ref: e119a66bcda2bc6a2903748d1eb994c8110e19ad
parent: 8e78e4cdbb3f3ab52e65ea77344061b05e2848ea
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Apr 1 23:53:38 EDT 2009
moving lognot out of core fixing type check in ash
--- 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)))
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -898,6 +898,7 @@
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 @@
{ "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 @@
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 @@
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 @@
else {if (ta == T_UINT64)
return return_from_uint64((*(uint64_t*)aptr)<<n);
- int64_t i64 = conv_to_int64(aptr, ta);
- return return_from_int64(i64<<n);
+ else if (ta < T_FLOAT) {+ int64_t i64 = conv_to_int64(aptr, ta);
+ return return_from_int64(i64<<n);
+ }
}
}
type_error("ash", "integer", a);--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -67,7 +67,7 @@
"eval", "eval*", "apply",
// arithmetic
- "+", "-", "*", "/", "<", "lognot", "compare",
+ "+", "-", "*", "/", "<", "compare",
// sequences
"vector", "aref", "aset!", "length", "for",
@@ -1272,13 +1272,6 @@
}
v = fl_div2(Stack[i], Stack[i+1]);
}
- break;
- case F_BNOT:
- argcount("lognot", nargs, 1);- if (isfixnum(Stack[SP-1]))
- v = fixnum(~numval(Stack[SP-1]));
- else
- v = fl_bitwise_not(Stack[SP-1]);
break;
case F_COMPARE:
argcount("compare", nargs, 2);--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -125,7 +125,7 @@
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
F_EVAL, F_EVALSTAR, F_APPLY,
- F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_COMPARE,
+ F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_COMPARE,
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_FOR,
F_TRUE, F_FALSE, F_NIL,
--
⑨