BOOT hack
This commit is contained in:
Jan Nieuwenhuizen
parent
f593a5c9d7
commit
6553b88599
4
define.c
4
define.c
|
|
@ -25,12 +25,12 @@ define (scm *x, scm *a)
|
|||
scm *e;
|
||||
scm *name = cadr (x);
|
||||
if (name->type != PAIR)
|
||||
e = builtin_eval (caddr (x), cons (cons (cadr (x), cadr (x)), a));
|
||||
e = eval (caddr (x), cons (cons (cadr (x), cadr (x)), a));
|
||||
else {
|
||||
name = car (name);
|
||||
scm *p = pairlis (cadr (x), cadr (x), a);
|
||||
cache_invalidate_range (p, a);
|
||||
e = builtin_eval (make_lambda (cdadr (x), cddr (x)), p);
|
||||
e = eval (make_lambda (cdadr (x), cddr (x)), p);
|
||||
}
|
||||
if (eq_p (car (x), &symbol_define_macro) == &scm_t)
|
||||
e = make_macro (name, e);
|
||||
|
|
|
|||
49
mes.c
49
mes.c
|
|
@ -330,8 +330,8 @@ scm *
|
|||
evlis_env (scm *m, scm *a)
|
||||
{
|
||||
if (m == &scm_nil) return &scm_nil;
|
||||
if (m->type != PAIR) return builtin_eval (m, a);
|
||||
scm *e = builtin_eval (car (m), a);
|
||||
if (m->type != PAIR) return eval (m, a);
|
||||
scm *e = eval (car (m), a);
|
||||
return cons (e, evlis_env (cdr (m), a));
|
||||
}
|
||||
|
||||
|
|
@ -342,6 +342,7 @@ apply_env (scm *fn, scm *x, scm *a)
|
|||
{
|
||||
if (fn == &scm_car) return x->car->car;
|
||||
if (fn == &scm_cdr) return x->car->cdr;
|
||||
if (fn == &scm_eval) assert (!"JA HEE!");
|
||||
if (builtin_p (fn) == &scm_t)
|
||||
return call (fn, x);
|
||||
if (eq_p (fn, &symbol_call_with_values) == &scm_t)
|
||||
|
|
@ -370,7 +371,7 @@ apply_env (scm *fn, scm *x, scm *a)
|
|||
else if (fn->car == &scm_label)
|
||||
return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
|
||||
#endif
|
||||
scm *efn = builtin_eval (fn, a);
|
||||
scm *efn = eval (fn, a);
|
||||
if (efn == &scm_f || efn == &scm_t) assert (!"apply bool");
|
||||
if (efn->type == NUMBER) assert (!"apply number");
|
||||
if (efn->type == STRING) assert (!"apply string");
|
||||
|
|
@ -378,7 +379,33 @@ apply_env (scm *fn, scm *x, scm *a)
|
|||
}
|
||||
|
||||
scm *
|
||||
builtin_eval (scm *e, scm *a)
|
||||
eval (scm *e, scm *a)
|
||||
{
|
||||
static scm s = {SYMBOL, "eval"};
|
||||
static scm *x = 0;
|
||||
fprintf (stderr, "c:eval e=");
|
||||
display_ (stderr, e);
|
||||
fprintf (stderr, "\n");
|
||||
|
||||
if (!x) x = make_symbol (&s);
|
||||
scm *eval = assq_ref_cache (x, a);
|
||||
|
||||
// fprintf (stderr, "eval=");
|
||||
// display_ (stderr, eval);
|
||||
// fprintf (stderr, "\n");
|
||||
|
||||
|
||||
if (eval != &scm_undefined && builtin_p (eval) == &scm_f) {
|
||||
fprintf (stderr, "gotta eval=");
|
||||
display_ (stderr, eval);
|
||||
fprintf (stderr, "\n");
|
||||
// return apply_env (eval, cons (e, cons (a, &scm_nil)), a);
|
||||
}
|
||||
return eval_ (e, a);
|
||||
}
|
||||
|
||||
scm *
|
||||
eval_ (scm *e, scm *a)
|
||||
{
|
||||
if (builtin_p (e) == &scm_t) return e;
|
||||
if (e->type == SCM) return e;
|
||||
|
|
@ -429,14 +456,14 @@ builtin_eval (scm *e, scm *a)
|
|||
assert (e->car != &symbol_define_macro);
|
||||
#endif
|
||||
if (e->car == &symbol_set_x)
|
||||
return set_env_x (cadr (e), builtin_eval (caddr (e), a), a);
|
||||
return set_env_x (cadr (e), eval (caddr (e), a), a);
|
||||
#if QUASIQUOTE
|
||||
if (e->car == &symbol_unquote)
|
||||
return builtin_eval (cadr (e), a);
|
||||
return eval (cadr (e), a);
|
||||
if (e->car == &symbol_quasiquote)
|
||||
return eval_quasiquote (cadr (e), add_unquoters (a));
|
||||
if (e->car == &symbol_unsyntax)
|
||||
return builtin_eval (cadr (e), a);
|
||||
return eval (cadr (e), a);
|
||||
if (e->car == &symbol_quasisyntax)
|
||||
return eval_quasisyntax (cadr (e), add_unsyntaxers (a));
|
||||
#endif //QUASIQUOTE
|
||||
|
|
@ -459,7 +486,7 @@ begin (scm *e, scm *a)
|
|||
{
|
||||
scm *r = &scm_unspecified;
|
||||
while (e != &scm_nil) {
|
||||
r = builtin_eval (e->car, a);
|
||||
r = eval (e->car, a);
|
||||
e = e->cdr;
|
||||
}
|
||||
return r;
|
||||
|
|
@ -468,10 +495,10 @@ begin (scm *e, scm *a)
|
|||
scm *
|
||||
builtin_if (scm *e, scm *a)
|
||||
{
|
||||
if (builtin_eval (car (e), a) != &scm_f)
|
||||
return builtin_eval (cadr (e), a);
|
||||
if (eval (car (e), a) != &scm_f)
|
||||
return eval (cadr (e), a);
|
||||
if (cddr (e) != &scm_nil)
|
||||
return builtin_eval (caddr (e), a);
|
||||
return eval (caddr (e), a);
|
||||
return &scm_unspecified;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -36,9 +36,23 @@
|
|||
|
||||
((label loop-0
|
||||
(lambda (r e a)
|
||||
;; (display "***LOOP-0*** ... e=") (display e) (newline)
|
||||
(if (null? e) (eval (read-file (read-env a) a) a)
|
||||
(if (atom? e) (loop-0 (eval e a) (read-env a) a)
|
||||
(display "***LOOP-0*** ... e=") (display e) (newline)
|
||||
(if (null? e) ;;(eval (read-file (read-env a) a) a)
|
||||
((lambda (program)
|
||||
(display "LOOP done eval=")
|
||||
(display (cddr evlis-env))
|
||||
(newline)
|
||||
(display "program=")
|
||||
(display program)
|
||||
(newline)
|
||||
;;(eval (read-file (read-env a) a) a)
|
||||
;;(apply-env eval (read-file (read-env a) a) a)
|
||||
;;(loop-1 (read-file (read-env a) a) a)
|
||||
(eval-expand program a)
|
||||
)
|
||||
(read-file (read-env a) a)
|
||||
)
|
||||
(if (atom? e) (loop-0 (eval- e a) (read-env a) a)
|
||||
(if (eq? (car e) 'define)
|
||||
((lambda (aa) ; env:define
|
||||
;; (display "0DEFINE name=") (display (cadr e)) (newline)
|
||||
|
|
@ -47,8 +61,8 @@
|
|||
(set-cdr! (assq '*closure* a) a)
|
||||
(loop-0 *unspecified* (read-env a) a))
|
||||
(cons ; sexp:define
|
||||
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
|
||||
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a)))
|
||||
(if (atom? (cadr e)) (cons (cadr e) (eval- (caddr e) a))
|
||||
(cons (caadr e) (eval- (cons 'lambda (cons (cdadr e) (cddr e))) a)))
|
||||
'()))
|
||||
(if (eq? (car e) 'define-macro)
|
||||
((lambda (name+entry) ; env:macro
|
||||
|
|
@ -64,10 +78,10 @@
|
|||
(cdr name+entry)))
|
||||
'())))
|
||||
; sexp:define
|
||||
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
|
||||
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a)))
|
||||
(if (atom? (cadr e)) (cons (cadr e) (eval- (caddr e) a))
|
||||
(cons (caadr e) (eval- (cons 'lambda (cons (cdadr e) (cddr e))) a)))
|
||||
'())
|
||||
(loop-0 (eval e a) (read-env a) a)))))))
|
||||
(loop-0 (eval- e a) (read-env a) a)))))))
|
||||
*unspecified* (read-env '()) (current-module))
|
||||
|
||||
()
|
||||
|
|
|
|||
|
|
@ -79,8 +79,8 @@
|
|||
(define (evlis-env m a)
|
||||
(cond
|
||||
((null? m) '())
|
||||
((not (pair? m)) (eval m a))
|
||||
(#t (cons (eval (car m) a) (evlis-env (cdr m) a)))))
|
||||
((not (pair? m)) (eval-expand m a))
|
||||
(#t (cons (eval-expand (car m) a) (evlis-env (cdr m) a)))))
|
||||
|
||||
(define (apply-env fn x a)
|
||||
(cond
|
||||
|
|
@ -89,7 +89,7 @@
|
|||
((builtin? fn) (call fn x))
|
||||
((eq? fn 'call-with-values) (c:apply-env 'call-with-values x a))
|
||||
((eq? fn 'current-module) a)
|
||||
(#t (apply-env (eval fn a) x a))))
|
||||
(#t (apply-env (eval-expand fn a) x a))))
|
||||
((eq? (car fn) 'lambda)
|
||||
(let ((p (pairlis (cadr fn) x a)))
|
||||
(cache-invalidate-range p (cdr a))
|
||||
|
|
@ -106,9 +106,10 @@
|
|||
(cache-invalidate-range p (cdr a))
|
||||
r))))
|
||||
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
|
||||
(#t (apply-env (eval fn a) x a))))
|
||||
(#t (apply-env (eval-expand fn a) x a))))
|
||||
|
||||
(define (eval-expand e a)
|
||||
(display "mes:eval-expand e=") (display e) (newline)
|
||||
(cond
|
||||
((symbol? e) (assq-ref-cache e a))
|
||||
((atom? e) e)
|
||||
|
|
@ -122,9 +123,9 @@
|
|||
((eq? (car e) 'if) (eval-if-env (cdr e) a))
|
||||
((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
|
||||
((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
|
||||
((eq? (car e) 'set!) (set-env! (cadr e) (eval (caddr e) a) a))
|
||||
((eq? (car e) 'apply-env) (apply-env (eval (cadr e) a) (evlis-env (caddr e) a) a))
|
||||
((eq? (car e) 'unquote) (eval (cadr e) a))
|
||||
((eq? (car e) 'set!) (set-env! (cadr e) (eval-expand (caddr e) a) a))
|
||||
((eq? (car e) 'apply-env) (apply-env (eval-expand (cadr e) a) (evlis-env (caddr e) a) a))
|
||||
((eq? (car e) 'unquote) (eval-expand (cadr e) a))
|
||||
((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
|
||||
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
|
||||
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
|
||||
|
|
@ -141,6 +142,7 @@
|
|||
(cons %the-unquoters a))
|
||||
|
||||
(define (eval e a)
|
||||
(display "mes:eval-expand e=") (display e) (newline)
|
||||
(eval-expand (expand-macro-env e a) a))
|
||||
|
||||
(define (expand-macro-env e a)
|
||||
|
|
@ -152,27 +154,27 @@
|
|||
|
||||
(define (eval-begin-env e a)
|
||||
(if (null? e) *unspecified*
|
||||
(if (null? (cdr e)) (eval (car e) a)
|
||||
(if (null? (cdr e)) (eval-expand (car e) a)
|
||||
(begin
|
||||
(eval (car e) a)
|
||||
(eval-expand (car e) a)
|
||||
(eval-begin-env (cdr e) a)))))
|
||||
|
||||
(define (eval-if-env e a)
|
||||
(if (eval (car e) a) (eval (cadr e) a)
|
||||
(if (pair? (cddr e)) (eval (caddr e) a))))
|
||||
(if (eval-expand (car e) a) (eval-expand (cadr e) a)
|
||||
(if (pair? (cddr e)) (eval-expand (caddr e) a))))
|
||||
|
||||
(define (eval-quasiquote e a)
|
||||
(cond ((null? e) e)
|
||||
((atom? e) e)
|
||||
((eq? (car e) 'unquote) (eval (cadr e) a))
|
||||
((eq? (car e) 'unquote) (eval-expand (cadr e) a))
|
||||
((and (pair? (car e))
|
||||
(eq? (caar e) 'unquote-splicing))
|
||||
(append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a)))
|
||||
(append2 (eval-expand (cadar e) a) (eval-quasiquote (cdr e) a)))
|
||||
(#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
|
||||
|
||||
(define (sexp:define e a)
|
||||
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
|
||||
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))
|
||||
(if (atom? (cadr e)) (cons (cadr e) (eval-expand (caddr e) a))
|
||||
(cons (caadr e) (eval-expand (cons 'lambda (cons (cdadr e) (cddr e))) a))))
|
||||
|
||||
(define (env:define a+ a)
|
||||
(set-cdr! a+ (cdr a))
|
||||
|
|
@ -189,4 +191,6 @@
|
|||
;; boot into loop-0
|
||||
(cache-invalidate-range (current-module) '())
|
||||
()
|
||||
ignored
|
||||
;;ignored
|
||||
begin
|
||||
|
||||
|
|
|
|||
|
|
@ -55,10 +55,10 @@ eval_quasiquote (scm *e, scm *a)
|
|||
if (e == &scm_nil) return e;
|
||||
else if (atom_p (e) == &scm_t) return e;
|
||||
else if (eq_p (car (e), &symbol_unquote) == &scm_t)
|
||||
return builtin_eval (cadr (e), a);
|
||||
return eval (cadr (e), a);
|
||||
else if (e->type == PAIR && e->car->type == PAIR
|
||||
&& eq_p (caar (e), &symbol_unquote_splicing) == &scm_t)
|
||||
return append2 (builtin_eval (cadar (e), a), eval_quasiquote (cdr (e), a));
|
||||
return append2 (eval (cadar (e), a), eval_quasiquote (cdr (e), a));
|
||||
return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a));
|
||||
}
|
||||
|
||||
|
|
@ -68,10 +68,10 @@ eval_quasisyntax (scm *e, scm *a)
|
|||
if (e == &scm_nil) return e;
|
||||
else if (atom_p (e) == &scm_t) return e;
|
||||
else if (eq_p (car (e), &symbol_unsyntax) == &scm_t)
|
||||
return builtin_eval (cadr (e), a);
|
||||
return eval (cadr (e), a);
|
||||
else if (e->type == PAIR && e->car->type == PAIR
|
||||
&& eq_p (caar (e), &symbol_unsyntax_splicing) == &scm_t)
|
||||
return append2 (builtin_eval (cadar (e), a), eval_quasisyntax (cdr (e), a));
|
||||
return append2 (eval (cadar (e), a), eval_quasisyntax (cdr (e), a));
|
||||
return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a));
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue