ref: 4cb9685266101394b296053de8957ce9407cfe77
parent: fe72c101e29f4f99f42547d3c8b5673e851bb5ef
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Thu Mar 26 23:06:55 EDT 2009
adding support for arbitrarily-long argument lists argument lists are heap-allocated after a certain cutoff (currently 127)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -382,16 +382,6 @@
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 @@
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 @@
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 @@
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 @@
continue;
}
add_type_error:
- type_error("+", "number", args[i]);+ type_error("+", "number", arg);}
if (Faccum != 0) {Faccum += Uaccum;
@@ -1146,14 +1143,15 @@
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 @@
continue;
}
mul_type_error:
- type_error("*", "number", args[i]);+ type_error("*", "number", arg);}
if (Faccum != 1) {Faccum *= Uaccum;
@@ -1408,14 +1406,11 @@
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 @@
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 @@
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;
}
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -73,7 +73,7 @@
"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 @@
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 @@
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 @@
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 @@
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 @@
// 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 @@
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 @@
// 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 @@
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 @@
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 @@
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 @@
}
}
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 @@
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 @@
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 @@
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]);
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -99,6 +99,21 @@
#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)i<nargs || \
+ (i>MAX_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,
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -169,7 +169,7 @@
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;
--- 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))
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -107,11 +107,12 @@
{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();
--- 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)
--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -83,11 +83,14 @@
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 @@
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;
}
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -153,6 +153,12 @@
* 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
--- 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))
@@ -69,6 +71,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)))))