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
This commit is contained in:
JeffBezanson
parent
ea5d334626
commit
debf3fd517
|
|
@ -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 },
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 },
|
||||
|
|
|
|||
|
|
@ -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 @@ 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)<N_STACK);
|
||||
penv[-1] = fixnum(2);
|
||||
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 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
|
|||
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,18 +1395,16 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
|
|||
lerror(ArgError, "apply: too many arguments");
|
||||
}
|
||||
else {
|
||||
v = NIL;
|
||||
if (i > 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: <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 @@ 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");
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
Loading…
Reference in New Issue