shithub: femtolisp

Download patch

ref: 63edc82ba49e51389c202e2e17f8a63f6702cea6
parent: 264df1f90b03973340fd96d85cbec744af77a65d
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Tue May 5 00:01:06 EDT 2009

using global variables uniformly for print settings instead of passing
around one of them
fixing unwind-protect not to duplicate code


--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -94,7 +94,8 @@
 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 @@
     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 @@
     }
     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;
     }
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -125,12 +125,14 @@
 
 /* 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 @@
 }
 
 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 @@
 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*);
 
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -11,10 +11,9 @@
 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("#<io stream>", f);
 }
 
@@ -167,7 +166,7 @@
     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);
@@ -174,17 +173,20 @@
     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];
 }
 
--- 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 @@
     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 @@
         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 @@
     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 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 @@
     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 @@
             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 @@
             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 @@
             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 @@
         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 @@
 // 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 @@
     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 @@
 #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 @@
 #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 @@
                 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 @@
                 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 @@
             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 @@
         // 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 @@
                 cnt = elsize ? len/elsize : 0;
             }
             if (eltype == bytesym) {
-                if (princ) {
+                if (print_princ) {
                     ios_write(f, data, len);
                 }
                 else {
@@ -623,7 +624,7 @@
                 }
                 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 @@
             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 @@
             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_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 @@
                                (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 @@
     }
     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 @@
     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);
 }
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -110,9 +110,15 @@
     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();
--- 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 ---------------------------------------------------------
 
--- 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 @@
     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;
         }
     }
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1025,10 +1025,12 @@
 * 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