conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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*
This commit is contained in:
JeffBezanson 2008-08-05 01:43:12 +00:00
parent c3811312a7
commit 46f2f47b14
9 changed files with 195 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
femtolisp/Makefile
View File

@ -32,6 +32,7 @@ $(LLT):
debug: $(DOBJS) $(LIBS) debug: $(DOBJS) $(LIBS)
$(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS) $(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
make test
release: $(OBJS) $(LIBS) release: $(OBJS) $(LIBS)
$(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS) $(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS)

3
femtolisp/builtins.c
View File

@ -451,8 +451,7 @@ value_t fl_string_char(value_t *args, u_int32_t nargs)
size_t sl = u8_seqlen(&s[i]); size_t sl = u8_seqlen(&s[i]);
if (sl > len || i > len-sl) if (sl > len || i > len-sl)
bounds_error("string.char", args[0], args[1]); bounds_error("string.char", args[0], args[1]);
value_t ccode = fixnum(u8_nextchar(s, &i)); return char_from_code(u8_nextchar(s, &i));
return cvalue_char(&ccode, 1);
} }
value_t fl_time_now(value_t *args, u_int32_t nargs) value_t fl_time_now(value_t *args, u_int32_t nargs)

28
femtolisp/cvalues.c
View File

@ -90,7 +90,7 @@ value_t cvalue(value_t type, size_t sz)
pcp->flags.inlined = 1; pcp->flags.inlined = 1;
pcp->flags.prim = 1; pcp->flags.prim = 1;
pcp->type = type; pcp->type = type;
return tagptr(pcp, TAG_BUILTIN); return tagptr(pcp, TAG_CVALUE);
} }
PUSH(type); PUSH(type);
if (sz <= MAX_INL_SIZE) { if (sz <= MAX_INL_SIZE) {
@ -110,7 +110,7 @@ value_t cvalue(value_t type, size_t sz)
} }
pcv->deps = NIL; pcv->deps = NIL;
pcv->type = POP(); 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) 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) { if (parent != NIL) {
// TODO: add dependency // TODO: add dependency
} }
cv = tagptr(pcv, TAG_BUILTIN); cv = tagptr(pcv, TAG_CVALUE);
return cv; return cv;
} }
@ -319,6 +319,14 @@ size_t toulong(value_t n, char *fname)
return 0; 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, static void cvalue_enum_init(value_t *args, u_int32_t nargs, void *dest,
void *data) void *data)
{ {
@ -507,7 +515,7 @@ value_t cvalue_relocate(value_t v)
if (!cv->flags.islispfunction) { if (!cv->flags.islispfunction) {
nv = (cvalue_t*)alloc_words(nw); nv = (cvalue_t*)alloc_words(nw);
memcpy(nv, cv, nw*sizeof(value_t)); memcpy(nv, cv, nw*sizeof(value_t));
ncv = tagptr(nv, TAG_BUILTIN); ncv = tagptr(nv, TAG_CVALUE);
cv->type = ncv; cv->type = ncv;
cv->flags.moved = 1; cv->flags.moved = 1;
} }
@ -637,13 +645,11 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs)
argcount("typeof", nargs, 1); argcount("typeof", nargs, 1);
switch(tag(args[0])) { switch(tag(args[0])) {
case TAG_CONS: return conssym; case TAG_CONS: return conssym;
case TAG_NUM1:
case TAG_NUM: return fixnumsym; case TAG_NUM: return fixnumsym;
case TAG_SYM: return symbolsym; case TAG_SYM: return symbolsym;
case TAG_BUILTIN: case TAG_VECTOR: return vectorsym;
if (isbuiltin(args[0])) case TAG_BUILTIN: return builtinsym;
return builtinsym;
if (discriminateAsVector(args[0]))
return vectorsym;
} }
return cv_type((cvalue_t*)ptr(args[0])); return cv_type((cvalue_t*)ptr(args[0]));
} }
@ -669,7 +675,7 @@ value_t cvalue_copy(value_t v)
autorelease((cvalue_t*)pnv); 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) 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 // directly-callable values are assumed not to move for
// evaluator performance, so put guestfunction metadata on the // evaluator performance, so put guestfunction metadata on the
// unmanaged heap // 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)); memcpy(buf, ptr(gf), nw*sizeof(value_t));
return tagptr(buf, TAG_BUILTIN); return tagptr(buf, TAG_BUILTIN);
} }

70
femtolisp/equal.c
View File

@ -7,11 +7,8 @@
#include "llt.h" #include "llt.h"
#include "flisp.h" #include "flisp.h"
// is it a leaf? (i.e. does not lead to other values) // comparable tag
static inline int leafp(value_t a) #define cmptag(v) (isfixnum(v) ? TAG_NUM : tag(v))
{
return (!iscons(a) && !isvector(a));
}
static value_t eq_class(ptrhash_t *table, value_t key) 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 (a == b) return fixnum(0);
if (bound <= 0) if (bound <= 0)
return NIL; return NIL;
switch (tag(a)) { int taga = tag(a);
case TAG_NUM: int tagb = cmptag(b);
switch (taga) {
case TAG_NUM :
case TAG_NUM1:
if (isfixnum(b)) { if (isfixnum(b)) {
return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1); 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); return fixnum(-1);
case TAG_SYM: case TAG_SYM:
if (tag(b) < TAG_SYM) return fixnum(1); if (tagb < TAG_SYM) return fixnum(1);
if (tag(b) > TAG_SYM) return fixnum(-1); if (tagb > TAG_SYM) return fixnum(-1);
return fixnum(strcmp(symbol_name(a), symbol_name(b))); return fixnum(strcmp(symbol_name(a), symbol_name(b)));
case TAG_BUILTIN: case TAG_VECTOR:
if (tag(b) > TAG_BUILTIN) return fixnum(-1); if (isvector(b))
if (tag(b) == TAG_BUILTIN) { return bounded_vector_compare(a, b, bound);
if (uintval(a) < N_BUILTINS || uintval(b) < N_BUILTINS) { break;
return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1); case TAG_CVALUE:
} if (iscvalue(b)) {
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));
cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b); cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b);
numerictype_t at, bt; numerictype_t at, bt;
if (valid_numtype(at=cv_numtype(acv)) && 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); return cvalue_compare(a, b);
} }
assert(isfixnum(b)); else if (isfixnum(b)) {
return fixnum(-compare_num_cvalue(b, a)); 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: 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); d = bounded_compare(car_(a), car_(b), bound-1);
if (numval(d) != 0) return d; if (numval(d) != 0) return d;
a = cdr_(a); b = cdr_(b); a = cdr_(a); b = cdr_(b);
bound--; bound--;
goto compare_top; 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) 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); d = bounded_compare(xa, xb, 1);
if (numval(d)!=0) return d; if (numval(d)!=0) return d;
} }
else if (tag(xa) < tag(xb)) { else if (cmptag(xa) < cmptag(xb)) {
return fixnum(-1); return fixnum(-1);
} }
else if (tag(xa) > tag(xb)) { else if (cmptag(xa) > cmptag(xb)) {
return fixnum(1); return fixnum(1);
} }
} }
@ -189,22 +187,24 @@ static value_t cyc_compare(value_t a, value_t b, ptrhash_t *table)
if (iscons(b)) { if (iscons(b)) {
value_t aa = car_(a); value_t da = cdr_(a); value_t aa = car_(a); value_t da = cdr_(a);
value_t ab = car_(b); value_t db = cdr_(b); 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; value_t d, ca, cb;
if (leafp(aa) || leafp(ab)) { if (leafp(aa) || leafp(ab)) {
d = bounded_compare(aa, ab, 1); d = bounded_compare(aa, ab, 1);
if (numval(d)!=0) return d; if (numval(d)!=0) return d;
} }
else if (tag(aa) < tag(ab)) else if (tagaa < tagab)
return fixnum(-1); return fixnum(-1);
else if (tag(aa) > tag(ab)) else if (tagaa > tagab)
return fixnum(1); return fixnum(1);
if (leafp(da) || leafp(db)) { if (leafp(da) || leafp(db)) {
d = bounded_compare(da, db, 1); d = bounded_compare(da, db, 1);
if (numval(d)!=0) return d; if (numval(d)!=0) return d;
} }
else if (tag(da) < tag(db)) else if (tagda < tagdb)
return fixnum(-1); return fixnum(-1);
else if (tag(da) > tag(db)) else if (tagda > tagdb)
return fixnum(1); return fixnum(1);
ca = eq_class(table, a); ca = eq_class(table, a);
@ -246,5 +246,5 @@ value_t compare(value_t a, value_t b)
bp once and use it twice. bp once and use it twice.
- preallocate hash table and call reset() instead of new/free - preallocate hash table and call reset() instead of new/free
- specialized version for equal (unordered comparison) - specialized version for equal (unordered comparison)
- less redundant tag checking, 3-bit tags * less redundant tag checking, 3-bit tags
*/ */

125
femtolisp/flisp.c
View File

@ -74,11 +74,12 @@ static char *stack_bottom;
value_t Stack[N_STACK]; value_t Stack[N_STACK];
u_int32_t SP = 0; 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 BACKQUOTE, COMMA, COMMAAT, COMMADOT;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error; value_t DivideError, BoundsError, Error;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; 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 eval_sexpr(value_t e, uint32_t penv, int tail);
static value_t *alloc_words(int n); static value_t *alloc_words(int n);
@ -193,7 +194,9 @@ static symbol_t *mk_symbol(char *str)
{ {
symbol_t *sym; 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->left = sym->right = NULL;
sym->binding = UNBOUND; sym->binding = UNBOUND;
sym->syntax = 0; sym->syntax = 0;
@ -297,8 +300,8 @@ static value_t *alloc_words(int n)
{ {
value_t *first; value_t *first;
// the minimum allocation is a 2-word block if (n < 2) n = 2; // the minimum allocation is a 2-word block
if (n < 2) n = 2; n = ALIGN(n, 2); // only allocate multiples of 2 words
if ((value_t*)curheap > ((value_t*)lim)+2-n) { if ((value_t*)curheap > ((value_t*)lim)+2-n) {
gc(0); gc(0);
while ((value_t*)curheap > ((value_t*)lim)+2-n) { 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 alloc_vector(size_t n, int init)
{ {
value_t *c = alloc_words(n+1); 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); vector_setsize(v, n);
if (init) { if (init) {
unsigned int i; unsigned int i;
@ -369,35 +372,32 @@ static value_t relocate(value_t v)
return first; return first;
} }
else if (isvectorish(v)) { else if (isvector(v)) {
if (discriminateAsVector(v)) { // 0-length vectors secretly have space for a first element
// 0-length vectors secretly have space for a first element if (vector_elt(v,0) == UNBOUND)
if (vector_elt(v,0) == UNBOUND) return vector_elt(v,-1);
return vector_elt(v,-1); size_t i, newsz, sz = vector_size(v);
size_t i, newsz, sz = vector_size(v); newsz = sz;
newsz = sz; if (vector_elt(v,-1) & 0x1)
if (vector_elt(v,-1) & 0x1) newsz += vector_grow_amt(sz);
newsz += vector_grow_amt(sz); nc = alloc_vector(newsz, 0);
nc = alloc_vector(newsz, 0); a = vector_elt(v,0);
a = vector_elt(v,0); vector_elt(v,0) = UNBOUND;
vector_elt(v,0) = UNBOUND; vector_elt(v,-1) = nc;
vector_elt(v,-1) = nc; i = 0;
i = 0; if (sz > 0) {
if (sz > 0) { vector_elt(nc,0) = relocate(a); i++;
vector_elt(nc,0) = relocate(a); i++; for(; i < sz; i++)
for(; i < sz; i++) vector_elt(nc,i) = relocate(vector_elt(v,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);
} }
for(; i < newsz; i++)
vector_elt(nc,i) = NIL;
return nc;
} }
else if (ismanaged(v)) { else if (iscvalue(v)) {
assert(issymbol(v)); return cvalue_relocate(v);
}
else if (ismanaged(v) && issymbol(v)) {
gensym_t *gs = (gensym_t*)ptr(v); gensym_t *gs = (gensym_t*)ptr(v);
if (gs->id == 0xffffffff) if (gs->id == 0xffffffff)
return gs->binding; return gs->binding;
@ -461,7 +461,7 @@ void gc(int mustgrow)
// more space to fill next time. if we grew tospace last time, // more space to fill next time. if we grew tospace last time,
// grow the other half of the heap this time to catch up. // grow the other half of the heap this time to catch up.
if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) { 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) if (temp == NULL)
lerror(MemoryError, "out of memory"); lerror(MemoryError, "out of memory");
tospace = temp; tospace = temp;
@ -681,7 +681,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
} }
else f = eval(v); else f = eval(v);
v = Stack[saveSP]; v = Stack[saveSP];
if (tag(f) == TAG_BUILTIN) { if (isbuiltinish(f)) {
// handle builtin function // handle builtin function
// evaluate argument list, placing arguments on stack // evaluate argument list, placing arguments on stack
while (iscons(v)) { while (iscons(v)) {
@ -706,8 +706,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
lenv = penv; lenv = penv;
envsz = numval(Stack[penv-1]); envsz = numval(Stack[penv-1]);
pv = alloc_words(envsz + 1); pv = alloc_words(envsz + 1);
PUSH(tagptr(pv, TAG_BUILTIN)); PUSH(tagptr(pv, TAG_VECTOR));
pv[0] = envsz<<2; pv[0] = fixnum(envsz);
pv++; pv++;
while (envsz--) while (envsz--)
*pv++ = Stack[penv++]; *pv++ = Stack[penv++];
@ -881,26 +881,24 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_LENGTH: case F_LENGTH:
argcount("length", nargs, 1); argcount("length", nargs, 1);
if (isvectorish(Stack[SP-1])) { if (isvector(Stack[SP-1])) {
if (discriminateAsVector(Stack[SP-1])) { v = fixnum(vector_size(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; break;
} }
else { else if (v == charsym) {
cv = (cvalue_t*)ptr(Stack[SP-1]); v = fixnum(1);
v = cv_type(cv); break;
if (iscons(v) && car_(v) == arraysym) { }
v = size_wrap(cvalue_arraylen(Stack[SP-1])); else if (v == wcharsym) {
break; 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) { else if (Stack[SP-1] == NIL) {
@ -963,7 +961,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_BUILTINP: case F_BUILTINP:
argcount("builtinp", nargs, 1); argcount("builtinp", nargs, 1);
v = (isbuiltin(Stack[SP-1]) || v = (isbuiltinish(Stack[SP-1]) ||
(iscvalue(Stack[SP-1]) && (iscvalue(Stack[SP-1]) &&
((cvalue_t*)ptr(Stack[SP-1]))->flags.islispfunction))? T:NIL; ((cvalue_t*)ptr(Stack[SP-1]))->flags.islispfunction))? T:NIL;
break; break;
@ -1094,7 +1092,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
break; break;
case F_EQUAL: case F_EQUAL:
argcount("equal", nargs, 2); 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; v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL;
} }
else { 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 v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
f = Stack[SP-2]; // first arg is new function f = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args POPN(2); // pop apply's args
if (tag(f) == TAG_BUILTIN) { if (isbuiltinish(f)) {
assert(!isspecial(f)); assert(!isspecial(f));
// unpack arglist onto the stack // unpack arglist onto the stack
while (iscons(v)) { while (iscons(v)) {
@ -1178,8 +1176,9 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
noeval = 1; noeval = 1;
goto apply_lambda; goto apply_lambda;
default: default:
// a guest function is a cvalue tagged as a builtin
cv = (cvalue_t*)ptr(f); cv = (cvalue_t*)ptr(f);
if (!discriminateAsVector(f) && cv->flags.islispfunction) { if (cv->flags.islispfunction) {
v = ((guestfunc_t)cv->data)(&Stack[saveSP+1], nargs); v = ((guestfunc_t)cv->data)(&Stack[saveSP+1], nargs);
} }
else { else {
@ -1306,8 +1305,8 @@ void lisp_init(void)
llt_init(); llt_init();
fromspace = malloc(heapsize); fromspace = malloc_aligned(heapsize, 16);
tospace = malloc(heapsize); tospace = malloc_aligned(heapsize, 16);
curheap = fromspace; curheap = fromspace;
lim = curheap+heapsize-sizeof(cons_t); lim = curheap+heapsize-sizeof(cons_t);
consflags = bitvector_new(heapsize/sizeof(cons_t), 1); consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
@ -1317,7 +1316,6 @@ void lisp_init(void)
T = symbol("T"); setc(T, T); T = symbol("T"); setc(T, T);
LAMBDA = symbol("lambda"); LAMBDA = symbol("lambda");
QUOTE = symbol("quote"); QUOTE = symbol("quote");
VECTOR = symbol("vector");
TRYCATCH = symbol("trycatch"); TRYCATCH = symbol("trycatch");
BACKQUOTE = symbol("backquote"); BACKQUOTE = symbol("backquote");
COMMA = symbol("*comma*"); COMMA = symbol("*comma*");
@ -1337,6 +1335,11 @@ void lisp_init(void)
fixnumsym = symbol("fixnum"); fixnumsym = symbol("fixnum");
vectorsym = symbol("vector"); vectorsym = symbol("vector");
builtinsym = symbol("builtin"); builtinsym = symbol("builtin");
defunsym = symbol("defun");
defmacrosym = symbol("defmacro");
forsym = symbol("for");
labelsym = symbol("label");
set(printprettysym=symbol("*print-pretty*"), T);
lasterror = NIL; lasterror = NIL;
lerrorbuf[0] = '\0'; lerrorbuf[0] = '\0';
special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL); special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL);

43
femtolisp/flisp.h
View File

@ -28,33 +28,42 @@ typedef struct _symbol_t {
} symbol_t; } symbol_t;
#define TAG_NUM 0x0 #define TAG_NUM 0x0
#define TAG_BUILTIN 0x1 //0x1 unused
#define TAG_SYM 0x2 #define TAG_BUILTIN 0x2
#define TAG_CONS 0x3 #define TAG_VECTOR 0x3
#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer #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_CONST ((value_t)-2) // in sym->syntax for constants
#define tag(x) ((x)&0x3) #define tag(x) ((x)&0x7)
#define ptr(x) ((void*)((x)&(~(value_t)0x3))) #define ptr(x) ((void*)((x)&(~(value_t)0x7)))
#define tagptr(p,t) (((value_t)(p)) | (t)) #define tagptr(p,t) (((value_t)(p)) | (t))
#define fixnum(x) ((value_t)((x)<<2)) #define fixnum(x) ((value_t)((x)<<2))
#define numval(x) (((fixnum_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) #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 fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
#define uintval(x) (((unsigned int)(x))>>2) #define uintval(x) (((unsigned int)(x))>>3)
#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN) #define builtin(n) tagptr((((int)n)<<3), TAG_BUILTIN)
#define iscons(x) (tag(x) == TAG_CONS) #define iscons(x) (tag(x) == TAG_CONS)
#define issymbol(x) (tag(x) == TAG_SYM) #define issymbol(x) (tag(x) == TAG_SYM)
#define isfixnum(x) (tag(x) == TAG_NUM) #define isfixnum(x) (((x)&3) == TAG_NUM)
#define bothfixnums(x,y) (tag((x)|(y)) == TAG_NUM) #define bothfixnums(x,y) ((((x)|(y))&3) == TAG_NUM)
#define isbuiltin(x) ((tag(x) == TAG_BUILTIN) && uintval(x) < N_BUILTINS) #define isbuiltin(x) ((tag(x) == TAG_BUILTIN) && uintval(x) < N_BUILTINS)
#define isvectorish(x) ((tag(x) == TAG_BUILTIN) && uintval(x) > N_BUILTINS) #define isbuiltinish(x) (tag(x) == TAG_BUILTIN)
#define isvector(x) (isvectorish(x) && !(((value_t*)ptr(x))[0] & 0x2)) #define isvector(x) (tag(x) == TAG_VECTOR)
#define iscvalue(x) (isvectorish(x) && (((value_t*)ptr(x))[0] & 0x2)) #define iscvalue(x) (tag(x) == TAG_CVALUE)
#define selfevaluating(x) (tag(x)<0x2) #define selfevaluating(x) (tag(x)<0x6)
// comparable with == // comparable with ==
#define eq_comparable(a,b) (!(((a)|(b))&0x1)) #define eq_comparable(a,b) (!(((a)|(b))&0x1))
// distinguish a vector from a cvalue // doesn't lead to other values
#define discriminateAsVector(x) (!(((value_t*)ptr(x))[0] & 0x2)) #define leafp(a) (((a)&3) != 3)
#define vector_size(v) (((size_t*)ptr(v))[0]>>2) #define vector_size(v) (((size_t*)ptr(v))[0]>>2)
#define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2)) #define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2))
#define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)]) #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); int isnumber(value_t v);
value_t cvalue_compare(value_t a, value_t b); value_t cvalue_compare(value_t a, value_t b);
value_t cvalue_char(value_t *args, uint32_t nargs); 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_double(double_t n);
value_t mk_uint32(uint32_t n); value_t mk_uint32(uint32_t n);
value_t mk_uint64(uint64_t n); value_t mk_uint64(uint64_t n);
value_t return_from_uint64(uint64_t Uaccum); value_t return_from_uint64(uint64_t Uaccum);
value_t return_from_int64(int64_t Saccum); value_t return_from_int64(int64_t Saccum);
value_t char_from_code(uint32_t code);
#endif #endif

76
femtolisp/print.c
View File

@ -1,5 +1,6 @@
static ptrhash_t printconses; static ptrhash_t printconses;
static u_int32_t printlabel; static u_int32_t printlabel;
static int print_pretty;
static int HPOS, VPOS; static int HPOS, VPOS;
static void outc(char c, FILE *f) static void outc(char c, FILE *f)
@ -43,25 +44,24 @@ static void print_traverse(value_t v)
} }
if (!ismanaged(v) || issymbol(v)) if (!ismanaged(v) || issymbol(v))
return; return;
if (isvectorish(v)) { if (ismarked(v)) {
if (ismarked(v)) { bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
bp = (value_t*)ptrhash_bp(&printconses, (void*)v); if (*bp == (value_t)PH_NOTFOUND)
if (*bp == (value_t)PH_NOTFOUND) *bp = fixnum(printlabel++);
*bp = fixnum(printlabel++); return;
return; }
} if (isvector(v)) {
if (discriminateAsVector(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); 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) 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) static int smallp(value_t v)
@ -142,10 +142,11 @@ static int smallp(value_t v)
return 0; 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 // 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 2;
return -1; return -1;
} }
@ -172,12 +173,19 @@ static int allsmallp(value_t v)
return n; 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) static int indentevery(value_t v)
{ {
// indent before every subform of a special form, unless every // indent before every subform of a special form, unless every
// subform is "small" // subform is "small"
value_t c = car_(v); value_t c = car_(v);
if (c == LAMBDA) if (c == LAMBDA || c == labelsym)
return 0; return 0;
value_t f; value_t f;
if (issymbol(c) && (f=((symbol_t*)ptr(c))->syntax) && isspecial(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; int lastv, n=0, si, ind=0, est, always=0, nextsmall;
if (!blk) always = indentevery(v); if (!blk) always = indentevery(v);
value_t head = car_(v); value_t head = car_(v);
int after3 = indentafter3(head, v);
while (1) { while (1) {
lastv = VPOS; lastv = VPOS;
unmark_cons(v); unmark_cons(v);
@ -232,7 +241,8 @@ static void print_pair(FILE *f, value_t v, int princ)
break; 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 // never break line before lambda-list or in princ
ind = 0; ind = 0;
} }
@ -243,16 +253,18 @@ static void print_pair(FILE *f, value_t v, int princ)
((!nextsmall && HPOS>28) || (VPOS > lastv))) || ((!nextsmall && HPOS>28) || (VPOS > lastv))) ||
((VPOS > lastv) && (!nextsmall || n==0)) || ((VPOS > lastv) && (!nextsmall || n==0)) ||
(HPOS > 50 && !nextsmall) || (HPOS > 50 && !nextsmall) ||
(HPOS > 74) || (HPOS > 74) ||
(est!=-1 && (HPOS+est > 78)) || (est!=-1 && (HPOS+est > 78)) ||
(head == LAMBDA && !nextsmall) || ((head == LAMBDA || head == labelsym) && !nextsmall) ||
(n > 0 && always)); (n > 0 && always) ||
(n == 2 && after3));
} }
if (ind) { if (ind) {
@ -282,7 +294,8 @@ static void do_print(FILE *f, value_t v, int princ)
char *name; char *name;
switch (tag(v)) { 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: case TAG_SYM:
name = symbol_name(v); name = symbol_name(v);
if (princ) if (princ)
@ -302,10 +315,10 @@ static void do_print(FILE *f, value_t v, int princ)
outs(builtin_names[uintval(v)], f); outs(builtin_names[uintval(v)], f);
break; break;
} }
if (!ismanaged(v)) { cvalue_print(f, v, princ);
assert(iscvalue(v)); break;
cvalue_print(f, v, princ); break; case TAG_CVALUE:
} case TAG_VECTOR:
case TAG_CONS: case TAG_CONS:
if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) != if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
(value_t)PH_NOTFOUND) { (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) void print(FILE *f, value_t v, int princ)
{ {
print_pretty = (symbol_value(printprettysym) != NIL);
ptrhash_reset(&printconses, 32); ptrhash_reset(&printconses, 32);
printlabel = 0; printlabel = 0;
print_traverse(v); print_traverse(v);

7
femtolisp/todo
View File

@ -28,7 +28,7 @@
checking ismanaged() checking ismanaged()
* eliminate compiler warnings * eliminate compiler warnings
* fix printing nan and inf * fix printing nan and inf
- move to "2.5-bit" type tags * move to "2.5-bit" type tags
? builtin abs() ? builtin abs()
- try adding optional arguments, (lambda (x (opt 0)) ...), see if performance - try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
is acceptable is acceptable
@ -123,6 +123,7 @@ for internal use:
. disadvantage is looking through the lambda list on every lookup. maybe . disadvantage is looking through the lambda list on every lookup. maybe
improve by making lambda lists vectors somehow? improve by making lambda lists vectors somehow?
* fast builtin bounded iteration construct (for lo hi (lambda (x) ...)) * fast builtin bounded iteration construct (for lo hi (lambda (x) ...))
- represent guest function as a tagged function pointer; allocate nothing
bugs: bugs:
* with the fully recursive (simpler) relocate(), the size of cons chains * 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 * write try_predict_len that gives a length for easy cases like
symbols, else -1. use it to avoid wrapping symbols around lines 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 - if indent gets too large, dedent back to left edge

2
llt/ptrhash.h
View File

@ -7,7 +7,7 @@ typedef struct _ptrhash_t {
} ptrhash_t; } ptrhash_t;
// define this to be an invalid key/value // define this to be an invalid key/value
#define PH_NOTFOUND ((void*)2) #define PH_NOTFOUND ((void*)1)
// initialize and free // initialize and free
ptrhash_t *ptrhash_new(ptrhash_t *h, size_t size); ptrhash_t *ptrhash_new(ptrhash_t *h, size_t size);