diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 36688f2..3521c12 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -94,7 +94,8 @@ value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t DivideError, BoundsError, Error, KeyError, EnumerationError; value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym; value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym; -value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym; +value_t printwidthsym, printreadablysym; +value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym; static value_t apply_cl(uint32_t nargs); static value_t *alloc_words(int n); @@ -1486,6 +1487,7 @@ static void lisp_init(void) tsym = symbol("t"); Tsym = symbol("T"); fsym = symbol("f"); Fsym = symbol("F"); set(printprettysym=symbol("*print-pretty*"), FL_T); + set(printreadablysym=symbol("*print-readably*"), FL_T); set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH)); lasterror = NIL; i = 0; @@ -1606,7 +1608,7 @@ int main(int argc, char *argv[]) } FL_CATCH { ios_puts("fatal error during bootstrap:\n", ios_stderr); - print(ios_stderr, lasterror, 0); + print(ios_stderr, lasterror); ios_putc('\n', ios_stderr); return 1; } diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index c848234..70ffd18 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -125,12 +125,14 @@ extern value_t NIL, FL_T, FL_F; /* read, eval, print main entry points */ value_t read_sexpr(value_t f); -void print(ios_t *f, value_t v, int princ); +void print(ios_t *f, value_t v); value_t toplevel_eval(value_t expr); value_t apply(value_t f, value_t l); value_t applyn(uint32_t n, value_t f, ...); value_t load_file(char *fname); +extern value_t printprettysym, printreadablysym, printwidthsym; + /* object model manipulation */ value_t fl_cons(value_t a, value_t b); value_t list2(value_t a, value_t b); @@ -167,7 +169,7 @@ static inline void argcount(char *fname, uint32_t nargs, uint32_t c) } typedef struct { - void (*print)(value_t self, ios_t *f, int princ); + void (*print)(value_t self, ios_t *f); void (*relocate)(value_t oldv, value_t newv); void (*finalize)(value_t self); void (*print_traverse)(value_t self); @@ -178,7 +180,7 @@ value_t relocate_lispvalue(value_t v); void print_traverse(value_t v); void fl_print_chr(char c, ios_t *f); void fl_print_str(char *s, ios_t *f); -void fl_print_child(ios_t *f, value_t v, int princ); +void fl_print_child(ios_t *f, value_t v); typedef int (*cvinitfunc_t)(struct _fltype_t*, value_t, void*); diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c index 8deb2f4..3631cea 100644 --- a/femtolisp/iostream.c +++ b/femtolisp/iostream.c @@ -11,10 +11,9 @@ static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym; static value_t instrsym, outstrsym; fltype_t *iostreamtype; -void print_iostream(value_t v, ios_t *f, int princ) +void print_iostream(value_t v, ios_t *f) { (void)v; - (void)princ; fl_print_str("#", f); } @@ -167,24 +166,27 @@ value_t fl_ioseek(value_t *args, u_int32_t nargs) return FL_T; } -static void do_ioprint(value_t *args, u_int32_t nargs, int princ, char *fname) +static void do_ioprint(value_t *args, u_int32_t nargs, char *fname) { if (nargs < 2 || nargs > MAX_ARGS) argcount(fname, nargs, 2); ios_t *s = toiostream(args[0], fname); unsigned i; for (i=1; i < nargs; i++) { - print(s, args[i], princ); + print(s, args[i]); } } value_t fl_ioprint(value_t *args, u_int32_t nargs) { - do_ioprint(args, nargs, 0, "io.print"); + do_ioprint(args, nargs, "io.print"); return args[nargs-1]; } value_t fl_ioprinc(value_t *args, u_int32_t nargs) { - do_ioprint(args, nargs, 1, "io.princ"); + value_t oldpr = symbol_value(printreadablysym); + set(printreadablysym, FL_F); + do_ioprint(args, nargs, "io.princ"); + set(printreadablysym, oldpr); return args[nargs-1]; } diff --git a/femtolisp/print.c b/femtolisp/print.c index 9810945..eb3076d 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -1,6 +1,7 @@ static htable_t printconses; static u_int32_t printlabel; static int print_pretty; +static int print_princ; static int SCR_WIDTH = 80; static int HPOS, VPOS; @@ -247,7 +248,7 @@ static int blockindent(value_t v) return (allsmallp(v) > 9); } -static void print_pair(ios_t *f, value_t v, int princ) +static void print_pair(ios_t *f, value_t v) { value_t cd; char *op = NULL; @@ -262,7 +263,7 @@ static void print_pair(ios_t *f, value_t v, int princ) unmark_cons(v); unmark_cons(cdr_(v)); outs(op, f); - fl_print_child(f, car_(cdr_(v)), princ); + fl_print_child(f, car_(cdr_(v))); return; } int startpos = HPOS; @@ -277,20 +278,20 @@ static void print_pair(ios_t *f, value_t v, int princ) while (1) { lastv = VPOS; unmark_cons(v); - fl_print_child(f, car_(v), princ); + fl_print_child(f, car_(v)); cd = cdr_(v); if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) { if (cd != NIL) { outsn(" . ", f, 3); - fl_print_child(f, cd, princ); + fl_print_child(f, cd); } outc(')', f); break; } - if (princ || !print_pretty || + if (!print_pretty || ((head == LAMBDA || head == labelsym) && n == 0)) { - // never break line before lambda-list or in princ + // never break line before lambda-list ind = 0; } else { @@ -337,9 +338,9 @@ static void print_pair(ios_t *f, value_t v, int princ) } } -static void cvalue_print(ios_t *f, value_t v, int princ); +static void cvalue_print(ios_t *f, value_t v); -void fl_print_child(ios_t *f, value_t v, int princ) +void fl_print_child(ios_t *f, value_t v) { value_t label; char *name; @@ -349,7 +350,7 @@ void fl_print_child(ios_t *f, value_t v, int princ) case TAG_NUM1: HPOS+=ios_printf(f, "%ld", numval(v)); break; case TAG_SYM: name = symbol_name(v); - if (princ) + if (print_princ) outs(name, f); else if (ismanaged(v)) { outsn("#:", f, 2); @@ -369,7 +370,7 @@ void fl_print_child(ios_t *f, value_t v, int princ) outsn("()", f, 2); } else if (isbuiltin(v)) { - if (!princ) + if (!print_princ) outsn("#.", f, 2); outs(builtin_names[uintval(v)], f); } @@ -380,13 +381,13 @@ void fl_print_child(ios_t *f, value_t v, int princ) char *data = cvalue_data(fn->bcode); size_t i, sz = cvalue_len(fn->bcode); for(i=0; i < sz; i++) data[i] += 48; - fl_print_child(f, fn->bcode, 0); + fl_print_child(f, fn->bcode); for(i=0; i < sz; i++) data[i] -= 48; outc(' ', f); - fl_print_child(f, fn->vals, 0); + fl_print_child(f, fn->vals); if (fn->env != NIL) { outc(' ', f); - fl_print_child(f, fn->env, 0); + fl_print_child(f, fn->env); } outc(')', f); } @@ -410,9 +411,9 @@ void fl_print_child(ios_t *f, value_t v, int princ) unmark_cons(v); int i, sz = vector_size(v); for(i=0; i < sz; i++) { - fl_print_child(f, vector_elt(v,i), princ); + fl_print_child(f, vector_elt(v,i)); if (i < sz-1) { - if (princ || !print_pretty) { + if (!print_pretty) { outc(' ', f); } else { @@ -434,10 +435,10 @@ void fl_print_child(ios_t *f, value_t v, int princ) if (iscvalue(v) || iscprim(v)) { if (ismanaged(v)) unmark_cons(v); - cvalue_print(f, v, princ); + cvalue_print(f, v); break; } - print_pair(f, v, princ); + print_pair(f, v); break; } } @@ -479,13 +480,13 @@ static numerictype_t sym_to_numtype(value_t type); // printing in a context where a type is already implied, e.g. inside // an array. static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, - int princ, int weak) + int weak) { int64_t tmp=0; if (type == bytesym) { unsigned char ch = *(unsigned char*)data; - if (princ) + if (print_princ) outc(ch, f); else if (weak) HPOS+=ios_printf(f, "0x%hhx", ch); @@ -495,11 +496,11 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, else if (type == wcharsym) { uint32_t wc = *(uint32_t*)data; char seq[8]; - if (princ || iswprint(wc)) { + if (print_princ || iswprint(wc)) { size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1); seq[nb] = '\0'; // TODO: better multibyte handling - if (!princ) outsn("#\\", f, 2); + if (!print_princ) outsn("#\\", f, 2); outs(seq, f); } else { @@ -512,8 +513,8 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, #endif ) { int64_t i64 = *(int64_t*)data; - if (fits_fixnum(i64) || princ) { - if (weak || princ) + if (fits_fixnum(i64) || print_princ) { + if (weak || print_princ) HPOS+=ios_printf(f, "%lld", i64); else HPOS+=ios_printf(f, "#%s(%lld)", symbol_name(type), i64); @@ -529,8 +530,8 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, #endif ) { uint64_t ui64 = *(uint64_t*)data; - if (fits_fixnum(ui64) || princ) { - if (weak || princ) + if (fits_fixnum(ui64) || print_princ) { + if (weak || print_princ) HPOS+=ios_printf(f, "%llu", ui64); else HPOS+=ios_printf(f, "#%s(%llu)", symbol_name(type), ui64); @@ -552,7 +553,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, rep = sign_bit(d) ? "-NaN" : "+NaN"; else rep = sign_bit(d) ? "-Inf" : "+Inf"; - if (type == floatsym && !princ && !weak) + if (type == floatsym && !print_princ && !weak) HPOS+=ios_printf(f, "#%s(%s)", symbol_name(type), rep); else outs(rep, f); @@ -562,7 +563,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, outsn("-0.0", f, 4); else outsn("0.0", f, 3); - if (type == floatsym && !princ && !weak) + if (type == floatsym && !print_princ && !weak) outc('f', f); } else { @@ -570,7 +571,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, int hasdec = (strpbrk(buf, ".eE") != NULL); outs(buf, f); if (!hasdec) outsn(".0", f, 2); - if (type == floatsym && !princ && !weak) + if (type == floatsym && !print_princ && !weak) outc('f', f); } } @@ -578,8 +579,8 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, // handle other integer prims. we know it's smaller than 64 bits // at this point, so int64 is big enough to capture everything. tmp = conv_to_int64(data, sym_to_numtype(type)); - if (fits_fixnum(tmp) || princ) { - if (weak || princ) + if (fits_fixnum(tmp) || print_princ) { + if (weak || print_princ) HPOS+=ios_printf(f, "%lld", tmp); else HPOS+=ios_printf(f, "#%s(%lld)", symbol_name(type), tmp); @@ -603,7 +604,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, cnt = elsize ? len/elsize : 0; } if (eltype == bytesym) { - if (princ) { + if (print_princ) { ios_write(f, data, len); } else { @@ -623,7 +624,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, } else { outsn("#array(", f, 7); - fl_print_child(f, eltype, princ); + fl_print_child(f, eltype); if (cnt > 0) outc(' ', f); } @@ -634,7 +635,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, for(i=0; i < cnt; i++) { if (i > 0) outc(' ', f); - cvalue_printdata(f, data, elsize, eltype, princ, 1); + cvalue_printdata(f, data, elsize, eltype, 1); data += elsize; } if (!weak) @@ -648,14 +649,14 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, assert(isvector(syms)); if (!weak) { outsn("#enum(", f, 6); - fl_print_child(f, syms, princ); + fl_print_child(f, syms); outc(' ', f); } if (n >= (int)vector_size(syms)) { - cvalue_printdata(f, data, len, int32sym, princ, 1); + cvalue_printdata(f, data, len, int32sym, 1); } else { - fl_print_child(f, vector_elt(syms, n), princ); + fl_print_child(f, vector_elt(syms, n)); } if (!weak) outc(')', f); @@ -663,7 +664,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, } } -static void cvalue_print(ios_t *f, value_t v, int princ) +static void cvalue_print(ios_t *f, value_t v) { cvalue_t *cv = (cvalue_t*)ptr(v); void *data = cptr(v); @@ -677,7 +678,7 @@ static void cvalue_print(ios_t *f, value_t v, int princ) (unsigned long)(builtin_t)fptr); } else { - if (princ) + if (print_princ) outs(symbol_name(label), f); else HPOS += ios_printf(f, "#builtin(%s)", symbol_name(label)); @@ -685,12 +686,12 @@ static void cvalue_print(ios_t *f, value_t v, int princ) } else if (cv_class(cv)->vtable != NULL && cv_class(cv)->vtable->print != NULL) { - cv_class(cv)->vtable->print(v, f, princ); + cv_class(cv)->vtable->print(v, f); } else { value_t type = cv_type(cv); size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv); - cvalue_printdata(f, data, len, type, princ, 0); + cvalue_printdata(f, data, len, type, 0); } } @@ -701,16 +702,17 @@ static void set_print_width() SCR_WIDTH = numval(pw); } -void print(ios_t *f, value_t v, int princ) +void print(ios_t *f, value_t v) { print_pretty = (symbol_value(printprettysym) != FL_F); if (print_pretty) set_print_width(); + print_princ = (symbol_value(printreadablysym) == FL_F); printlabel = 0; print_traverse(v); HPOS = VPOS = 0; - fl_print_child(f, v, princ); + fl_print_child(f, v); htable_reset(&printconses, 32); } diff --git a/femtolisp/string.c b/femtolisp/string.c index 8ec9e96..a501e55 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -110,9 +110,15 @@ value_t fl_string(value_t *args, u_int32_t nargs) value_t arg, buf = fl_buffer(NULL, 0); ios_t *s = value2c(ios_t*,buf); uint32_t i; + value_t oldpr = symbol_value(printreadablysym); + value_t oldpp = symbol_value(printprettysym); + set(printreadablysym, FL_F); + set(printprettysym, FL_F); FOR_ARGS(i,0,arg,args) { - print(s, args[i], 1); + print(s, args[i]); } + set(printreadablysym, oldpr); + set(printprettysym, oldpp); PUSH(buf); value_t outp = stream_to_string(&Stack[SP-1]); (void)POP(); diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 7ebe874..b32adce 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -440,10 +440,12 @@ (raise ,e)))))) (define-macro (unwind-protect expr finally) - (let ((e (gensym))) - `(prog1 (trycatch ,expr - (lambda (,e) (begin ,finally (raise ,e)))) - ,finally))) + (let ((e (gensym)) + (thk (gensym))) + `(let ((,thk (lambda () ,finally))) + (prog1 (trycatch ,expr + (lambda (,e) (begin (,thk) (raise ,e)))) + (,thk))))) ; debugging utilities --------------------------------------------------------- diff --git a/femtolisp/table.c b/femtolisp/table.c index e28e90d..a85539c 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -11,7 +11,7 @@ static value_t tablesym; static fltype_t *tabletype; -void print_htable(value_t v, ios_t *f, int princ) +void print_htable(value_t v, ios_t *f) { htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(v)); size_t i; @@ -20,9 +20,9 @@ void print_htable(value_t v, ios_t *f, int princ) for(i=0; i < h->size; i+=2) { if (h->table[i+1] != HT_NOTFOUND) { if (!first) fl_print_str(" ", f); - fl_print_child(f, (value_t)h->table[i], princ); + fl_print_child(f, (value_t)h->table[i]); fl_print_chr(' ', f); - fl_print_child(f, (value_t)h->table[i+1], princ); + fl_print_child(f, (value_t)h->table[i+1]); first = 0; } } diff --git a/femtolisp/todo b/femtolisp/todo index 0a9001a..d08c844 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -1025,10 +1025,12 @@ new evaluator todo: * trycatch should require 2nd arg to be a lambda expression * immediate load int8 instruction - fix equal? on functions +- store function name and signature - maxstack calculation, replace Stack with C stack, alloca - stack traces and better debugging support - lambda lifting * let optimization +- let eversion * have macroexpand use its own global syntax table * be able to create/load an image file - fix trace and untrace