diff --git a/define.c b/define.c index fd6c87e3..9c026f7c 100644 --- a/define.c +++ b/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); diff --git a/mes.c b/mes.c index 1e67f26e..0e0a840d 100644 --- a/mes.c +++ b/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; } diff --git a/module/mes/loop-0.mes b/module/mes/loop-0.mes index 6fbf654c..01856e15 100644 --- a/module/mes/loop-0.mes +++ b/module/mes/loop-0.mes @@ -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)) () diff --git a/module/mes/mes-0.mes b/module/mes/mes-0.mes index 2fda9f71..5952421b 100644 --- a/module/mes/mes-0.mes +++ b/module/mes/mes-0.mes @@ -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 + diff --git a/quasiquote.c b/quasiquote.c index f351aaa5..fe54d92c 100644 --- a/quasiquote.c +++ b/quasiquote.c @@ -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)); }