diff --git a/define.c b/define.c index 50f41eb3..e0687721 100644 --- a/define.c +++ b/define.c @@ -25,12 +25,12 @@ define_env (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_env (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_env (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 0d953f40..f049b784 100644 --- a/mes.c +++ b/mes.c @@ -355,8 +355,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_env (m, a); + scm *e = eval_env (car (m), a); return cons (e, evlis_env (cdr (m), a)); } @@ -392,7 +392,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_env (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"); @@ -401,37 +401,35 @@ apply_env (scm *fn, scm *x, scm *a) } scm * -builtin_eval (scm *e, scm *a) +eval_env (scm *e, scm *a) { - if (e->type == FUNCTION) return e; - if (e->type == SCM) return e; - if (e->type == SYMBOL) return assert_defined (assq_ref_cache (e, a)); - if (e->type != PAIR) return e; - if (e->car->type != PAIR) + switch (e->type) { - if (e->car == &symbol_quote) - return cadr (e); + case PAIR: + { + if (e->car == &symbol_quote) + return cadr (e); #if QUASISYNTAX - if (e->car == &symbol_syntax) - return e; + if (e->car == &symbol_syntax) + return e; #endif - if (e->car == &symbol_begin) - return begin_env (e, a); - if (e->car == &symbol_lambda) - return make_closure (cadr (e), cddr (e), assq (&scm_closure, a)); - if (e->car == &scm_closure) - return e; - if (e->car == &symbol_if) - return builtin_if (cdr (e), a); + if (e->car == &symbol_begin) + return begin_env (e, a); + if (e->car == &symbol_lambda) + return make_closure (cadr (e), cddr (e), assq (&scm_closure, a)); + if (e->car == &scm_closure) + return e; + if (e->car == &symbol_if) + return builtin_if (cdr (e), a); #if !BOOT - if (e->car == &symbol_define) - return define_env (e, a); - if (e->car == &symbol_define_macro) - return define_env (e, a); - if (e->car == &symbol_primitive_load) - return load_env (a); + if (e->car == &symbol_define) + return define_env (e, a); + if (e->car == &symbol_define_macro) + return define_env (e, a); + if (e->car == &symbol_primitive_load) + return load_env (a); #else - if (e->car == &symbol_define) { +if (e->car == &symbol_define) { fprintf (stderr, "C DEFINE: "); display_ (stderr, e->cdr->car->type == SYMBOL @@ -443,23 +441,26 @@ 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_env (caddr (e), a), a); #if QUASIQUOTE if (e->car == &symbol_unquote) - return builtin_eval (cadr (e), a); + return eval_env (cadr (e), a); if (e->car == &symbol_quasiquote) return eval_quasiquote (cadr (e), add_unquoters (a)); #endif //QUASIQUOTE #if QUASISYNTAX if (e->car == &symbol_unsyntax) - return builtin_eval (cadr (e), a); + return eval_env (cadr (e), a); if (e->car == &symbol_quasisyntax) return eval_quasisyntax (cadr (e), add_unsyntaxers (a)); #endif //QUASISYNTAX scm *x = expand_macro_env (e, a); - if (x != e) return builtin_eval (x, a); + if (x != e) return eval_env (x, a); + return apply_env (e->car, evlis_env (e->cdr, a), a); + } + case SYMBOL: return assert_defined (assq_ref_cache (e, a)); + default: return e; } - return apply_env (e->car, evlis_env (e->cdr, a), a); } scm * @@ -491,7 +492,7 @@ begin_env (scm *e, scm *a) { scm *r = &scm_unspecified; while (e != &scm_nil) { - r = builtin_eval (e->car, a); + r = eval_env (e->car, a); e = e->cdr; } return r; @@ -500,10 +501,10 @@ begin_env (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_env (car (e), a) != &scm_f) + return eval_env (cadr (e), a); if (cddr (e) != &scm_nil) - return builtin_eval (caddr (e), a); + return eval_env (caddr (e), a); return &scm_unspecified; } diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index 55e496b3..f589c3cb 100644 --- a/module/mes/base-0.mes +++ b/module/mes/base-0.mes @@ -26,8 +26,8 @@ ;;; Code: -;;(define (apply f x) (apply-env f x (current-module))) -(define (primitive-eval e) (eval e (current-module))) +(define (primitive-eval e) (eval-env e (current-module))) +(define eval eval-env) (define (expand-macro e) (expand-macro-env e (current-module))) (define quotient /) diff --git a/module/mes/loop-0.mes b/module/mes/loop-0.mes index 9e4b2fad..7a1e3c20 100644 --- a/module/mes/loop-0.mes +++ b/module/mes/loop-0.mes @@ -37,8 +37,8 @@ ((label loop-0 (lambda (r e a) ;; (display "***LOOP-0*** ... e=") (display e) (newline) - (if (null? e) (eval (cons 'begin (read-file-env (read-env a) a)) a) - (if (atom? e) (loop-0 (eval e a) (read-env a) a) + (if (null? e) (eval-env (cons 'begin (read-file-env (read-env a) a)) a) + (if (atom? e) (loop-0 (eval-env e a) (read-env a) a) (if (eq? (car e) 'define) ((lambda (aa) ; env:define ;; (display "0DEFINE name=") (display (cadr e)) (newline) @@ -47,8 +47,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-env (caddr e) a)) + (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))) '())) (if (eq? (car e) 'define-macro) ((lambda (name+entry) ; env:macro @@ -64,10 +64,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-env (caddr e) a)) + (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))) '()) - (loop-0 (eval e a) (read-env a) a))))))) + (loop-0 (eval-env 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 7f67cbf7..0854a1de 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-env m a)) + (#t (cons (eval-env (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) (call call-with-values-env (append x (cons a '())))) ((eq? fn 'current-module) a) - (#t (apply-env (eval fn a) x a)))) + (#t (apply-env (eval-env fn a) x a)))) ((eq? (car fn) 'lambda) (let ((p (pairlis (cadr fn) x a))) (cache-invalidate-range p (cdr a)) @@ -106,7 +106,7 @@ (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-env fn a) x a)))) (define (eval-expand e a) (cond @@ -122,9 +122,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-env (caddr e) a) a)) + ((eq? (car e) 'apply-env) (apply-env (eval-env (cadr e) a) (evlis-env (caddr e) a) a)) + ((eq? (car e) 'unquote) (eval-env (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)))) @@ -140,7 +140,7 @@ (define (add-unquoters a) (cons %the-unquoters a)) -(define (eval e a) +(define (eval-env e a) (eval-expand (expand-macro-env e a) a)) (define (expand-macro-env e a) @@ -152,27 +152,27 @@ (define (eval-begin-env e a) (if (null? e) *unspecified* - (if (null? (cdr e)) (eval (car e) a) + (if (null? (cdr e)) (eval-env (car e) a) (begin - (eval (car e) a) + (eval-env (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-env (car e) a) (eval-env (cadr e) a) + (if (pair? (cddr e)) (eval-env (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-env (cadr e) a)) ((and (pair? (car e)) (eq? (caar e) 'unquote-splicing)) - (append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a))) + (append2 (eval-env (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-env (caddr e) a)) + (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a)))) (define (env:define a+ a) (set-cdr! a+ (cdr a)) diff --git a/module/mes/repl.mes b/module/mes/repl.mes index d221937f..579c3f58 100644 --- a/module/mes/repl.mes +++ b/module/mes/repl.mes @@ -160,7 +160,7 @@ along with Mes. If not, see . (begin (meta (cadr sexp)) (loop a)) - (let ((e (eval sexp a))) + (let ((e (eval-env sexp a))) (if (eq? e *unspecified*) (loop a) (let ((id (string->symbol (string-append "$" (number->string count))))) (set! count (+ count 1)) diff --git a/quasiquote.c b/quasiquote.c index 11a3d596..e2518e72 100644 --- a/quasiquote.c +++ b/quasiquote.c @@ -39,10 +39,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_env (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_env (cadar (e), a), eval_quasiquote (cdr (e), a)); return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a)); } @@ -90,10 +90,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_env (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_env (cadar (e), a), eval_quasisyntax (cdr (e), a)); return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a)); }