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:
parent
86b7738c89
commit
2ed581e62d
|
@ -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 },
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
Loading…
Reference in New Issue