moving lognot out of core

fixing type check in ash

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
+    :loadg :loada :loadc :loadg.l
-    :setg  :seta  :setc  :loadg.l :setg.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
+	 :aset!    3      :length   1))
-	 :for      3))
 
 (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 :+ :- :* :/
+		     ((:loada :seta :call :tcall :list :+ :- :* :/ :vector)
-			      :vector)
 		      (princ (number->string (aref code i)))
 		      (set! i (+ i 1)))
 

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,10 +1493,12 @@ 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);
+            else if (ta < T_FLOAT) {
                 int64_t i64 = conv_to_int64(aptr, ta);
                 return return_from_int64(i64<<n);
             }
         }
+    }
     type_error("ash", "integer", a);
     return NIL;
 }

femtolisp/flisp.c

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

femtolisp/flisp.h

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