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

adding support for arbitrarily-long argument lists 

argument lists are heap-allocated after a certain cutoff (currently 127)
This commit is contained in:
JeffBezanson 2009-03-27 03:06:55 +00:00
parent fe72c101e2
commit 4cb9685266
10 changed files with 168 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
femtolisp/cvalues.c
View File

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

101
femtolisp/flisp.c
View File

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

15
femtolisp/flisp.h
View File

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

2
femtolisp/iostream.c
View File

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

2
femtolisp/rule30.lsp
View File

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

5
femtolisp/string.c
View File

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

10
femtolisp/system.lsp
View File

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

18
femtolisp/table.c
View File

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

6
femtolisp/todo
View File

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

5
femtolisp/unittest.lsp
View File

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