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)
$(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
make test
release: $(OBJS) $(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]);
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)

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

70
femtolisp/equal.c
View File

@ -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
*/

125
femtolisp/flisp.c
View File

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

43
femtolisp/flisp.h
View File

@ -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

76
femtolisp/print.c
View File

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

7
femtolisp/todo
View File

@ -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

2
llt/ptrhash.h
View File

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