shithub: femtolisp

Download patch

ref: 1ee81e2625d31562e3a43df2f935598e8dd31068
parent: 99c17feac1cd1e5bb7d0b1d3b3793e2416f6f917
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed May 20 20:56:25 EDT 2009

fixing bug printing functions involved in cycles


--- a/femtolisp/cps.lsp
+++ b/femtolisp/cps.lsp
@@ -274,7 +274,7 @@
                         (shift yk
                                (begin (set! ,ko  yk)
                                       (set! ,cur v))))))
-                 ,(f-body body))))))))))
+                 ,@body)))))))))
 
 ; a test case
 (define-generator (range-iterator lo hi)
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -340,9 +340,24 @@
 
 static void cvalue_print(ios_t *f, value_t v);
 
-void fl_print_child(ios_t *f, value_t v)
+static int print_circle_prefix(ios_t *f, value_t v)
 {
     value_t label;
+    if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
+        (value_t)HT_NOTFOUND) {
+        if (!ismarked(v)) {
+            HPOS+=ios_printf(f, "#%ld#", numval(label));
+            return 1;
+        }
+        HPOS+=ios_printf(f, "#%ld=", numval(label));
+    }
+    if (ismanaged(v))
+        unmark_cons(v);
+    return 0;
+}
+
+void fl_print_child(ios_t *f, value_t v)
+{
     char *name;
 
     switch (tag(v)) {
@@ -376,6 +391,7 @@
         }
         else {
             assert(isclosure(v));
+            if (print_circle_prefix(f, v)) return;
             function_t *fn = (function_t*)ptr(v);
             outs("#function(", f);
             char *data = cvalue_data(fn->bcode);
@@ -397,18 +413,10 @@
       if (v == UNBOUND) { outs("#<undefined>", f); break; }
     case TAG_VECTOR:
     case TAG_CONS:
-        if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
-            (value_t)HT_NOTFOUND) {
-            if (!ismarked(v)) {
-                HPOS+=ios_printf(f, "#%ld#", numval(label));
-                return;
-            }
-            HPOS+=ios_printf(f, "#%ld=", numval(label));
-        }
+        if (print_circle_prefix(f, v)) return;
         if (isvector(v)) {
             outc('[', f);
             int newindent = HPOS, est;
-            unmark_cons(v);
             int i, sz = vector_size(v);
             for(i=0; i < sz; i++) {
                 fl_print_child(f, vector_elt(v,i));
@@ -432,13 +440,10 @@
             outc(']', f);
             break;
         }
-        if (iscvalue(v) || iscprim(v)) {
-            if (ismanaged(v))
-                unmark_cons(v);
+        if (iscvalue(v) || iscprim(v))
             cvalue_print(f, v);
-            break;
-        }
-        print_pair(f, v);
+        else
+            print_pair(f, v);
         break;
     }
 }
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -376,8 +376,8 @@
 	  (let* ,(cdr binds) ,@body))
 	,(cadar binds))))
 
-(define-macro (when   c . body) (list 'if c (f-body body) #f))
-(define-macro (unless c . body) (list 'if c #f (f-body body)))
+(define-macro (when   c . body) (list 'if c (cons 'begin body) #f))
+(define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
 
 (define-macro (case key . clauses)
   (define (vals->cond key v)