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)