diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 13426b4..998c300 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -8,7 +8,7 @@ (define Instructions (make-enum-table - [:nop :dup :pop :popn :call :jmp :brf :brt :jmp.l :brf.l :brt.l :ret + [:nop :dup :pop :call :jmp :brf :brt :jmp.l :brf.l :brt.l :ret :eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol? :number? :bound? :pair? :builtin? :vector? :fixnum? @@ -16,13 +16,13 @@ :cons :list :car :cdr :set-car! :set-cdr! :eval :eval* :apply - :+ :- :* :/ :< :lognot :compare + :+ :- :* :/ :< :compare :vector :aref :aset! :length :for :loadt :loadf :loadnil :load0 :load1 :loadv :loadv.l - :loadg :loada :loadc - :setg :seta :setc :loadg.l :setg.l + :loadg :loada :loadc :loadg.l + :setg :seta :setc :setg.l :closure :trycatch :tcall :tapply])) @@ -38,10 +38,9 @@ :cdr 1 :set-car! 2 :set-cdr! 2 :eval 1 :eval* 1 :apply 2 - :< 2 :lognot 1 + :< 2 :for 3 :compare 2 :aref 2 - :aset! 3 :length 1 - :for 3)) + :aset! 3 :length 1)) (define 1/Instructions (table.invert Instructions)) @@ -121,7 +120,7 @@ (io.write bcode (uint32 nxt)) (set! i (+ i 1))) - ((:loada :seta :call :tcall :loadv :loadg :setg :popn + ((:loada :seta :call :tcall :loadv :loadg :setg :list :+ :- :* :/ :vector) (io.write bcode (uint8 nxt)) (set! i (+ i 1))) @@ -168,7 +167,7 @@ (define (in-env? s env) (and (pair? env) - (or (index-of s (car env) 0) + (or (memq s (car env)) (in-env? s (cdr env))))) (define (lookup-sym s env lev arg?) @@ -411,8 +410,7 @@ (print-val (aref vals (aref code i))) (set! i (+ i 1))) - ((:loada :seta :call :tcall :popn :list :+ :- :* :/ - :vector) + ((:loada :seta :call :tcall :list :+ :- :* :/ :vector) (princ (number->string (aref code i))) (set! i (+ i 1))) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 1f53ae7..9f866e3 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -898,6 +898,7 @@ value_t cbuiltin(char *name, builtin_t f) static value_t fl_logand(value_t *args, u_int32_t nargs); static value_t fl_logior(value_t *args, u_int32_t nargs); static value_t fl_logxor(value_t *args, u_int32_t nargs); +static value_t fl_lognot(value_t *args, u_int32_t nargs); static value_t fl_ash(value_t *args, u_int32_t nargs); static builtinspec_t cvalues_builtin_info[] = { @@ -906,9 +907,11 @@ static builtinspec_t cvalues_builtin_info[] = { { "sizeof", cvalue_sizeof }, { "builtin", fl_builtin }, { "copy", fl_copy }, + { "logand", fl_logand }, { "logior", fl_logior }, { "logxor", fl_logxor }, + { "lognot", fl_lognot }, { "ash", fl_ash }, // todo: autorelease { NULL, NULL } @@ -1303,31 +1306,6 @@ static void *int_data_ptr(value_t a, int *pnumtype, char *fname) return NULL; } -static value_t fl_bitwise_not(value_t a) -{ - cprim_t *cp; - int ta; - void *aptr; - - if (iscprim(a)) { - cp = (cprim_t*)ptr(a); - ta = cp_numtype(cp); - aptr = cp_data(cp); - switch (ta) { - case T_INT8: return fixnum(~*(int8_t *)aptr); - case T_UINT8: return fixnum(~*(uint8_t *)aptr); - case T_INT16: return fixnum(~*(int16_t *)aptr); - case T_UINT16: return fixnum(~*(uint16_t*)aptr); - case T_INT32: return mk_int32(~*(int32_t *)aptr); - case T_UINT32: return mk_uint32(~*(uint32_t*)aptr); - case T_INT64: return mk_int64(~*(int64_t *)aptr); - case T_UINT64: return mk_uint64(~*(uint64_t*)aptr); - } - } - type_error("~", "integer", a); - return NIL; -} - static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname) { int_t ai, bi; @@ -1447,6 +1425,34 @@ static value_t fl_logxor(value_t *args, u_int32_t nargs) return v; } +static value_t fl_lognot(value_t *args, u_int32_t nargs) +{ + argcount("lognot", nargs, 1); + value_t a = args[0]; + if (isfixnum(a)) + return fixnum(~numval(a)); + cprim_t *cp; + int ta; + void *aptr; + + if (iscprim(a)) { + cp = (cprim_t*)ptr(a); + ta = cp_numtype(cp); + aptr = cp_data(cp); + switch (ta) { + case T_INT8: return fixnum(~*(int8_t *)aptr); + case T_UINT8: return fixnum(~*(uint8_t *)aptr); + case T_INT16: return fixnum(~*(int16_t *)aptr); + case T_UINT16: return fixnum(~*(uint16_t*)aptr); + case T_INT32: return mk_int32(~*(int32_t *)aptr); + case T_UINT32: return mk_uint32(~*(uint32_t*)aptr); + case T_INT64: return mk_int64(~*(int64_t *)aptr); + case T_UINT64: return mk_uint64(~*(uint64_t*)aptr); + } + } + type_error("lognot", "integer", a); +} + static value_t fl_ash(value_t *args, u_int32_t nargs) { fixnum_t n; @@ -1487,8 +1493,10 @@ static value_t fl_ash(value_t *args, u_int32_t nargs) else { if (ta == T_UINT64) return return_from_uint64((*(uint64_t*)aptr)<