shithub: femtolisp

Download patch

ref: 46f2f47b1405c0f644e6d3dd5b8cdf458c458814
parent: c3811312a7820de1b9a2aaca5ae7efa52cb611fa
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Mon Aug 4 21:43:12 EDT 2008

switched to 3-bit type tags for simpler checking
fixnums still have 30 bits

moving towards making "guest functions" more opaque; their type is now
just 'builtin

pretty printing some forms better: defun, defmacro, for, label
support *print-pretty*



--- a/femtolisp/Makefile
+++ b/femtolisp/Makefile
@@ -32,6 +32,7 @@
 
 debug: $(DOBJS) $(LIBS)
 	$(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
+	make test
 
 release: $(OBJS) $(LIBS)
 	$(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS)
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -451,8 +451,7 @@
     size_t sl = u8_seqlen(&s[i]);
     if (sl > len || i > len-sl)
         bounds_error("string.char", args[0], args[1]);
-    value_t ccode = fixnum(u8_nextchar(s, &i));
-    return cvalue_char(&ccode, 1);
+    return char_from_code(u8_nextchar(s, &i));
 }
 
 value_t fl_time_now(value_t *args, u_int32_t nargs)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -90,7 +90,7 @@
         pcp->flags.inlined = 1;
         pcp->flags.prim = 1;
         pcp->type = type;
-        return tagptr(pcp, TAG_BUILTIN);
+        return tagptr(pcp, TAG_CVALUE);
     }
     PUSH(type);
     if (sz <= MAX_INL_SIZE) {
@@ -110,7 +110,7 @@
     }
     pcv->deps = NIL;
     pcv->type = POP();
-    return tagptr(pcv, TAG_BUILTIN);
+    return tagptr(pcv, TAG_CVALUE);
 }
 
 value_t cvalue_from_data(value_t type, void *data, size_t sz)
@@ -149,7 +149,7 @@
     if (parent != NIL) {
         // TODO: add dependency
     }
-    cv = tagptr(pcv, TAG_BUILTIN);
+    cv = tagptr(pcv, TAG_CVALUE);
     return cv;
 }
 
@@ -319,6 +319,14 @@
     return 0;
 }
 
+value_t char_from_code(uint32_t code)
+{
+    value_t ccode = fixnum(code);
+    if (code > 0x7f)
+        return cvalue_wchar(&ccode, 1);
+    return cvalue_char(&ccode, 1);
+}
+
 static void cvalue_enum_init(value_t *args, u_int32_t nargs, void *dest,
                              void *data)
 {
@@ -507,7 +515,7 @@
     if (!cv->flags.islispfunction) {
         nv = (cvalue_t*)alloc_words(nw);
         memcpy(nv, cv, nw*sizeof(value_t));
-        ncv = tagptr(nv, TAG_BUILTIN);
+        ncv = tagptr(nv, TAG_CVALUE);
         cv->type = ncv;
         cv->flags.moved = 1;
     }
@@ -637,13 +645,11 @@
     argcount("typeof", nargs, 1);
     switch(tag(args[0])) {
     case TAG_CONS: return conssym;
+    case TAG_NUM1:
     case TAG_NUM:  return fixnumsym;
     case TAG_SYM:  return symbolsym;
-    case TAG_BUILTIN:
-        if (isbuiltin(args[0]))
-            return builtinsym;
-        if (discriminateAsVector(args[0]))
-            return vectorsym;
+    case TAG_VECTOR: return vectorsym;
+    case TAG_BUILTIN: return builtinsym;
     }
     return cv_type((cvalue_t*)ptr(args[0]));
 }
@@ -669,7 +675,7 @@
         autorelease((cvalue_t*)pnv);
     }
 
-    return tagptr(pnv, TAG_BUILTIN);
+    return tagptr(pnv, TAG_CVALUE);
 }
 
 static void cvalue_init(value_t type, value_t *vs, u_int32_t nv, void *dest)
@@ -852,7 +858,7 @@
     // directly-callable values are assumed not to move for
     // evaluator performance, so put guestfunction metadata on the
     // unmanaged heap
-    cvalue_t *buf = malloc(nw * sizeof(value_t));
+    cvalue_t *buf = malloc_aligned(nw * sizeof(value_t), 8);
     memcpy(buf, ptr(gf), nw*sizeof(value_t));
     return tagptr(buf, TAG_BUILTIN);
 }
--- a/femtolisp/equal.c
+++ b/femtolisp/equal.c
@@ -7,11 +7,8 @@
 #include "llt.h"
 #include "flisp.h"
 
-// is it a leaf? (i.e. does not lead to other values)
-static inline int leafp(value_t a)
-{
-    return (!iscons(a) && !isvector(a));
-}
+// comparable tag
+#define cmptag(v) (isfixnum(v) ? TAG_NUM : tag(v))
 
 static value_t eq_class(ptrhash_t *table, value_t key)
 {
@@ -80,8 +77,11 @@
     if (a == b) return fixnum(0);
     if (bound <= 0)
         return NIL;
-    switch (tag(a)) {
-    case TAG_NUM:
+    int taga = tag(a);
+    int tagb = cmptag(b);
+    switch (taga) {
+    case TAG_NUM :
+    case TAG_NUM1:
         if (isfixnum(b)) {
             return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
         }
@@ -90,24 +90,15 @@
         }
         return fixnum(-1);
     case TAG_SYM:
-        if (tag(b) < TAG_SYM) return fixnum(1);
-        if (tag(b) > TAG_SYM) return fixnum(-1);
+        if (tagb < TAG_SYM) return fixnum(1);
+        if (tagb > TAG_SYM) return fixnum(-1);
         return fixnum(strcmp(symbol_name(a), symbol_name(b)));
-    case TAG_BUILTIN:
-        if (tag(b) > TAG_BUILTIN) return fixnum(-1);
-        if (tag(b) == TAG_BUILTIN) {
-            if (uintval(a) < N_BUILTINS || uintval(b) < N_BUILTINS) {
-                return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
-            }
-            if (discriminateAsVector(a)) {
-                if (discriminateAsVector(b))
-                    return bounded_vector_compare(a, b, bound);
-                return fixnum(1);
-            }
-            if (discriminateAsVector(b))
-                return fixnum(-1);
-            assert(iscvalue(a));
-            assert(iscvalue(b));
+    case TAG_VECTOR:
+        if (isvector(b))
+            return bounded_vector_compare(a, b, bound);
+        break;
+    case TAG_CVALUE:
+        if (iscvalue(b)) {
             cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b);
             numerictype_t at, bt;
             if (valid_numtype(at=cv_numtype(acv)) &&
@@ -122,10 +113,17 @@
             }
             return cvalue_compare(a, b);
         }
-        assert(isfixnum(b));
-        return fixnum(-compare_num_cvalue(b, a));
+        else if (isfixnum(b)) {
+            return fixnum(-compare_num_cvalue(b, a));
+        }
+        break;
+    case TAG_BUILTIN:
+        if (tagb == TAG_BUILTIN) {
+            return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
+        }
+        break;
     case TAG_CONS:
-        if (tag(b) < TAG_CONS) return fixnum(1);
+        if (tagb < TAG_CONS) return fixnum(1);
         d = bounded_compare(car_(a), car_(b), bound-1);
         if (numval(d) != 0) return d;
         a = cdr_(a); b = cdr_(b);
@@ -132,7 +130,7 @@
         bound--;
         goto compare_top;
     }
-    return NIL;
+    return (taga < tagb) ? fixnum(-1) : fixnum(1);
 }
 
 static value_t cyc_vector_compare(value_t a, value_t b, ptrhash_t *table)
@@ -151,10 +149,10 @@
             d = bounded_compare(xa, xb, 1);
             if (numval(d)!=0) return d;
         }
-        else if (tag(xa) < tag(xb)) {
+        else if (cmptag(xa) < cmptag(xb)) {
             return fixnum(-1);
         }
-        else if (tag(xa) > tag(xb)) {
+        else if (cmptag(xa) > cmptag(xb)) {
             return fixnum(1);
         }
     }
@@ -189,22 +187,24 @@
         if (iscons(b)) {
             value_t aa = car_(a); value_t da = cdr_(a);
             value_t ab = car_(b); value_t db = cdr_(b);
+            int tagaa = cmptag(aa); int tagda = cmptag(da);
+            int tagab = cmptag(ab); int tagdb = cmptag(db);
             value_t d, ca, cb;
             if (leafp(aa) || leafp(ab)) {
                 d = bounded_compare(aa, ab, 1);
                 if (numval(d)!=0) return d;
             }
-            else if (tag(aa) < tag(ab))
+            else if (tagaa < tagab)
                 return fixnum(-1);
-            else if (tag(aa) > tag(ab))
+            else if (tagaa > tagab)
                 return fixnum(1);
             if (leafp(da) || leafp(db)) {
                 d = bounded_compare(da, db, 1);
                 if (numval(d)!=0) return d;
             }
-            else if (tag(da) < tag(db))
+            else if (tagda < tagdb)
                 return fixnum(-1);
-            else if (tag(da) > tag(db))
+            else if (tagda > tagdb)
                 return fixnum(1);
 
             ca = eq_class(table, a);
@@ -246,5 +246,5 @@
     bp once and use it twice.
   - preallocate hash table and call reset() instead of new/free
   - specialized version for equal (unordered comparison)
-  - less redundant tag checking, 3-bit tags
+  * less redundant tag checking, 3-bit tags
 */
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -74,11 +74,12 @@
 value_t Stack[N_STACK];
 u_int32_t SP = 0;
 
-value_t NIL, T, LAMBDA, QUOTE, VECTOR, IF, TRYCATCH;
+value_t NIL, T, LAMBDA, QUOTE, IF, TRYCATCH;
 value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
 value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
 value_t DivideError, BoundsError, Error;
 value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
+value_t defunsym, defmacrosym, forsym, labelsym, printprettysym;
 
 static value_t eval_sexpr(value_t e, uint32_t penv, int tail);
 static value_t *alloc_words(int n);
@@ -193,7 +194,9 @@
 {
     symbol_t *sym;
 
-    sym = (symbol_t*)malloc(sizeof(symbol_t) - sizeof(void*) + strlen(str)+1);
+    sym = (symbol_t*)malloc_aligned(sizeof(symbol_t)-sizeof(void*) +
+                                        strlen(str)+1,
+                                    8);
     sym->left = sym->right = NULL;
     sym->binding = UNBOUND;
     sym->syntax = 0;
@@ -297,8 +300,8 @@
 {
     value_t *first;
 
-    // the minimum allocation is a 2-word block
-    if (n < 2) n = 2;
+    if (n < 2) n = 2;  // the minimum allocation is a 2-word block
+    n = ALIGN(n, 2);   // only allocate multiples of 2 words
     if ((value_t*)curheap > ((value_t*)lim)+2-n) {
         gc(0);
         while ((value_t*)curheap > ((value_t*)lim)+2-n) {
@@ -321,7 +324,7 @@
 value_t alloc_vector(size_t n, int init)
 {
     value_t *c = alloc_words(n+1);
-    value_t v = tagptr(c, TAG_BUILTIN);
+    value_t v = tagptr(c, TAG_VECTOR);
     vector_setsize(v, n);
     if (init) {
         unsigned int i;
@@ -369,35 +372,32 @@
 
         return first;
     }
-    else if (isvectorish(v)) {
-        if (discriminateAsVector(v)) {
-            // 0-length vectors secretly have space for a first element
-            if (vector_elt(v,0) == UNBOUND)
-                return vector_elt(v,-1);
-            size_t i, newsz, sz = vector_size(v);
-            newsz = sz;
-            if (vector_elt(v,-1) & 0x1)
-                newsz += vector_grow_amt(sz);
-            nc = alloc_vector(newsz, 0);
-            a = vector_elt(v,0);
-            vector_elt(v,0) = UNBOUND;
-            vector_elt(v,-1) = nc;
-            i = 0;
-            if (sz > 0) {
-                vector_elt(nc,0) = relocate(a); i++;
-                for(; i < sz; i++)
-                    vector_elt(nc,i) = relocate(vector_elt(v,i));
-            }
-            for(; i < newsz; i++)
-                vector_elt(nc,i) = NIL;
-            return nc;
+    else if (isvector(v)) {
+        // 0-length vectors secretly have space for a first element
+        if (vector_elt(v,0) == UNBOUND)
+            return vector_elt(v,-1);
+        size_t i, newsz, sz = vector_size(v);
+        newsz = sz;
+        if (vector_elt(v,-1) & 0x1)
+            newsz += vector_grow_amt(sz);
+        nc = alloc_vector(newsz, 0);
+        a = vector_elt(v,0);
+        vector_elt(v,0) = UNBOUND;
+        vector_elt(v,-1) = nc;
+        i = 0;
+        if (sz > 0) {
+            vector_elt(nc,0) = relocate(a); i++;
+            for(; i < sz; i++)
+                vector_elt(nc,i) = relocate(vector_elt(v,i));
         }
-        else {
-            return cvalue_relocate(v);
-        }
+        for(; i < newsz; i++)
+            vector_elt(nc,i) = NIL;
+        return nc;
     }
-    else if (ismanaged(v)) {
-        assert(issymbol(v));
+    else if (iscvalue(v)) {
+        return cvalue_relocate(v);
+    }
+    else if (ismanaged(v) && issymbol(v)) {
         gensym_t *gs = (gensym_t*)ptr(v);
         if (gs->id == 0xffffffff)
             return gs->binding;
@@ -461,7 +461,7 @@
     // more space to fill next time. if we grew tospace last time,
     // grow the other half of the heap this time to catch up.
     if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {
-        temp = realloc(tospace, grew ? heapsize : heapsize*2);
+        temp = realloc_aligned(tospace, grew ? heapsize : heapsize*2, 16);
         if (temp == NULL)
             lerror(MemoryError, "out of memory");
         tospace = temp;
@@ -681,7 +681,7 @@
     }
     else f = eval(v);
     v = Stack[saveSP];
-    if (tag(f) == TAG_BUILTIN) {
+    if (isbuiltinish(f)) {
         // handle builtin function
         // evaluate argument list, placing arguments on stack
         while (iscons(v)) {
@@ -706,8 +706,8 @@
                 lenv = penv;
                 envsz = numval(Stack[penv-1]);
                 pv = alloc_words(envsz + 1);
-                PUSH(tagptr(pv, TAG_BUILTIN));
-                pv[0] = envsz<<2;
+                PUSH(tagptr(pv, TAG_VECTOR));
+                pv[0] = fixnum(envsz);
                 pv++;
                 while (envsz--)
                     *pv++ = Stack[penv++];
@@ -881,27 +881,25 @@
             break;
         case F_LENGTH:
             argcount("length", nargs, 1);
-            if (isvectorish(Stack[SP-1])) {
-                if (discriminateAsVector(Stack[SP-1])) {
-                    v = fixnum(vector_size(Stack[SP-1]));
+            if (isvector(Stack[SP-1])) {
+                v = fixnum(vector_size(Stack[SP-1]));
+                break;
+            }
+            else if (iscvalue(Stack[SP-1])) {
+                cv = (cvalue_t*)ptr(Stack[SP-1]);
+                v = cv_type(cv);
+                if (iscons(v) && car_(v) == arraysym) {
+                    v = size_wrap(cvalue_arraylen(Stack[SP-1]));
                     break;
                 }
-                else {
-                    cv = (cvalue_t*)ptr(Stack[SP-1]);
-                    v = cv_type(cv);
-                    if (iscons(v) && car_(v) == arraysym) {
-                        v = size_wrap(cvalue_arraylen(Stack[SP-1]));
-                        break;
-                    }
-                    else if (v == charsym) {
-                        v = fixnum(1);
-                        break;
-                    }
-                    else if (v == wcharsym) {
-                        v = fixnum(u8_charlen(*(wchar_t*)cv_data(cv)));
-                        break;
-                    }
+                else if (v == charsym) {
+                    v = fixnum(1);
+                    break;
                 }
+                else if (v == wcharsym) {
+                    v = fixnum(u8_charlen(*(wchar_t*)cv_data(cv)));
+                    break;
+                }
             }
             else if (Stack[SP-1] == NIL) {
                 v = fixnum(0); break;
@@ -963,7 +961,7 @@
             break;
         case F_BUILTINP:
             argcount("builtinp", nargs, 1);
-            v = (isbuiltin(Stack[SP-1]) ||
+            v = (isbuiltinish(Stack[SP-1]) ||
                  (iscvalue(Stack[SP-1]) &&
                   ((cvalue_t*)ptr(Stack[SP-1]))->flags.islispfunction))? T:NIL;
             break;
@@ -1094,7 +1092,7 @@
             break;
         case F_EQUAL:
             argcount("equal", nargs, 2);
-            if (!((Stack[SP-2] | Stack[SP-1])&0x1)) {
+            if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
                 v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL;
             }
             else {
@@ -1166,7 +1164,7 @@
             v = Stack[saveSP] = Stack[SP-1];  // second arg is new arglist
             f = Stack[SP-2];            // first arg is new function
             POPN(2);                    // pop apply's args
-            if (tag(f) == TAG_BUILTIN) {
+            if (isbuiltinish(f)) {
                 assert(!isspecial(f));
                 // unpack arglist onto the stack
                 while (iscons(v)) {
@@ -1178,8 +1176,9 @@
             noeval = 1;
             goto apply_lambda;
         default:
+            // a guest function is a cvalue tagged as a builtin
             cv = (cvalue_t*)ptr(f);
-            if (!discriminateAsVector(f) && cv->flags.islispfunction) {
+            if (cv->flags.islispfunction) {
                 v = ((guestfunc_t)cv->data)(&Stack[saveSP+1], nargs);
             }
             else {
@@ -1306,8 +1305,8 @@
 
     llt_init();
 
-    fromspace = malloc(heapsize);
-    tospace   = malloc(heapsize);
+    fromspace = malloc_aligned(heapsize, 16);
+    tospace   = malloc_aligned(heapsize, 16);
     curheap = fromspace;
     lim = curheap+heapsize-sizeof(cons_t);
     consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
@@ -1317,7 +1316,6 @@
     T   = symbol("T");   setc(T,   T);
     LAMBDA = symbol("lambda");
     QUOTE = symbol("quote");
-    VECTOR = symbol("vector");
     TRYCATCH = symbol("trycatch");
     BACKQUOTE = symbol("backquote");
     COMMA = symbol("*comma*");
@@ -1337,6 +1335,11 @@
     fixnumsym = symbol("fixnum");
     vectorsym = symbol("vector");
     builtinsym = symbol("builtin");
+    defunsym = symbol("defun");
+    defmacrosym = symbol("defmacro");
+    forsym = symbol("for");
+    labelsym = symbol("label");
+    set(printprettysym=symbol("*print-pretty*"), T);
     lasterror = NIL;
     lerrorbuf[0] = '\0';
     special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL);
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -28,33 +28,42 @@
 } symbol_t;
 
 #define TAG_NUM      0x0
-#define TAG_BUILTIN  0x1
-#define TAG_SYM      0x2
-#define TAG_CONS     0x3
-#define UNBOUND      ((value_t)TAG_SYM) // an invalid symbol pointer
+                   //0x1 unused
+#define TAG_BUILTIN  0x2
+#define TAG_VECTOR   0x3
+#define TAG_NUM1     0x4
+#define TAG_CVALUE   0x5
+#define TAG_SYM      0x6
+#define TAG_CONS     0x7
+#define UNBOUND      ((value_t)0x1) // an invalid value
 #define TAG_CONST    ((value_t)-2)  // in sym->syntax for constants
-#define tag(x) ((x)&0x3)
-#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tag(x) ((x)&0x7)
+#define ptr(x) ((void*)((x)&(~(value_t)0x7)))
 #define tagptr(p,t) (((value_t)(p)) | (t))
 #define fixnum(x) ((value_t)((x)<<2))
 #define numval(x)  (((fixnum_t)(x))>>2)
+#ifdef BITS64
+#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
+#else
 #define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0)
+#endif
 #define fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
-#define uintval(x)  (((unsigned int)(x))>>2)
-#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define uintval(x)  (((unsigned int)(x))>>3)
+#define builtin(n) tagptr((((int)n)<<3), TAG_BUILTIN)
 #define iscons(x)    (tag(x) == TAG_CONS)
 #define issymbol(x)  (tag(x) == TAG_SYM)
-#define isfixnum(x)  (tag(x) == TAG_NUM)
-#define bothfixnums(x,y) (tag((x)|(y)) == TAG_NUM)
+#define isfixnum(x)  (((x)&3) == TAG_NUM)
+#define bothfixnums(x,y) ((((x)|(y))&3) == TAG_NUM)
 #define isbuiltin(x) ((tag(x) == TAG_BUILTIN) && uintval(x) < N_BUILTINS)
-#define isvectorish(x) ((tag(x) == TAG_BUILTIN) && uintval(x) > N_BUILTINS)
-#define isvector(x) (isvectorish(x) && !(((value_t*)ptr(x))[0] & 0x2))
-#define iscvalue(x) (isvectorish(x) && (((value_t*)ptr(x))[0] & 0x2))
-#define selfevaluating(x) (tag(x)<0x2)
+#define isbuiltinish(x) (tag(x) == TAG_BUILTIN)
+#define isvector(x) (tag(x) == TAG_VECTOR)
+#define iscvalue(x) (tag(x) == TAG_CVALUE)
+#define selfevaluating(x) (tag(x)<0x6)
 // comparable with ==
 #define eq_comparable(a,b) (!(((a)|(b))&0x1))
-// distinguish a vector from a cvalue
-#define discriminateAsVector(x) (!(((value_t*)ptr(x))[0] & 0x2))
+// doesn't lead to other values
+#define leafp(a) (((a)&3) != 3)
+
 #define vector_size(v) (((size_t*)ptr(v))[0]>>2)
 #define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2))
 #define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)])
@@ -229,6 +238,7 @@
 int isnumber(value_t v);
 value_t cvalue_compare(value_t a, value_t b);
 value_t cvalue_char(value_t *args, uint32_t nargs);
+value_t cvalue_wchar(value_t *args, uint32_t nargs);
 
 value_t mk_double(double_t n);
 value_t mk_uint32(uint32_t n);
@@ -235,5 +245,6 @@
 value_t mk_uint64(uint64_t n);
 value_t return_from_uint64(uint64_t Uaccum);
 value_t return_from_int64(int64_t Saccum);
+value_t char_from_code(uint32_t code);
 
 #endif
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -1,5 +1,6 @@
 static ptrhash_t printconses;
 static u_int32_t printlabel;
+static int print_pretty;
 
 static int HPOS, VPOS;
 static void outc(char c, FILE *f)
@@ -43,25 +44,24 @@
     }
     if (!ismanaged(v) || issymbol(v))
         return;
-    if (isvectorish(v)) {
-        if (ismarked(v)) {
-            bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
-            if (*bp == (value_t)PH_NOTFOUND)
-                *bp = fixnum(printlabel++);
-            return;
-        }
-        if (discriminateAsVector(v)) {
-            mark_cons(v);
-            unsigned int i;
-            for(i=0; i < vector_size(v); i++)
-                print_traverse(vector_elt(v,i));
-        }
-        else {
-            cvalue_t *cv = (cvalue_t*)ptr(v);
-            // don't consider shared references to ""
-            if (!cv->flags.cstring || cv_len(cv)!=0)
-                mark_cons(v);
-        }
+    if (ismarked(v)) {
+        bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
+        if (*bp == (value_t)PH_NOTFOUND)
+            *bp = fixnum(printlabel++);
+        return;
+    }
+    if (isvector(v)) {
+        mark_cons(v);
+        unsigned int i;
+        for(i=0; i < vector_size(v); i++)
+            print_traverse(vector_elt(v,i));
+    }
+    else {
+        assert(iscvalue(v));
+        cvalue_t *cv = (cvalue_t*)ptr(v);
+        // don't consider shared references to ""
+        if (!cv->flags.cstring || cv_len(cv)!=0)
+            mark_cons(v);
     }
 }
 
@@ -119,7 +119,7 @@
 */
 static inline int tinyp(value_t v)
 {
-    return (issymbol(v) || isfixnum(v) || isbuiltin(v));
+    return (issymbol(v) || isfixnum(v) || isbuiltinish(v));
 }
 
 static int smallp(value_t v)
@@ -142,10 +142,11 @@
     return 0;
 }
 
-static int specialindent(value_t v)
+static int specialindent(value_t head)
 {
     // indent these forms 2 spaces, not lined up with the first argument
-    if (v == LAMBDA || v == TRYCATCH)
+    if (head == LAMBDA || head == TRYCATCH || head == defunsym ||
+        head == defmacrosym || head == forsym || head == labelsym)
         return 2;
     return -1;
 }
@@ -172,12 +173,19 @@
     return n;
 }
 
+static int indentafter3(value_t head, value_t v)
+{
+    // for certain X always indent (X a b c) after b
+    return ((head == defunsym || head == defmacrosym || head == forsym) &&
+            !allsmallp(cdr_(v)));
+}
+
 static int indentevery(value_t v)
 {
     // indent before every subform of a special form, unless every
     // subform is "small"
     value_t c = car_(v);
-    if (c == LAMBDA)
+    if (c == LAMBDA || c == labelsym)
         return 0;
     value_t f;
     if (issymbol(c) && (f=((symbol_t*)ptr(c))->syntax) && isspecial(f))
@@ -218,6 +226,7 @@
     int lastv, n=0, si, ind=0, est, always=0, nextsmall;
     if (!blk) always = indentevery(v);
     value_t head = car_(v);
+    int after3 = indentafter3(head, v);
     while (1) {
         lastv = VPOS;
         unmark_cons(v);
@@ -232,7 +241,8 @@
             break;
         }
 
-        if (princ || (head == LAMBDA && n == 0)) {
+        if (princ || !print_pretty ||
+            ((head == LAMBDA || head == labelsym) && n == 0)) {
             // never break line before lambda-list or in princ
             ind = 0;
         }
@@ -243,7 +253,7 @@
                     ((!nextsmall && HPOS>28) || (VPOS > lastv))) ||
                    
                    ((VPOS > lastv) && (!nextsmall || n==0)) ||
-
+                   
                    (HPOS > 50 && !nextsmall) ||
                    
                    (HPOS > 74) ||
@@ -250,9 +260,11 @@
                    
                    (est!=-1 && (HPOS+est > 78)) ||
                    
-                   (head == LAMBDA && !nextsmall) ||
+                   ((head == LAMBDA || head == labelsym) && !nextsmall) ||
                    
-                   (n > 0 && always));
+                   (n > 0 && always) ||
+                   
+                   (n == 2 && after3));
         }
 
         if (ind) {
@@ -282,7 +294,8 @@
     char *name;
 
     switch (tag(v)) {
-    case TAG_NUM: HPOS+=fprintf(f, "%ld", numval(v)); break;
+    case TAG_NUM :
+    case TAG_NUM1: HPOS+=fprintf(f, "%ld", numval(v)); break;
     case TAG_SYM:
         name = symbol_name(v);
         if (princ)
@@ -302,10 +315,10 @@
             outs(builtin_names[uintval(v)], f);
             break;
         }
-        if (!ismanaged(v)) {
-            assert(iscvalue(v));
-            cvalue_print(f, v, princ); break;
-        }
+        cvalue_print(f, v, princ);
+        break;
+    case TAG_CVALUE:
+    case TAG_VECTOR:
     case TAG_CONS:
         if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
             (value_t)PH_NOTFOUND) {
@@ -563,6 +576,7 @@
 
 void print(FILE *f, value_t v, int princ)
 {
+    print_pretty = (symbol_value(printprettysym) != NIL);
     ptrhash_reset(&printconses, 32);
     printlabel = 0;
     print_traverse(v);
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -28,7 +28,7 @@
   checking ismanaged()
 * eliminate compiler warnings
 * fix printing nan and inf
-- move to "2.5-bit" type tags
+* move to "2.5-bit" type tags
 ? builtin abs()
 - try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
   is acceptable
@@ -123,6 +123,7 @@
  . disadvantage is looking through the lambda list on every lookup. maybe
    improve by making lambda lists vectors somehow?
 * fast builtin bounded iteration construct (for lo hi (lambda (x) ...))
+- represent guest function as a tagged function pointer; allocate nothing
 
 bugs:
 * with the fully recursive (simpler) relocate(), the size of cons chains
@@ -862,8 +863,8 @@
 * write try_predict_len that gives a length for easy cases like
   symbols, else -1. use it to avoid wrapping symbols around lines
 
-- print defun and defmacro more like lambda (2 spaces)
+* print defun, defmacro, label, for more like lambda (2 spaces)
 
-- *print-pretty* to control it
+* *print-pretty* to control it
 
 - if indent gets too large, dedent back to left edge
--- a/llt/ptrhash.h
+++ b/llt/ptrhash.h
@@ -7,7 +7,7 @@
 } ptrhash_t;
 
 // define this to be an invalid key/value
-#define PH_NOTFOUND ((void*)2)
+#define PH_NOTFOUND ((void*)1)
 
 // initialize and free
 ptrhash_t *ptrhash_new(ptrhash_t *h, size_t size);