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);