From debf3fd5179629f8da5764b65ed3b870bab4cce5 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Thu, 9 Apr 2009 04:04:27 +0000 Subject: [PATCH] moving (length) out of core changing another recursive call to goto adding special cases in compiler for 0 and 1 argument versions of some vararg builtins beginning implementation of bytecode interpreter --- femtolisp/builtins.c | 30 +++ femtolisp/compiler.lsp | 58 +++-- femtolisp/cvalues.c | 31 +-- femtolisp/flisp.c | 565 +++++++++++++++++++++++++++++++++++++---- femtolisp/flisp.h | 5 +- 5 files changed, 607 insertions(+), 82 deletions(-) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index e0d7fdb..3731215 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -78,6 +78,35 @@ static value_t fl_memq(value_t *args, u_int32_t nargs) return FL_F; } +static value_t fl_length(value_t *args, u_int32_t nargs) +{ + argcount("length", nargs, 1); + value_t a = args[0]; + cvalue_t *cv; + if (isvector(a)) { + return fixnum(vector_size(a)); + } + else if (iscprim(a)) { + cv = (cvalue_t*)ptr(a); + if (cp_class(cv) == bytetype) + return fixnum(1); + else if (cp_class(cv) == wchartype) + return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv))); + } + else if (iscvalue(a)) { + cv = (cvalue_t*)ptr(a); + if (cv_class(cv)->eltype != NULL) + return size_wrap(cvalue_arraylen(a)); + } + else if (a == NIL) { + return fixnum(0); + } + else if (iscons(a)) { + return fixnum(llength(a)); + } + type_error("length", "sequence", a); +} + static value_t fl_raise(value_t *args, u_int32_t nargs) { argcount("raise", nargs, 1); @@ -387,6 +416,7 @@ static builtinspec_t builtin_info[] = { { "nconc", fl_nconc }, { "assq", fl_assq }, { "memq", fl_memq }, + { "length", fl_length }, { "vector.alloc", fl_vector_alloc }, diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 998c300..aaac367 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -18,13 +18,13 @@ :+ :- :* :/ :< :compare - :vector :aref :aset! :length :for + :vector :aref :aset! :for :loadt :loadf :loadnil :load0 :load1 :loadv :loadv.l :loadg :loada :loadc :loadg.l :setg :seta :setc :setg.l - :closure :trycatch :tcall :tapply])) + :closure :trycatch :tcall :tapply :argc :vargc])) (define arg-counts (table :eq? 2 :eqv? 2 @@ -40,7 +40,7 @@ :eval* 1 :apply 2 :< 2 :for 3 :compare 2 :aref 2 - :aset! 3 :length 1)) + :aset! 3)) (define 1/Instructions (table.invert Instructions)) @@ -121,7 +121,7 @@ (set! i (+ i 1))) ((:loada :seta :call :tcall :loadv :loadg :setg - :list :+ :- :* :/ :vector) + :list :+ :- :* :/ :vector :argc :vargc) (io.write bcode (uint8 nxt)) (set! i (+ i 1))) @@ -154,7 +154,7 @@ cvec))) (define (bytecode g) - (cons (encode-byte-code (aref g 0)) + (cons (cvalue.pin (encode-byte-code (aref g 0))) (const-to-idx-vec g))) (define (bytecode:code b) (car b)) @@ -185,7 +185,7 @@ #f))))) (define (compile-sym g env s Is) - (let ((loc (lookup-sym s env 0 #t))) + (let ((loc (lookup-sym s env -1 #t))) (case (car loc) (arg (emit g (aref Is 0) (cadr loc))) (closed (emit g (aref Is 1) (cadr loc) (caddr loc))) @@ -303,6 +303,14 @@ (begin (just-compile-args g lst env) (length lst))))) +(define (emit-nothing g) g) + +(define (argc-error head count) + (error (string "compile error: " head " expects " count + (if (= count 1) + " argument." + " arguments.")))) + (define (compile-app g env tail? x) (let ((head (car x))) (let ((head @@ -322,13 +330,24 @@ (let ((count (get arg-counts b #f))) (if (and count (not (length= (cdr x) count))) - (error (string "compile error: " head " expects " count - (if (= count 1) - " argument." - " arguments.")))) - (if (memq b '(:list :+ :- :* :/ :vector)) - (emit g b nargs) - (emit g (if (and tail? (eq? b :apply)) :tapply b)))) + (argc-error head count)) + (case b ; handle special cases of vararg builtins + (:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs))) + (:+ (if (= nargs 0) (emit g :load0) + (if (= nargs 1) (emit-nothing g) + (emit g b nargs)))) + (:- (if (= nargs 0) + (argc-error head 1) + (emit g b nargs))) + (:* (if (= nargs 0) (emit g :load1) + (if (= nargs 1) (emit-nothing g) + (emit g b nargs)))) + (:/ (if (= nargs 0) + (argc-error head 1) + (emit g b nargs))) + (:vector (emit g b nargs)) + (else + (emit g (if (and tail? (eq? b :apply)) :tapply b))))) (emit g (if tail? :tcall :call) nargs))))))) (define (compile-in g env tail? x) @@ -360,10 +379,14 @@ (else (compile-app g env tail? x)))))) (define (compile-f env f) - (let ((g (make-code-emitter))) - (compile-in g (cons (to-proper (cadr f)) env) #t (caddr f)) + (let ((g (make-code-emitter)) + (args (cadr f))) + (if (null? (lastcdr args)) + (emit g :argc (length args)) + (emit g :vargc (length args))) + (compile-in g (cons (to-proper args) env) #t (caddr f)) (emit g :ret) - `(compiled-lambda ,(cadr f) ,(bytecode g)))) + `(compiled-lambda ,args ,(bytecode g)))) (define (compile x) (bytecode (compile-in (make-code-emitter) () #t x))) @@ -410,7 +433,8 @@ (print-val (aref vals (aref code i))) (set! i (+ i 1))) - ((:loada :seta :call :tcall :list :+ :- :* :/ :vector) + ((:loada :seta :call :tcall :list :+ :- :* :/ :vector + :argc :vargc) (princ (number->string (aref code i))) (set! i (+ i 1))) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 9f866e3..c72b552 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -223,26 +223,17 @@ int isstring(value_t v) } // convert to malloc representation (fixed address) -/* -static void cv_pin(cvalue_t *cv) +void cv_pin(cvalue_t *cv) { - if (!cv->flags.inlined) + if (!isinlined(cv)) return; - size_t sz = cv->flags.inllen; + size_t sz = cv_len(cv); + if (cv_isstr(cv)) sz++; void *data = malloc(sz); - cv->flags.inlined = 0; - // TODO: handle flags.cstring - if (cv->flags.prim) { - memcpy(data, (void*)(&((cprim_t*)cv)->data), sz); - ((cprim_t*)cv)->data = data; - } - else { - memcpy(data, (void*)(&cv->data), sz); - cv->data = data; - } + memcpy(data, cv_data(cv), sz); + cv->data = data; autorelease(cv); } -*/ #define num_init(ctype, cnvt, tag) \ static int cvalue_##ctype##_init(fltype_t *type, value_t arg, \ @@ -703,6 +694,15 @@ value_t fl_copy(value_t *args, u_int32_t nargs) return cvalue_copy(args[0]); } +value_t fl_cv_pin(value_t *args, u_int32_t nargs) +{ + argcount("cvalue.pin", nargs, 1); + if (!iscvalue(args[0])) + lerror(ArgError, "cvalue.pin: must be a byte array"); + cv_pin((cvalue_t*)ptr(args[0])); + return args[0]; +} + static void cvalue_init(fltype_t *type, value_t v, void *dest) { cvinitfunc_t f=type->init; @@ -907,6 +907,7 @@ static builtinspec_t cvalues_builtin_info[] = { { "sizeof", cvalue_sizeof }, { "builtin", fl_builtin }, { "copy", fl_copy }, + { "cvalue.pin", fl_cv_pin }, { "logand", fl_logand }, { "logior", fl_logior }, diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index dab6c5d..a28a1e9 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -50,6 +50,7 @@ #include #include "llt.h" #include "flisp.h" +#include "opcodes.h" static char *builtin_names[] = { // special forms @@ -70,7 +71,7 @@ static char *builtin_names[] = "+", "-", "*", "/", "<", "compare", // sequences - "vector", "aref", "aset!", "length", "for", + "vector", "aref", "aset!", "for", "", "", "" }; #define N_STACK 262144 @@ -88,7 +89,7 @@ stackseg_t stackseg0 = { StaticStack, 0, NULL }; stackseg_t *current_stack_seg = &stackseg0; value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH; -value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; +value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, COMPILEDLAMBDA; value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t DivideError, BoundsError, Error, KeyError, EnumerationError; value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; @@ -96,6 +97,7 @@ value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym; value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym; static value_t eval_sexpr(value_t e, value_t *penv, int tail); +static value_t apply_cl(uint32_t nargs); static value_t *alloc_words(int n); static value_t relocate(value_t v); @@ -770,7 +772,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) uint32_t saveSP, bp, envsz, nargs; int i, noeval=0; fixnum_t s, lo, hi; - cvalue_t *cv; int64_t accum; /* @@ -1085,38 +1086,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) } } break; - case F_LENGTH: - argcount("length", nargs, 1); - if (isvector(Stack[SP-1])) { - v = fixnum(vector_size(Stack[SP-1])); - break; - } - else if (iscprim(Stack[SP-1])) { - cv = (cvalue_t*)ptr(Stack[SP-1]); - if (cp_class(cv) == bytetype) { - v = fixnum(1); - break; - } - else if (cp_class(cv) == wchartype) { - v = fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv))); - break; - } - } - else if (iscvalue(Stack[SP-1])) { - cv = (cvalue_t*)ptr(Stack[SP-1]); - if (cv_class(cv)->eltype != NULL) { - v = size_wrap(cvalue_arraylen(Stack[SP-1])); - break; - } - } - else if (Stack[SP-1] == NIL) { - v = fixnum(0); break; - } - else if (iscons(Stack[SP-1])) { - v = fixnum(llength(Stack[SP-1])); break; - } - type_error("length", "sequence", Stack[SP-1]); - break; case F_AREF: argcount("aref", nargs, 2); v = Stack[SP-2]; @@ -1152,7 +1121,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_ATOM: argcount("atom?", nargs, 1); - v = ((!iscons(Stack[SP-1])) ? FL_T : FL_F); + v = (iscons(Stack[SP-1]) ? FL_F : FL_T); break; case F_CONSP: argcount("pair?", nargs, 1); @@ -1325,24 +1294,23 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_EVAL: argcount("eval", nargs, 1); - v = Stack[SP-1]; - if (selfevaluating(v)) { SP=saveSP; return v; } + e = Stack[SP-1]; + if (selfevaluating(e)) { SP=saveSP; return e; } if (tail) { assert((ulong_t)(penv-Stack) 0) { list(&v, i, &NIL); if (nargs > MAX_ARGS) { c = (cons_t*)curheap; (c-2)->cdr = (c-1)->car; } - Stack[SP-i] = v; - SP -= (i-1); - } - else { - PUSH(NIL); } + Stack[SP-i] = v; + SP -= (i-1); } f = cdr_(Stack[bp+1]); if (!iscons(f)) goto notpair; @@ -1477,6 +1448,503 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) return NIL; } +/* + stack on entry: + caller's responsibility: + - put the stack in this state + - provide arg count + - respect tail position + - call correct entry point (either eval_sexpr or apply_cl) + + callee's responsibility: + - check arg counts + - allocate vararg array + - push closed env, set up new environment + + ** need 'copyenv' instruction that moves env to heap, installs + heap version as the current env, and pushes the result vector. + this can be used to implement the copy-closure op in terms of + other ops. and it can be the first instruction in lambdas in + head position (let optimization). +*/ +static value_t apply_cl(uint32_t nargs) +{ + uint32_t i, n, ip, bp; + fixnum_t s; + int64_t accum; + uint8_t op, *code; + value_t func, v, bcode, x, e, ftl; + value_t *penv, *pvals; + symbol_t *sym; + cons_t *c; + + apply_cl_top: + func = Stack[SP-nargs-1]; + ftl = cdr_(cdr_(func)); + bcode = car_(ftl); + code = cv_data((cvalue_t*)ptr(car_(bcode))); + i = code[1]; + if (nargs < i) + lerror(ArgError, "apply: too few arguments"); + if (code[0] == OP_VARGC) { + s = (fixnum_t)nargs - (fixnum_t)i; + v = NIL; + if (s > 0) { + list(&v, s, &NIL); + if (nargs > MAX_ARGS) { + c = (cons_t*)curheap; + (c-2)->cdr = (c-1)->car; + } + // reload movable pointers + func = Stack[SP-nargs-1]; + ftl = cdr_(cdr_(func)); + bcode = car_(ftl); + code = cv_data((cvalue_t*)ptr(car_(bcode))); + } + Stack[SP-s] = v; + SP -= (s-1); + nargs = i+1; + } + else if (nargs > i) { + lerror(ArgError, "apply: too many arguments"); + } + + bp = SP-nargs; + x = cdr_(ftl); // cloenv + Stack[bp-1] = car_(cdr_(func)); // lambda list + penv = &Stack[bp-1]; + PUSH(x); + PUSH(cdr_(bcode)); + pvals = &Stack[SP-1]; + + ip = 2; + while (1) { + op = code[ip++]; + switch (op) { + case OP_NOP: break; + case OP_DUP: v = Stack[SP-1]; PUSH(v); break; + case OP_POP: (void)POP(); break; + case OP_TCALL: + case OP_CALL: + i = code[ip++]; // nargs + do_call: + s = SP; + func = Stack[SP-i-1]; + if (isbuiltinish(func)) { + if (uintval(func) > N_BUILTINS) { + v = ((builtin_t)ptr(func))(&Stack[SP-i], i); + } + } + else { + if (iscons(func) && car_(func) == COMPILEDLAMBDA) { + if (op == OP_TCALL) { + for(s=-1; s < (fixnum_t)i; s++) + Stack[bp+s] = Stack[SP-i+s]; + SP = bp+i; + nargs = i; + goto apply_cl_top; + } + else { + v = apply_cl(i); + } + } + } + SP = s-i-1; + PUSH(v); + break; + case OP_JMP: ip = (uint32_t)*(uint16_t*)&code[ip]; break; + case OP_BRF: + v = POP(); + if (v == FL_F) ip = (uint32_t)*(uint16_t*)&code[ip]; + else ip += 2; + break; + case OP_BRT: + v = POP(); + if (v != FL_F) ip = (uint32_t)*(uint16_t*)&code[ip]; + else ip += 2; + break; + case OP_JMPL: ip = *(uint32_t*)&code[ip]; break; + case OP_BRFL: + v = POP(); + if (v == FL_F) ip = *(uint32_t*)&code[ip]; + else ip += 4; + break; + case OP_BRTL: + v = POP(); + if (v != FL_F) ip = *(uint32_t*)&code[ip]; + else ip += 4; + break; + case OP_RET: v = POP(); return v; + + case OP_EQ: + Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F); + POP(); break; + case OP_EQV: + if (Stack[SP-2] == Stack[SP-1]) { + v = FL_T; + } + else if (!leafp(Stack[SP-2]) || !leafp(Stack[SP-1])) { + v = FL_F; + } + else { + v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? + FL_T : FL_F; + } + Stack[SP-2] = v; POP(); + break; + case OP_EQUAL: + if (Stack[SP-2] == Stack[SP-1]) { + v = FL_T; + } + else if (eq_comparable(Stack[SP-2],Stack[SP-1])) { + v = FL_F; + } + else { + v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? + FL_T : FL_F; + } + Stack[SP-2] = v; POP(); + break; + case OP_PAIRP: + Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); break; + case OP_ATOMP: + Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_F : FL_T); break; + case OP_NOT: + Stack[SP-1] = ((Stack[SP-1]==FL_F) ? FL_T : FL_F); break; + case OP_NULLP: + Stack[SP-1] = ((Stack[SP-1]==NIL) ? FL_T : FL_F); break; + case OP_BOOLEANP: + v = Stack[SP-1]; + Stack[SP-1] = ((v == FL_T || v == FL_F) ? FL_T : FL_F); break; + case OP_SYMBOLP: + Stack[SP-1] = (issymbol(Stack[SP-1]) ? FL_T : FL_F); break; + case OP_NUMBERP: + v = Stack[SP-1]; + Stack[SP-1] = (isfixnum(v) || iscprim(v) ? FL_T : FL_F); break; + case OP_FIXNUMP: + Stack[SP-1] = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); break; + case OP_BOUNDP: + sym = tosymbol(Stack[SP-1], "bound?"); + Stack[SP-1] = ((sym->binding == UNBOUND) ? FL_F : FL_T); + break; + case OP_BUILTINP: + v = Stack[SP-1]; + Stack[SP-1] = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL) + ? FL_T : FL_F); + break; + case OP_VECTORP: + Stack[SP-1] = (isvector(Stack[SP-1]) ? FL_T : FL_F); break; + + case OP_CONS: + if (curheap > lim) + gc(0); + c = (cons_t*)curheap; + curheap += sizeof(cons_t); + c->car = Stack[SP-2]; + c->cdr = Stack[SP-1]; + Stack[SP-2] = tagptr(c, TAG_CONS); + POP(); break; + case OP_CAR: + c = tocons(Stack[SP-1], "car"); + Stack[SP-1] = c->car; + break; + case OP_CDR: + c = tocons(Stack[SP-1], "cdr"); + Stack[SP-1] = c->cdr; + break; + case OP_SETCAR: + car(Stack[SP-2]) = Stack[SP-1]; + POP(); break; + case OP_SETCDR: + cdr(Stack[SP-2]) = Stack[SP-1]; + POP(); break; + case OP_LIST: + i = code[ip++]; + list(&v, i, &NIL); + POPN(i); + PUSH(v); + break; + case OP_EVAL: + v = toplevel_eval(POP()); + PUSH(v); + break; + case OP_EVALSTAR: + + case OP_TAPPLY: + case OP_APPLY: + v = POP(); // arglist + i = SP; + while (iscons(v)) { + if (SP-i == MAX_ARGS) { + PUSH(v); + break; + } + PUSH(car_(v)); + v = cdr_(v); + } + i = SP-i; + if (op==OP_TAPPLY) op = OP_TCALL; + goto do_call; + + case OP_ADD: + s = 0; + n = code[ip++]; + i = SP-n; + if (n > MAX_ARGS) goto add_ovf; + for (; i < (int)SP; i++) { + if (__likely(isfixnum(Stack[i]))) { + s += numval(Stack[i]); + if (__unlikely(!fits_fixnum(s))) { + i++; + goto add_ovf; + } + } + else { + add_ovf: + v = fl_add_any(&Stack[i], SP-i, s); + break; + } + } + if (i==SP) + v = fixnum(s); + POPN(n); + PUSH(v); + break; + case OP_SUB: + n = code[ip++]; + if (__unlikely(n < 1)) lerror(ArgError, "-: too few arguments"); + i = SP-n; + if (n == 1) { + if (__likely(isfixnum(Stack[i]))) + Stack[SP-1] = fixnum(-numval(Stack[i])); + else + Stack[SP-1] = fl_neg(Stack[i]); + break; + } + if (n == 2) { + if (__likely(bothfixnums(Stack[i], Stack[i+1]))) { + s = numval(Stack[i]) - numval(Stack[i+1]); + if (__likely(fits_fixnum(s))) { + POP(); + Stack[SP-1] = fixnum(s); + break; + } + Stack[i+1] = fixnum(-numval(Stack[i+1])); + } + else { + Stack[i+1] = fl_neg(Stack[i+1]); + } + } + else { + // 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], n, 0)); + Stack[i] = POP(); + } + v = fl_add_any(&Stack[i], 2, 0); + POPN(n); + PUSH(v); + break; + case OP_MUL: + accum = 1; + n = code[ip++]; + i = SP-n; + if (n > 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); + break; + } + } + if (i == SP) { + if (__likely(fits_fixnum(accum))) + v = fixnum(accum); + else + v = return_from_int64(accum); + } + POPN(n); + PUSH(v); + break; + case OP_DIV: + n = code[ip++]; + if (__unlikely(n < 1)) lerror(ArgError, "/: too few arguments"); + i = SP-n; + if (n == 1) { + Stack[SP-1] = fl_div2(fixnum(1), Stack[i]); + } + else { + if (n > 2) { + PUSH(Stack[i]); + Stack[i] = fixnum(1); + Stack[i+1] = fl_mul_any(&Stack[i], n, 1); + Stack[i] = POP(); + } + v = fl_div2(Stack[i], Stack[i+1]); + POPN(n); + PUSH(v); + } + break; + case OP_LT: + if (bothfixnums(Stack[SP-2], Stack[SP-1])) { + v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? FL_T : FL_F; + } + else { + v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? + FL_T : FL_F; + } + POP(); + Stack[SP-1] = v; + break; + case OP_COMPARE: + Stack[SP-2] = compare(Stack[SP-2], Stack[SP-1]); + POP(); + break; + + case OP_VECTOR: + n = code[ip++]; + if (n > MAX_ARGS) { + i = llength(Stack[SP-1]); + n--; + } + else i = 0; + v = alloc_vector(n+i, 0); + memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t)); + if (i > 0) { + e = POP(); + POPN(n); + while (iscons(e)) { + vector_elt(v,n) = car_(e); + n++; + e = cdr_(e); + } + } + PUSH(v); + break; + + case OP_AREF: + v = Stack[SP-2]; + if (isvector(v)) { + i = tofixnum(Stack[SP-1], "aref"); + if (__unlikely((unsigned)i >= vector_size(v))) + bounds_error("aref", v, Stack[SP-1]); + v = vector_elt(v, i); + } + else if (isarray(v)) { + v = cvalue_array_aref(&Stack[SP-2]); + } + else { + type_error("aref", "sequence", v); + } + POP(); + Stack[SP-1] = v; + break; + case OP_ASET: + e = Stack[SP-3]; + if (isvector(e)) { + i = tofixnum(Stack[SP-2], "aset!"); + if (__unlikely((unsigned)i >= vector_size(e))) + bounds_error("aset!", v, Stack[SP-1]); + vector_elt(e, i) = (v=Stack[SP-1]); + } + else if (isarray(e)) { + v = cvalue_array_aset(&Stack[SP-3]); + } + else { + type_error("aset!", "sequence", e); + } + POPN(2); + Stack[SP-1] = v; + break; + case OP_FOR: + + case OP_LOADT: PUSH(FL_T); break; + case OP_LOADF: PUSH(FL_F); break; + case OP_LOADNIL: PUSH(NIL); break; + case OP_LOAD0: PUSH(fixnum(0)); break; + case OP_LOAD1: PUSH(fixnum(1)); break; + case OP_LOADV: + v = vector_elt(*pvals, code[ip]); ip++; + PUSH(v); + break; + case OP_LOADVL: + v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4; + PUSH(v); + break; + case OP_LOADGL: + v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4; + goto do_loadg; + case OP_LOADG: + v = vector_elt(*pvals, code[ip]); ip++; + do_loadg: + sym = (symbol_t*)ptr(v); + if (sym->binding == UNBOUND) + raise(list2(UnboundError, v)); + PUSH(sym->binding); + break; + + case OP_SETGL: + v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4; + goto do_setg; + case OP_SETG: + v = vector_elt(*pvals, code[ip]); ip++; + do_setg: + sym = (symbol_t*)ptr(v); + v = Stack[SP-1]; + if (sym->syntax != TAG_CONST) + sym->binding = v; + break; + + case OP_LOADA: + i = code[ip++]; + if (penv[0] == NIL) + v = vector_elt(penv[1], i+1); + else + v = Stack[bp+i]; + PUSH(v); + break; + case OP_SETA: + v = Stack[SP-1]; + i = code[ip++]; + if (penv[0] == NIL) + vector_elt(penv[1], i+1) = v; + else + Stack[bp+i] = v; + break; + case OP_LOADC: + case OP_SETC: + s = code[ip++]; + i = code[ip++]; + if (penv[0]==NIL) { + if (nargs > 0) { + // current frame has been captured + s++; + } + v = penv[1]; + } + else { + v = penv[numval(penv[-1])-1]; + } + while (s--) + v = vector_elt(v, vector_size(v)-1); + if (op == OP_SETC) + vector_elt(v, i) = Stack[SP-1]; + else + PUSH(vector_elt(v, i)); + break; + + case OP_CLOSURE: + case OP_TRYCATCH: + break; + } + } +} + // initialization ------------------------------------------------------------- extern void builtins_init(); @@ -1510,6 +1978,7 @@ static void lisp_init(void) FL_T = builtin(F_TRUE); FL_F = builtin(F_FALSE); LAMBDA = symbol("lambda"); + COMPILEDLAMBDA = symbol("compiled-lambda"); QUOTE = symbol("quote"); TRYCATCH = symbol("trycatch"); BACKQUOTE = symbol("backquote"); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index b67d375..8c71290 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -127,9 +127,9 @@ enum { F_EVAL, F_EVALSTAR, F_APPLY, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_COMPARE, - F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_FOR, + F_VECTOR, F_AREF, F_ASET, F_FOR, F_TRUE, F_FALSE, F_NIL, - N_BUILTINS, + N_BUILTINS }; #define isspecial(v) (uintval(v) <= (unsigned int)F_BEGIN) @@ -274,6 +274,7 @@ extern fltype_t *builtintype; value_t cvalue(fltype_t *type, size_t sz); void add_finalizer(cvalue_t *cv); void cv_autorelease(cvalue_t *cv); +void cv_pin(cvalue_t *cv); size_t ctype_sizeof(value_t type, int *palign); value_t cvalue_copy(value_t v); value_t cvalue_from_data(fltype_t *type, void *data, size_t sz);