From 46f2f47b1405c0f644e6d3dd5b8cdf458c458814 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Tue, 5 Aug 2008 01:43:12 +0000 Subject: [PATCH] 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* --- femtolisp/Makefile | 1 + femtolisp/builtins.c | 3 +- femtolisp/cvalues.c | 28 ++++++---- femtolisp/equal.c | 70 ++++++++++++------------ femtolisp/flisp.c | 125 ++++++++++++++++++++++--------------------- femtolisp/flisp.h | 43 +++++++++------ femtolisp/print.c | 76 +++++++++++++++----------- femtolisp/todo | 7 +-- llt/ptrhash.h | 2 +- 9 files changed, 195 insertions(+), 160 deletions(-) diff --git a/femtolisp/Makefile b/femtolisp/Makefile index 5fc3dfd..2b9db26 100644 --- a/femtolisp/Makefile +++ b/femtolisp/Makefile @@ -32,6 +32,7 @@ $(LLT): debug: $(DOBJS) $(LIBS) $(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS) + make test release: $(OBJS) $(LIBS) $(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 7ffc3a8..c4e8f7f 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -451,8 +451,7 @@ value_t fl_string_char(value_t *args, u_int32_t nargs) 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) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index b4d7492..5d07dd7 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -90,7 +90,7 @@ value_t cvalue(value_t type, size_t sz) 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 @@ value_t cvalue(value_t type, size_t sz) } 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 @@ value_t cvalue_from_ref(value_t type, void *ptr, size_t sz, value_t parent) if (parent != NIL) { // TODO: add dependency } - cv = tagptr(pcv, TAG_BUILTIN); + cv = tagptr(pcv, TAG_CVALUE); return cv; } @@ -319,6 +319,14 @@ size_t toulong(value_t n, char *fname) 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 @@ value_t cvalue_relocate(value_t v) 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 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs) 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 @@ value_t cvalue_copy(value_t v) 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 @@ value_t guestfunc(guestfunc_t f) // 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); } diff --git a/femtolisp/equal.c b/femtolisp/equal.c index d7cffae..4fe6cad 100644 --- 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 @@ static value_t bounded_compare(value_t a, value_t b, int bound) 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 @@ static value_t bounded_compare(value_t a, value_t b, int bound) } 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,17 +113,24 @@ static value_t bounded_compare(value_t a, value_t b, int bound) } 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); 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 @@ static value_t cyc_vector_compare(value_t a, value_t b, ptrhash_t *table) 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 @@ static value_t cyc_compare(value_t a, value_t b, ptrhash_t *table) 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 @@ value_t compare(value_t a, value_t b) 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 */ diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index f01c6f7..c48c95f 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -74,11 +74,12 @@ static char *stack_bottom; 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 @@ static symbol_t *mk_symbol(char *str) { 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 @@ static value_t *alloc_words(int n) { 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 @@ static value_t *alloc_words(int n) 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 @@ static value_t relocate(value_t v) 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 { - return cvalue_relocate(v); + 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)); } + 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 @@ void gc(int mustgrow) // 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 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) } 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 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) 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,26 +881,24 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) 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) { @@ -963,7 +961,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) 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 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) 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 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) 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 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) 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 @@ void lisp_init(void) 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 @@ void lisp_init(void) 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 @@ void lisp_init(void) 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); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 42538c1..458bf73 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -28,33 +28,42 @@ typedef struct _symbol_t { } 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,11 +238,13 @@ int isstring(value_t v); 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); 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 diff --git a/femtolisp/print.c b/femtolisp/print.c index 64d79ca..e6ba988 100644 --- 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 @@ static void print_traverse(value_t v) } 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)) { + 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); - 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); - } } } @@ -119,7 +119,7 @@ static void print_symbol_name(FILE *f, char *name) */ 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 @@ static int smallp(value_t v) 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 @@ static int allsmallp(value_t v) 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 @@ static void print_pair(FILE *f, value_t v, int princ) 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 @@ static void print_pair(FILE *f, value_t v, int princ) 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,16 +253,18 @@ static void print_pair(FILE *f, value_t v, int princ) ((!nextsmall && HPOS>28) || (VPOS > lastv))) || ((VPOS > lastv) && (!nextsmall || n==0)) || - + (HPOS > 50 && !nextsmall) || (HPOS > 74) || (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 @@ static void do_print(FILE *f, value_t v, int princ) 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 @@ static void do_print(FILE *f, value_t v, int princ) 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 cvalue_print(FILE *f, value_t v, int princ) void print(FILE *f, value_t v, int princ) { + print_pretty = (symbol_value(printprettysym) != NIL); ptrhash_reset(&printconses, 32); printlabel = 0; print_traverse(v); diff --git a/femtolisp/todo b/femtolisp/todo index a1b2af3..94f5514 100644 --- 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 @@ for internal use: . 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 @@ switch to miser mode, otherwise default is ok, for example: * 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 diff --git a/llt/ptrhash.h b/llt/ptrhash.h index 0b6423f..4c1a8e3 100644 --- a/llt/ptrhash.h +++ b/llt/ptrhash.h @@ -7,7 +7,7 @@ typedef struct _ptrhash_t { } 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);