ref: debf3fd5179629f8da5764b65ed3b870bab4cce5
parent: ea5d33462692109547e5f10c10c350aa2ac982c4
author: JeffBezanson <[email protected]>
date: Thu Apr 9 00:04:27 EDT 2009
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
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -78,6 +78,35 @@
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 @@
{ "nconc", fl_nconc }, { "assq", fl_assq }, { "memq", fl_memq },+ { "length", fl_length }, { "vector.alloc", fl_vector_alloc },--- 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)))
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -223,26 +223,17 @@
}
// 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 @@
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 @@
{ "sizeof", cvalue_sizeof }, { "builtin", fl_builtin }, { "copy", fl_copy },+ { "cvalue.pin", fl_cv_pin }, { "logand", fl_logand }, { "logior", fl_logior },--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -50,6 +50,7 @@
#include <math.h>
#include "llt.h"
#include "flisp.h"
+#include "opcodes.h"
static char *builtin_names[] =
{ // special forms@@ -70,7 +71,7 @@
"+", "-", "*", "/", "<", "compare",
// sequences
- "vector", "aref", "aset!", "length", "for",
+ "vector", "aref", "aset!", "for",
"", "", "" };
#define N_STACK 262144
@@ -88,7 +89,7 @@
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 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 @@
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 @@
}
}
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 @@
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,8 +1294,8 @@
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)<N_STACK);
penv[-1] = fixnum(2);
@@ -1333,16 +1302,15 @@
penv[0] = NIL;
penv[1] = NIL;
SP = (penv-Stack) + 2;
- e=v;
- goto eval_top;
}
else {PUSH(fixnum(2));
PUSH(NIL);
PUSH(NIL);
- v = eval_sexpr(v, &Stack[SP-2], 1);
+ tail = 1;
+ penv = &Stack[SP-2];
}
- break;
+ goto eval_top;
case F_EVALSTAR:
argcount("eval*", nargs, 1);e = Stack[SP-1];
@@ -1404,9 +1372,14 @@
SP = saveSP;
return v;
}
+ f = Stack[bp+1];
if (__likely(iscons(f))) {+ if (car_(f) == COMPILEDLAMBDA) {+ v = apply_cl(nargs);
+ SP = saveSP;
+ return v;
+ }
// apply lambda expression
- f = Stack[bp+1];
f = Stack[bp+1] = cdr_(f);
if (!iscons(f)) goto notpair;
v = car_(f); // arglist
@@ -1422,6 +1395,7 @@
lerror(ArgError, "apply: too many arguments");
}
else {+ v = NIL;
if (i > 0) {list(&v, i, &NIL);
if (nargs > MAX_ARGS) {@@ -1428,12 +1402,9 @@
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 @@
return NIL;
}
+/*
+ stack on entry: <func> <args...>
+ 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 @@
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");--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -127,9 +127,9 @@
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 @@
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);