From 4cb9685266101394b296053de8957ce9407cfe77 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Fri, 27 Mar 2009 03:06:55 +0000 Subject: [PATCH] adding support for arbitrarily-long argument lists argument lists are heap-allocated after a certain cutoff (currently 127) --- femtolisp/cvalues.c | 77 ++++++++++++++----------------- femtolisp/flisp.c | 101 +++++++++++++++++++++++++++++++++++------ femtolisp/flisp.h | 15 ++++++ femtolisp/iostream.c | 2 +- femtolisp/rule30.lsp | 2 +- femtolisp/string.c | 5 +- femtolisp/system.lsp | 10 ++-- femtolisp/table.c | 18 ++++++-- femtolisp/todo | 6 +++ femtolisp/unittest.lsp | 5 ++ 10 files changed, 168 insertions(+), 73 deletions(-) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index a8f2cc3..1f53ae7 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -382,16 +382,6 @@ value_t cvalue_enum(value_t *args, u_int32_t nargs) return cv; } -static void array_init_fromargs(char *dest, value_t *vals, size_t cnt, - fltype_t *eltype, size_t elsize) -{ - size_t i; - for(i=0; i < cnt; i++) { - cvalue_init(eltype, vals[i], dest); - dest += elsize; - } -} - static int isarray(value_t v) { return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL; @@ -428,23 +418,23 @@ static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest) sz = elsize * cnt; if (isvector(arg)) { - array_init_fromargs((char*)dest, &vector_elt(arg,0), cnt, - eltype, elsize); + for(i=0; i < cnt; i++) { + cvalue_init(eltype, vector_elt(arg,i), dest); + dest += elsize; + } return 0; } else if (iscons(arg) || arg==NIL) { i = 0; while (iscons(arg)) { - if (SP >= N_STACK) - break; - PUSH(car_(arg)); + if (i == cnt) { i++; break; } // trigger error + cvalue_init(eltype, car_(arg), dest); i++; + dest += elsize; arg = cdr_(arg); } if (i != cnt) lerror(ArgError, "array: size mismatch"); - array_init_fromargs((char*)dest, &Stack[SP-i], i, eltype, elsize); - POPN(i); return 0; } else if (iscvalue(arg)) { @@ -473,19 +463,25 @@ static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest) value_t cvalue_array(value_t *args, u_int32_t nargs) { - size_t elsize, cnt, sz; + size_t elsize, cnt, sz, i; + value_t arg; if (nargs < 1) argcount("array", nargs, 1); cnt = nargs - 1; + if (nargs > MAX_ARGS) + cnt += llength(args[MAX_ARGS]); fltype_t *type = get_array_type(args[0]); elsize = type->elsz; sz = elsize * cnt; value_t cv = cvalue(type, sz); - array_init_fromargs(cv_data((cvalue_t*)ptr(cv)), &args[1], cnt, - type->eltype, elsize); + char *dest = cv_data((cvalue_t*)ptr(cv)); + FOR_ARGS(i,1,arg,args) { + cvalue_init(type->eltype, arg, dest); + dest += elsize; + } return cv; } @@ -1040,14 +1036,15 @@ static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn) int64_t Saccum = carryIn; double Faccum=0; uint32_t i; + value_t arg=NIL; - for(i=0; i < nargs; i++) { - if (isfixnum(args[i])) { - Saccum += numval(args[i]); + FOR_ARGS(i,0,arg,args) { + if (isfixnum(arg)) { + Saccum += numval(arg); continue; } - else if (iscprim(args[i])) { - cprim_t *cp = (cprim_t*)ptr(args[i]); + else if (iscprim(arg)) { + cprim_t *cp = (cprim_t*)ptr(arg); void *a = cp_data(cp); int64_t i64; switch(cp_numtype(cp)) { @@ -1073,7 +1070,7 @@ static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn) continue; } add_type_error: - type_error("+", "number", args[i]); + type_error("+", "number", arg); } if (Faccum != 0) { Faccum += Uaccum; @@ -1146,14 +1143,15 @@ static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum) uint64_t Uaccum=1; double Faccum=1; uint32_t i; + value_t arg=NIL; - for(i=0; i < nargs; i++) { - if (isfixnum(args[i])) { - Saccum *= numval(args[i]); + FOR_ARGS(i,0,arg,args) { + if (isfixnum(arg)) { + Saccum *= numval(arg); continue; } - else if (iscprim(args[i])) { - cprim_t *cp = (cprim_t*)ptr(args[i]); + else if (iscprim(arg)) { + cprim_t *cp = (cprim_t*)ptr(arg); void *a = cp_data(cp); int64_t i64; switch(cp_numtype(cp)) { @@ -1179,7 +1177,7 @@ static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum) continue; } mul_type_error: - type_error("*", "number", args[i]); + type_error("*", "number", arg); } if (Faccum != 1) { Faccum *= Uaccum; @@ -1408,14 +1406,11 @@ static value_t fl_logand(value_t *args, u_int32_t nargs) if (nargs == 0) return fixnum(-1); v = args[0]; - i = 1; - while (i < (int)nargs) { - e = args[i]; + FOR_ARGS(i,1,e,args) { if (bothfixnums(v, e)) v = v & e; else v = fl_bitwise_op(v, e, 0, "logand"); - i++; } return v; } @@ -1427,14 +1422,11 @@ static value_t fl_logior(value_t *args, u_int32_t nargs) if (nargs == 0) return fixnum(0); v = args[0]; - i = 1; - while (i < (int)nargs) { - e = args[i]; + FOR_ARGS(i,1,e,args) { if (bothfixnums(v, e)) v = v | e; else v = fl_bitwise_op(v, e, 1, "logior"); - i++; } return v; } @@ -1446,14 +1438,11 @@ static value_t fl_logxor(value_t *args, u_int32_t nargs) if (nargs == 0) return fixnum(0); v = args[0]; - i = 1; - while (i < (int)nargs) { - e = args[i]; + FOR_ARGS(i,1,e,args) { if (bothfixnums(v, e)) v = fixnum(numval(v) ^ numval(e)); else v = fl_bitwise_op(v, e, 2, "logxor"); - i++; } return v; } diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index a269f49..1f1883d 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -73,7 +73,7 @@ static char *builtin_names[] = "vector", "aref", "aset!", "length", "for", "", "", "" }; -#define N_STACK 98304 +#define N_STACK 131072 value_t Stack[N_STACK]; uint32_t SP = 0; @@ -636,7 +636,10 @@ static void list(value_t *pv, uint32_t nargs, value_t *plastcdr) c->cdr = tagptr(c+1, TAG_CONS); c++; } - (c-1)->cdr = *plastcdr; + if (nargs > MAX_ARGS) + (c-2)->cdr = (c-1)->car; + else + (c-1)->cdr = *plastcdr; POPN(nargs); } @@ -646,6 +649,32 @@ static void list(value_t *pv, uint32_t nargs, value_t *plastcdr) if (selfevaluating(xpr)) { return (xpr); } \ else { e=(xpr); goto eval_top; } } while (0) +/* eval a list of expressions, giving a list of the results */ +static value_t evlis(value_t *pv, uint32_t penv) +{ + PUSH(NIL); + PUSH(NIL); + value_t *rest = &Stack[SP-1]; + value_t a, v = *pv; + while (iscons(v)) { + a = car_(v); + v = eval(a); + PUSH(v); + v = mk_cons(); + car_(v) = Stack[SP-1]; + cdr_(v) = NIL; + (void)POP(); + if (*rest == NIL) + Stack[SP-2] = v; + else + cdr_(*rest) = v; + *rest = v; + v = *pv = cdr_(*pv); + } + (void)POP(); + return POP(); +} + static value_t do_trycatch(value_t expr, uint32_t penv) { value_t v; @@ -659,7 +688,8 @@ static value_t do_trycatch(value_t expr, uint32_t penv) v = FL_F; // 1-argument form } else { - Stack[SP-1] = eval(car_(v)); + v = car_(v); + Stack[SP-1] = eval(v); v = apply1(Stack[SP-1], lasterror); } } @@ -719,7 +749,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) raise(list2(UnboundError, e)); return v; } - if (__unlikely(SP >= (N_STACK-64))) + if (__unlikely(SP >= (N_STACK-MAX_ARGS))) lerror(MemoryError, "eval: stack overflow"); saveSP = SP; v = car_(e); @@ -740,7 +770,13 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) // handle builtin function // evaluate argument list, placing arguments on stack while (iscons(v)) { - v = eval(car_(v)); + if (SP-saveSP-1 == MAX_ARGS) { + v = evlis(&Stack[saveSP], penv); + PUSH(v); + break; + } + v = car_(v); + v = eval(v); PUSH(v); v = Stack[saveSP] = cdr_(Stack[saveSP]); } @@ -756,7 +792,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_SETQ: e = car(Stack[saveSP]); - v = eval(car(cdr_(Stack[saveSP]))); + v = car(cdr_(Stack[saveSP])); + v = eval(v); pv = &Stack[penv]; while (1) { f = *pv++; @@ -843,7 +880,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) // evaluate body forms if (iscons(*pv)) { while (iscons(cdr_(*pv))) { - v = eval(car_(*pv)); + v = car_(*pv); + v = eval(v); *pv = cdr_(*pv); } tail_eval(car_(*pv)); @@ -899,7 +937,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) pv = &Stack[saveSP]; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { - (void)eval(car_(*pv)); + v = car_(*pv); + (void)eval(v); *pv = cdr_(*pv); } tail_eval(car_(*pv)); @@ -971,8 +1010,21 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) cdr(v=Stack[SP-2]) = Stack[SP-1]; break; case F_VECTOR: - v = alloc_vector(nargs, 0); + if (nargs > MAX_ARGS) { + i = llength(Stack[SP-1]); + nargs--; + } + else i = 0; + v = alloc_vector(nargs+i, 0); memcpy(&vector_elt(v,0), &Stack[saveSP+1], nargs*sizeof(value_t)); + if (i > 0) { + e = Stack[SP-1]; + while (iscons(e)) { + vector_elt(v,nargs) = car_(e); + nargs++; + e = cdr_(e); + } + } break; case F_LENGTH: argcount("length", nargs, 1); @@ -1084,7 +1136,9 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_ADD: s = 0; - for (i=saveSP+1; i < (int)SP; i++) { + i = saveSP+1; + if (nargs > MAX_ARGS) goto add_ovf; + for (; i < (int)SP; i++) { if (__likely(isfixnum(Stack[i]))) { s += numval(Stack[i]); if (__unlikely(!fits_fixnum(s))) { @@ -1125,17 +1179,25 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) } } else { - Stack[i+1] = fl_neg(fl_add_any(&Stack[i+1], nargs-1, 0)); + // we need to pass the full arglist on to fl_add_any + // so it can handle rest args properly + PUSH(Stack[i]); + Stack[i] = fixnum(0); + Stack[i+1] = fl_neg(fl_add_any(&Stack[i], nargs, 0)); + Stack[i] = POP(); } v = fl_add_any(&Stack[i], 2, 0); break; case F_MUL: accum = 1; - for (i=saveSP+1; i < (int)SP; i++) { + i = saveSP+1; + if (nargs > MAX_ARGS) goto mul_ovf; + for (; i < (int)SP; i++) { if (__likely(isfixnum(Stack[i]))) { accum *= numval(Stack[i]); } else { + mul_ovf: v = fl_mul_any(&Stack[i], SP-i, accum); SP = saveSP; return v; @@ -1153,8 +1215,12 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) v = fl_div2(fixnum(1), Stack[i]); } else { - if (nargs > 2) - Stack[i+1] = fl_mul_any(&Stack[i+1], nargs-1, 1); + if (nargs > 2) { + PUSH(Stack[i]); + Stack[i] = fixnum(1); + Stack[i+1] = fl_mul_any(&Stack[i], nargs, 1); + Stack[i] = POP(); + } v = fl_div2(Stack[i], Stack[i+1]); } break; @@ -1268,6 +1334,10 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) assert(!isspecial(f)); // unpack arglist onto the stack while (iscons(v)) { + if (SP-saveSP-1 == MAX_ARGS) { + PUSH(v); + break; + } PUSH(car_(v)); v = cdr_(v); } @@ -1320,7 +1390,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) lerror(ArgError, "apply: too many arguments"); break; } - v = eval(car_(v)); + v = car_(v); + v = eval(v); PUSH(v); *argsyms = cdr_(*argsyms); v = Stack[saveSP] = cdr_(Stack[saveSP]); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index a2dfe64..14479e3 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -99,6 +99,21 @@ extern uint32_t SP; #define POP() (Stack[--SP]) #define POPN(n) (SP-=(n)) +// maximum number of explicit arguments. the 128th arg is a list of rest args. +// the largest value nargs can have is MAX_ARGS+1 +#define MAX_ARGS 127 + +// utility for iterating over all arguments in a builtin +// i=index, i0=start index, arg = var for each arg, args = arg array +// assumes "nargs" is the argument count +// modifies args[MAX_ARGS] when nargs==MAX_ARGS+1 +#define FOR_ARGS(i, i0, arg, args) \ + for(i=i0; (((size_t)iMAX_ARGS && iscons(args[MAX_ARGS]))) && \ + ((i>=MAX_ARGS?(arg=car_(args[MAX_ARGS]), \ + args[MAX_ARGS]=cdr_(args[MAX_ARGS])) : \ + (arg = args[i])) || 1)); i++) + enum { // special forms F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c index 6798d79..2063e5c 100644 --- a/femtolisp/iostream.c +++ b/femtolisp/iostream.c @@ -169,7 +169,7 @@ value_t fl_ioseek(value_t *args, u_int32_t nargs) static void do_ioprint(value_t *args, u_int32_t nargs, int princ, char *fname) { - if (nargs < 2) + if (nargs < 2 || nargs > MAX_ARGS) argcount(fname, nargs, 2); ios_t *s = toiostream(args[0], fname); unsigned i; diff --git a/femtolisp/rule30.lsp b/femtolisp/rule30.lsp index 19b8231..225f674 100644 --- a/femtolisp/rule30.lsp +++ b/femtolisp/rule30.lsp @@ -36,5 +36,5 @@ (for-each (lambda (n) (begin (princ (bin-draw (pad0 (number->string n 2) 63))) - (terpri))) + (newline))) (nestlist rule30-step (uint64 0x0000000080000000) 32)) diff --git a/femtolisp/string.c b/femtolisp/string.c index dec1807..8ec9e96 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -107,11 +107,12 @@ value_t fl_string(value_t *args, u_int32_t nargs) { if (nargs == 1 && isstring(args[0])) return args[0]; - value_t buf = fl_buffer(NULL, 0); + value_t arg, buf = fl_buffer(NULL, 0); ios_t *s = value2c(ios_t*,buf); uint32_t i; - for (i=0; i < nargs; i++) + FOR_ARGS(i,0,arg,args) { print(s, args[i], 1); + } PUSH(buf); value_t outp = stream_to_string(&Stack[SP-1]); (void)POP(); diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index ce27027..5152827 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -486,9 +486,9 @@ ,expr (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) -(define (terpri) (princ *linefeed*)) +(define (newline) (princ *linefeed*)) (define (display x) (princ x) #t) -(define (println . args) (prog1 (apply print args) (terpri))) +(define (println . args) (prog1 (apply print args) (newline))) (define (vu8 . elts) (apply array (cons 'uint8 elts))) @@ -591,12 +591,12 @@ (set! that V) #t)))) (define (reploop) - (when (trycatch (and (prompt) (terpri)) + (when (trycatch (and (prompt) (newline)) print-exception) - (begin (terpri) + (begin (newline) (reploop)))) (reploop) - (terpri)) + (newline)) (define (print-exception e) (cond ((and (pair? e) diff --git a/femtolisp/table.c b/femtolisp/table.c index 5394448..69e4f97 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -83,11 +83,14 @@ static htable_t *totable(value_t v, char *fname) value_t fl_table(value_t *args, uint32_t nargs) { - if (nargs & 1) + size_t cnt = (size_t)nargs; + if (nargs > MAX_ARGS) + cnt += llength(args[MAX_ARGS]); + if (cnt & 1) lerror(ArgError, "table: arguments must come in pairs"); value_t nt; // prevent small tables from being added to finalizer list - if (nargs <= HT_N_INLINE) { + if (cnt <= HT_N_INLINE) { tabletype->vtable->finalize = NULL; nt = cvalue(tabletype, sizeof(htable_t)); tabletype->vtable->finalize = free_htable; @@ -96,10 +99,15 @@ value_t fl_table(value_t *args, uint32_t nargs) nt = cvalue(tabletype, 2*sizeof(void*)); } htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(nt)); - htable_new(h, nargs/2); + htable_new(h, cnt/2); uint32_t i; - for(i=0; i < nargs; i+=2) - equalhash_put(h, (void*)args[i], (void*)args[i+1]); + value_t k=NIL, arg=NIL; + FOR_ARGS(i,0,arg,args) { + if (i&1) + equalhash_put(h, (void*)k, (void*)arg); + else + k = arg; + } return nt; } diff --git a/femtolisp/todo b/femtolisp/todo index 2310e9c..f9d5320 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -153,6 +153,12 @@ bugs: * prettyprint size measuring is not utf-8 correct - stack is too limited. possibly allocate user frames with alloca so the only limit is the process stack size. +* argument list length is too limited. + need to fix it for: +,-,*,/,&,|,$,list,vector,apply,string,array + . for builtins, make Nth argument list of rest args + . write a function to evaluate directly from list to list, use it for + Nth arg and for user function rest args + . modify vararg builtins accordingly femtoLisp3...with symbolic C interface diff --git a/femtolisp/unittest.lsp b/femtolisp/unittest.lsp index b6b98ad..25cd37d 100644 --- a/femtolisp/unittest.lsp +++ b/femtolisp/unittest.lsp @@ -51,6 +51,8 @@ (assert (= (/ 2) 0)) (assert (= (/ 2.0) 0.5)) +(assert (= (- 4999950000 4999941999) 8001)) + ; tricky cases involving INT_MIN (assert (< (- #uint32(0x80000000)) 0)) (assert (> (- #int32(0x80000000)) 0)) @@ -70,6 +72,9 @@ ; this crashed once (for 1 10 (lambda (i) 0)) +; long argument lists +(assert (= (apply + (iota 100000)) 4999950000)) + ; ok, a couple end-to-end tests as well (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (assert (equal (fib 20) 6765))