diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index ac1c7fc..cd9ac66 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -129,6 +129,24 @@ static value_t fl_intern(value_t *args, u_int32_t nargs) 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 @@ static value_t fl_constantp(value_t *args, u_int32_t nargs) 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 @@ static value_t fl_integerp(value_t *args, u_int32_t nargs) 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 @@ static builtinspec_t builtin_info[] = { { "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 }, diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index a95c0e8..092fb47 100644 --- 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)))) diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index 72ec341..51e2060 100644 --- 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 diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index bebf345..dae0b3c 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -171,6 +171,7 @@ void raise(value_t e) __attribute__ ((__noreturn__)); 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)) diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 4974c6e..e8b8be4 100644 --- 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))))