conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

moving lognot out of core 

fixing type check in ash
This commit is contained in:
JeffBezanson 2009-04-02 03:53:38 +00:00
parent 8e78e4cdbb
commit e119a66bcd
4 changed files with 46 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
femtolisp/compiler.lsp
View File

@ -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)))

62
femtolisp/cvalues.c
View File

@ -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)<<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);

9
femtolisp/flisp.c
View File

@ -67,7 +67,7 @@ static char *builtin_names[] =
"eval", "eval*", "apply",
// arithmetic
"+", "-", "*", "/", "<", "lognot", "compare",
"+", "-", "*", "/", "<", "compare",
// sequences
"vector", "aref", "aset!", "length", "for",
@ -1273,13 +1273,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail)
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);
v = compare(Stack[SP-2], Stack[SP-1]);

2
femtolisp/flisp.h
View File

@ -125,7 +125,7 @@ enum {
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,