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
This commit is contained in:
JeffBezanson 2009-04-17 14:41:15 +00:00
parent 86b7738c89
commit 2ed581e62d
5 changed files with 43 additions and 14 deletions

View File

@ -129,6 +129,24 @@ static value_t fl_intern(value_t *args, u_int32_t nargs)
return symbol(cvalue_data(args[0])); 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; extern value_t LAMBDA, COMPILEDLAMBDA;
static value_t fl_setsyntax(value_t *args, u_int32_t nargs) 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; 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]; value_t v = args[0];
if (isfixnum(v)) { if (isfixnum(v)) {
return FL_T; return FL_T;
@ -231,6 +249,14 @@ static value_t fl_integerp(value_t *args, u_int32_t nargs)
return FL_F; 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) static value_t fl_fixnum(value_t *args, u_int32_t nargs)
{ {
argcount("fixnum", nargs, 1); argcount("fixnum", nargs, 1);
@ -407,13 +433,16 @@ static builtinspec_t builtin_info[] = {
{ "symbol-syntax", fl_symbolsyntax }, { "symbol-syntax", fl_symbolsyntax },
{ "environment", fl_global_env }, { "environment", fl_global_env },
{ "constant?", fl_constantp }, { "constant?", fl_constantp },
{ "top-level-value", fl_top_level_value },
{ "set-top-level-value!", fl_set_top_level_value },
{ "raise", fl_raise }, { "raise", fl_raise },
{ "exit", fl_exit }, { "exit", fl_exit },
{ "intern", fl_intern }, { "intern", fl_intern },
{ "fixnum", fl_fixnum }, { "fixnum", fl_fixnum },
{ "truncate", fl_truncate }, { "truncate", fl_truncate },
{ "integer?", fl_integerp }, { "integer?", fl_integerp },
{ "integer-valued?", fl_integer_valuedp },
{ "nconc", fl_nconc }, { "nconc", fl_nconc },
{ "assq", fl_assq }, { "assq", fl_assq },
{ "memq", fl_memq }, { "memq", fl_memq },

View File

@ -352,8 +352,8 @@
(not (in-env? head env)) (not (in-env? head env))
(bound? head) (bound? head)
(constant? head) (constant? head)
(builtin? (eval head))) (builtin? (top-level-value head)))
(eval head) (top-level-value head)
head))) head)))
(let ((b (and (builtin? head) (let ((b (and (builtin? head)
(builtin->instruction head)))) (builtin->instruction head))))

View File

@ -76,7 +76,7 @@
(#t (rest->cps prim->cps form k argsyms)))) (#t (rest->cps prim->cps form k argsyms))))
(define *top-k* (gensym)) (define *top-k* (gensym))
(set *top-k* identity) (set-top-level-value! *top-k* identity)
(define (cps form) (define (cps form)
(η-reduce (η-reduce

View File

@ -171,6 +171,7 @@ void raise(value_t e) __attribute__ ((__noreturn__));
void type_error(char *fname, char *expected, value_t got) __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__)); void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));
extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError; extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;
extern value_t UnboundError;
static inline void argcount(char *fname, uint32_t nargs, uint32_t c) static inline void argcount(char *fname, uint32_t nargs, uint32_t c)
{ {
if (__unlikely(nargs != c)) if (__unlikely(nargs != c))

View File

@ -21,8 +21,6 @@
(list 'set! form (car body)) (list 'set! form (car body))
(list 'set! (car form) (list 'lambda (cdr form) (f-body 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) (define (map f lst)
(if (atom? lst) lst (if (atom? lst) lst
(cons (f (car lst)) (map f (cdr lst))))) (cons (f (car lst)) (map f (cdr lst)))))
@ -298,7 +296,8 @@
(or (and (atom? x) (or (and (atom? x)
(not (symbol? x))) (not (symbol? x)))
(and (constant? x) (and (constant? x)
(eq x (eval x))))) (symbol? x)
(eq x (top-level-value x)))))
(define-macro (backquote x) (bq-process x)) (define-macro (backquote x) (bq-process x))
@ -451,11 +450,11 @@
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
(define (trace sym) (define (trace sym)
(let* ((lam (eval sym)) (let* ((lam (top-level-value sym))
(args (cadr lam)) (args (cadr lam))
(al (to-proper args))) (al (to-proper args)))
(if (not (eq? (car lam) 'trace-lambda)) (if (not (eq? (car lam) 'trace-lambda))
(set sym (set-top-level-value! sym
`(trace-lambda ,args `(trace-lambda ,args
(begin (begin
(princ "(") (princ "(")
@ -469,9 +468,9 @@
'ok) 'ok)
(define (untrace sym) (define (untrace sym)
(let ((lam (eval sym))) (let ((lam (top-level-value sym)))
(if (eq? (car lam) 'trace-lambda) (if (eq? (car lam) 'trace-lambda)
(set sym (set-top-level-value! sym
(cadr (caar (last-pair (caddr lam)))))))) (cadr (caar (last-pair (caddr lam))))))))
(define-macro (time expr) (define-macro (time expr)
@ -679,7 +678,7 @@
(lambda (e) (begin (io.discardbuffer *input-stream*) (lambda (e) (begin (io.discardbuffer *input-stream*)
(raise e)))))) (raise e))))))
(and (not (io.eof? *input-stream*)) (and (not (io.eof? *input-stream*))
(let ((V (eval (expand v)))) (let ((V (load-process v)))
(print V) (print V)
(set! that V) (set! that V)
#t)))) #t))))