shithub: femtolisp

Info  •  Files  •  Log

adding top-level-value and set-top-level-value!, using them instead of
set and eval where appropriate
adding separate integer? and integer-valued? predicates

--- a/femtolisp/builtins.c

+++ b/femtolisp/builtins.c

@@ -129,6 +129,24 @@

     return symbol(cvalue_data(args[0]));

 }

+static value_t fl_top_level_value(value_t *args, u_int32_t nargs)

+{

+    argcount("top-level-value", nargs, 1);

+    symbol_t *sym = tosymbol(args[0], "top-level-value");

+    if (sym->binding == UNBOUND)

+        raise(list2(UnboundError, args[0]));

+    return sym->binding;

+}

+

+static value_t fl_set_top_level_value(value_t *args, u_int32_t nargs)

+{

+    argcount("set-top-level-value!", nargs, 2);

+    symbol_t *sym = tosymbol(args[0], "set-top-level-value!");

+    if (sym->syntax != TAG_CONST)

+        sym->binding = args[1];

+    return args[1];

+}

+

 extern value_t LAMBDA, COMPILEDLAMBDA;

 static value_t fl_setsyntax(value_t *args, u_int32_t nargs)

@@ -202,9 +220,9 @@

     return FL_T;

 }

-static value_t fl_integerp(value_t *args, u_int32_t nargs)

+static value_t fl_integer_valuedp(value_t *args, u_int32_t nargs)

 {

-    argcount("integer?", nargs, 1);

+    argcount("integer-valued?", nargs, 1);

     value_t v = args[0];

     if (isfixnum(v)) {

         return FL_T;

@@ -231,6 +249,14 @@

     return FL_F;

 }

+static value_t fl_integerp(value_t *args, u_int32_t nargs)

+{

+    argcount("integer?", nargs, 1);

+    value_t v = args[0];

+    return (isfixnum(v) ||

+            (iscprim(v) && cp_numtype((cprim_t*)ptr(v)) < T_FLOAT));

+}

+

 static value_t fl_fixnum(value_t *args, u_int32_t nargs)

 {

     argcount("fixnum", nargs, 1);

@@ -407,13 +433,16 @@

     { "symbol-syntax", fl_symbolsyntax },

     { "environment", fl_global_env },

     { "constant?", fl_constantp },

+    { "top-level-value", fl_top_level_value },

+    { "set-top-level-value!", fl_set_top_level_value },

     { "raise", fl_raise },

-

     { "exit", fl_exit },

     { "intern", fl_intern },

+

     { "fixnum", fl_fixnum },

     { "truncate", fl_truncate },

     { "integer?", fl_integerp },

+    { "integer-valued?", fl_integer_valuedp },

     { "nconc", fl_nconc },

     { "assq", fl_assq },

     { "memq", fl_memq },

--- a/femtolisp/compiler.lsp

+++ b/femtolisp/compiler.lsp

@@ -352,8 +352,8 @@

 		    (not (in-env? head env))

 		    (bound? head)

 		    (constant? head)

-		    (builtin? (eval head)))

-	       (eval head)

+		    (builtin? (top-level-value head)))

+	       (top-level-value head)

 	       head)))

       (let ((b (and (builtin? head)

 		    (builtin->instruction head))))

--- a/femtolisp/cps.lsp

+++ b/femtolisp/cps.lsp

@@ -76,7 +76,7 @@

         (#t           (rest->cps prim->cps form k argsyms))))

 (define *top-k* (gensym))

-(set *top-k* identity)

+(set-top-level-value! *top-k* identity)

 (define (cps form)

   (η-reduce

--- a/femtolisp/flisp.h

+++ b/femtolisp/flisp.h

@@ -171,6 +171,7 @@

 void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__));

 void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));

 extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;

+extern value_t UnboundError;

 static inline void argcount(char *fname, uint32_t nargs, uint32_t c)

 {

     if (__unlikely(nargs != c))

--- a/femtolisp/system.lsp

+++ b/femtolisp/system.lsp

@@ -21,8 +21,6 @@

       (list 'set! form (car body))

       (list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))

-(define (set s v) (eval (list 'set! s (list 'quote v))))

-

 (define (map f lst)

   (if (atom? lst) lst

       (cons (f (car lst)) (map f (cdr lst)))))

@@ -298,7 +296,8 @@

   (or (and (atom? x)

            (not (symbol? x)))

       (and (constant? x)

-           (eq x (eval x)))))

+	   (symbol? x)

+           (eq x (top-level-value x)))))

 (define-macro (backquote x) (bq-process x))

@@ -451,11 +450,11 @@

 (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))

 (define (trace sym)

-  (let* ((lam  (eval sym))

+  (let* ((lam  (top-level-value sym))

 	 (args (cadr lam))

 	 (al   (to-proper args)))

     (if (not (eq? (car lam) 'trace-lambda))

-	(set sym

+	(set-top-level-value! sym

 	     `(trace-lambda ,args

 	        (begin

 		  (princ "(")

@@ -469,9 +468,9 @@

   'ok)

 (define (untrace sym)

-  (let ((lam  (eval sym)))

+  (let ((lam  (top-level-value sym)))

     (if (eq? (car lam) 'trace-lambda)

-	(set sym

+	(set-top-level-value! sym

 	     (cadr (caar (last-pair (caddr lam))))))))

 (define-macro (time expr)

@@ -679,7 +678,7 @@

 		       (lambda (e) (begin (io.discardbuffer *input-stream*)

 					  (raise e))))))

       (and (not (io.eof? *input-stream*))

-	   (let ((V (eval (expand v))))

+	   (let ((V (load-process v)))

 	     (print V)

 	     (set! that V)

 	     #t))))