lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixing bug printing functions involved in cycles

This commit is contained in:
JeffBezanson 2009-05-21 00:56:25 +00:00
parent 99c17feac1
commit 1ee81e2625
3 changed files with 24 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
femtolisp/cps.lsp
View File

@ -274,7 +274,7 @@
(shift yk (shift yk
(begin (set! ,ko yk) (begin (set! ,ko yk)
(set! ,cur v)))))) (set! ,cur v))))))
,(f-body body)))))))))) ,@body)))))))))
; a test case ; a test case
(define-generator (range-iterator lo hi) (define-generator (range-iterator lo hi)

37
femtolisp/print.c
View File

@ -340,9 +340,24 @@ static void print_pair(ios_t *f, value_t v)
static void cvalue_print(ios_t *f, value_t v); 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; 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; char *name;
switch (tag(v)) { switch (tag(v)) {
@ -376,6 +391,7 @@ void fl_print_child(ios_t *f, value_t v)
} }
else { else {
assert(isclosure(v)); assert(isclosure(v));
if (print_circle_prefix(f, v)) return;
function_t *fn = (function_t*)ptr(v); function_t *fn = (function_t*)ptr(v);
outs("#function(", f); outs("#function(", f);
char *data = cvalue_data(fn->bcode); char *data = cvalue_data(fn->bcode);
@ -397,18 +413,10 @@ void fl_print_child(ios_t *f, value_t v)
if (v == UNBOUND) { outs("#<undefined>", f); break; } if (v == UNBOUND) { outs("#<undefined>", f); break; }
case TAG_VECTOR: case TAG_VECTOR:
case TAG_CONS: case TAG_CONS:
if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) != if (print_circle_prefix(f, v)) return;
(value_t)HT_NOTFOUND) {
if (!ismarked(v)) {
HPOS+=ios_printf(f, "#%ld#", numval(label));
return;
}
HPOS+=ios_printf(f, "#%ld=", numval(label));
}
if (isvector(v)) { if (isvector(v)) {
outc('[', f); outc('[', f);
int newindent = HPOS, est; int newindent = HPOS, est;
unmark_cons(v);
int i, sz = vector_size(v); int i, sz = vector_size(v);
for(i=0; i < sz; i++) { for(i=0; i < sz; i++) {
fl_print_child(f, vector_elt(v,i)); fl_print_child(f, vector_elt(v,i));
@ -432,13 +440,10 @@ void fl_print_child(ios_t *f, value_t v)
outc(']', f); outc(']', f);
break; break;
} }
if (iscvalue(v) || iscprim(v)) { if (iscvalue(v) || iscprim(v))
if (ismanaged(v))
unmark_cons(v);
cvalue_print(f, v); cvalue_print(f, v);
break; else
} print_pair(f, v);
print_pair(f, v);
break; break;
} }
} }

4
femtolisp/system.lsp
View File

@ -376,8 +376,8 @@
(let* ,(cdr binds) ,@body)) (let* ,(cdr binds) ,@body))
,(cadar binds)))) ,(cadar binds))))
(define-macro (when c . body) (list 'if c (f-body body) #f)) (define-macro (when c . body) (list 'if c (cons 'begin body) #f))
(define-macro (unless c . body) (list 'if c #f (f-body body))) (define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
(define-macro (case key . clauses) (define-macro (case key . clauses)
(define (vals->cond key v) (define (vals->cond key v)