artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: Refactor eval.

Browse source 
* mes.c (eval_env): Rename from builtin_eval, Update callers.  Use switch.
This commit is contained in:
Jan Nieuwenhuizen 2016-11-03 21:43:01 +01:00
parent 7e8341d76c
commit a0709313ca
7 changed files with 70 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
define.c
View file

@ -25,12 +25,12 @@ define_env (scm *x, scm *a)
scm *e; scm *e;
scm *name = cadr (x); scm *name = cadr (x);
if (name->type != PAIR) 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 { else {
name = car (name); name = car (name);
scm *p = pairlis (cadr (x), cadr (x), a); scm *p = pairlis (cadr (x), cadr (x), a);
cache_invalidate_range (p, 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) if (eq_p (car (x), &symbol_define_macro) == &scm_t)
e = make_macro (name, e); e = make_macro (name, e);

75
mes.c
View file

@ -355,8 +355,8 @@ scm *
evlis_env (scm *m, scm *a) evlis_env (scm *m, scm *a)
{ {
if (m == &scm_nil) return &scm_nil; if (m == &scm_nil) return &scm_nil;
if (m->type != PAIR) return builtin_eval (m, a); if (m->type != PAIR) return eval_env (m, a);
scm *e = builtin_eval (car (m), a); scm *e = eval_env (car (m), a);
return cons (e, evlis_env (cdr (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) else if (fn->car == &scm_label)
return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a)); return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
#endif #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 == &scm_f || efn == &scm_t) assert (!"apply bool");
if (efn->type == NUMBER) assert (!"apply number"); if (efn->type == NUMBER) assert (!"apply number");
if (efn->type == STRING) assert (!"apply string"); if (efn->type == STRING) assert (!"apply string");
@ -401,37 +401,35 @@ apply_env (scm *fn, scm *x, scm *a)
} }
scm * scm *
builtin_eval (scm *e, scm *a) eval_env (scm *e, scm *a)
{ {
if (e->type == FUNCTION) return e; switch (e->type)
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)
{ {
if (e->car == &symbol_quote) case PAIR:
return cadr (e); {
if (e->car == &symbol_quote)
return cadr (e);
#if QUASISYNTAX #if QUASISYNTAX
if (e->car == &symbol_syntax) if (e->car == &symbol_syntax)
return e; return e;
#endif #endif
if (e->car == &symbol_begin) if (e->car == &symbol_begin)
return begin_env (e, a); return begin_env (e, a);
if (e->car == &symbol_lambda) if (e->car == &symbol_lambda)
return make_closure (cadr (e), cddr (e), assq (&scm_closure, a)); return make_closure (cadr (e), cddr (e), assq (&scm_closure, a));
if (e->car == &scm_closure) if (e->car == &scm_closure)
return e; return e;
if (e->car == &symbol_if) if (e->car == &symbol_if)
return builtin_if (cdr (e), a); return builtin_if (cdr (e), a);
#if !BOOT #if !BOOT
if (e->car == &symbol_define) if (e->car == &symbol_define)
return define_env (e, a); return define_env (e, a);
if (e->car == &symbol_define_macro) if (e->car == &symbol_define_macro)
return define_env (e, a); return define_env (e, a);
if (e->car == &symbol_primitive_load) if (e->car == &symbol_primitive_load)
return load_env (a); return load_env (a);
#else #else
if (e->car == &symbol_define) { if (e->car == &symbol_define) {
fprintf (stderr, "C DEFINE: "); fprintf (stderr, "C DEFINE: ");
display_ (stderr, display_ (stderr,
e->cdr->car->type == SYMBOL e->cdr->car->type == SYMBOL
@ -443,23 +441,26 @@ builtin_eval (scm *e, scm *a)
assert (e->car != &symbol_define_macro); assert (e->car != &symbol_define_macro);
#endif #endif
if (e->car == &symbol_set_x) 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 QUASIQUOTE
if (e->car == &symbol_unquote) if (e->car == &symbol_unquote)
return builtin_eval (cadr (e), a); return eval_env (cadr (e), a);
if (e->car == &symbol_quasiquote) if (e->car == &symbol_quasiquote)
return eval_quasiquote (cadr (e), add_unquoters (a)); return eval_quasiquote (cadr (e), add_unquoters (a));
#endif //QUASIQUOTE #endif //QUASIQUOTE
#if QUASISYNTAX #if QUASISYNTAX
if (e->car == &symbol_unsyntax) if (e->car == &symbol_unsyntax)
return builtin_eval (cadr (e), a); return eval_env (cadr (e), a);
if (e->car == &symbol_quasisyntax) if (e->car == &symbol_quasisyntax)
return eval_quasisyntax (cadr (e), add_unsyntaxers (a)); return eval_quasisyntax (cadr (e), add_unsyntaxers (a));
#endif //QUASISYNTAX #endif //QUASISYNTAX
scm *x = expand_macro_env (e, a); 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 * scm *
@ -491,7 +492,7 @@ begin_env (scm *e, scm *a)
{ {
scm *r = &scm_unspecified; scm *r = &scm_unspecified;
while (e != &scm_nil) { while (e != &scm_nil) {
r = builtin_eval (e->car, a); r = eval_env (e->car, a);
e = e->cdr; e = e->cdr;
} }
return r; return r;
@ -500,10 +501,10 @@ begin_env (scm *e, scm *a)
scm * scm *
builtin_if (scm *e, scm *a) builtin_if (scm *e, scm *a)
{ {
if (builtin_eval (car (e), a) != &scm_f) if (eval_env (car (e), a) != &scm_f)
return builtin_eval (cadr (e), a); return eval_env (cadr (e), a);
if (cddr (e) != &scm_nil) if (cddr (e) != &scm_nil)
return builtin_eval (caddr (e), a); return eval_env (caddr (e), a);
return &scm_unspecified; return &scm_unspecified;
} }

4
module/mes/base-0.mes
View file

@ -26,8 +26,8 @@
;;; Code: ;;; Code:
;;(define (apply f x) (apply-env f x (current-module))) (define (primitive-eval e) (eval-env e (current-module)))
(define (primitive-eval e) (eval e (current-module))) (define eval eval-env)
(define (expand-macro e) (expand-macro-env e (current-module))) (define (expand-macro e) (expand-macro-env e (current-module)))
(define quotient /) (define quotient /)

14
module/mes/loop-0.mes
View file

@ -37,8 +37,8 @@
((label loop-0 ((label loop-0
(lambda (r e a) (lambda (r e a)
;; (display "***LOOP-0*** ... e=") (display e) (newline) ;; (display "***LOOP-0*** ... e=") (display e) (newline)
(if (null? e) (eval (cons 'begin (read-file-env (read-env a) a)) a) (if (null? e) (eval-env (cons 'begin (read-file-env (read-env a) a)) a)
(if (atom? e) (loop-0 (eval e a) (read-env a) a) (if (atom? e) (loop-0 (eval-env e a) (read-env a) a)
(if (eq? (car e) 'define) (if (eq? (car e) 'define)
((lambda (aa) ; env:define ((lambda (aa) ; env:define
;; (display "0DEFINE name=") (display (cadr e)) (newline) ;; (display "0DEFINE name=") (display (cadr e)) (newline)
@ -47,8 +47,8 @@
(set-cdr! (assq '*closure* a) a) (set-cdr! (assq '*closure* a) a)
(loop-0 *unspecified* (read-env a) a)) (loop-0 *unspecified* (read-env a) a))
(cons ; sexp:define (cons ; sexp:define
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a)) (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a))) (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a)))
'())) '()))
(if (eq? (car e) 'define-macro) (if (eq? (car e) 'define-macro)
((lambda (name+entry) ; env:macro ((lambda (name+entry) ; env:macro
@ -64,10 +64,10 @@
(cdr name+entry))) (cdr name+entry)))
'()))) '())))
; sexp:define ; sexp:define
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a)) (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr 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)) *unspecified* (read-env '()) (current-module))
() ()

32
module/mes/mes-0.mes
View file

@ -79,8 +79,8 @@
(define (evlis-env m a) (define (evlis-env m a)
(cond (cond
((null? m) '()) ((null? m) '())
((not (pair? m)) (eval m a)) ((not (pair? m)) (eval-env m a))
(#t (cons (eval (car m) a) (evlis-env (cdr m) a))))) (#t (cons (eval-env (car m) a) (evlis-env (cdr m) a)))))
(define (apply-env fn x a) (define (apply-env fn x a)
(cond (cond
@ -89,7 +89,7 @@
((builtin? fn) (call fn x)) ((builtin? fn) (call fn x))
((eq? fn 'call-with-values) (call call-with-values-env (append x (cons a '())))) ((eq? fn 'call-with-values) (call call-with-values-env (append x (cons a '()))))
((eq? fn 'current-module) 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) ((eq? (car fn) 'lambda)
(let ((p (pairlis (cadr fn) x a))) (let ((p (pairlis (cadr fn) x a)))
(cache-invalidate-range p (cdr a)) (cache-invalidate-range p (cdr a))
@ -106,7 +106,7 @@
(cache-invalidate-range p (cdr a)) (cache-invalidate-range p (cdr a))
r)))) r))))
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a))) ;;((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) (define (eval-expand e a)
(cond (cond
@ -122,9 +122,9 @@
((eq? (car e) 'if) (eval-if-env (cdr e) a)) ((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) (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) '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) 'set!) (set-env! (cadr e) (eval-env (caddr e) a) a))
((eq? (car e) 'apply-env) (apply-env (eval (cadr e) a) (evlis-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 (cadr e) a)) ((eq? (car e) 'unquote) (eval-env (cadr e) a))
((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters 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))))
(#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) (define (add-unquoters a)
(cons %the-unquoters a)) (cons %the-unquoters a))
(define (eval e a) (define (eval-env e a)
(eval-expand (expand-macro-env e a) a)) (eval-expand (expand-macro-env e a) a))
(define (expand-macro-env e a) (define (expand-macro-env e a)
@ -152,27 +152,27 @@
(define (eval-begin-env e a) (define (eval-begin-env e a)
(if (null? e) *unspecified* (if (null? e) *unspecified*
(if (null? (cdr e)) (eval (car e) a) (if (null? (cdr e)) (eval-env (car e) a)
(begin (begin
(eval (car e) a) (eval-env (car e) a)
(eval-begin-env (cdr e) a))))) (eval-begin-env (cdr e) a)))))
(define (eval-if-env e a) (define (eval-if-env e a)
(if (eval (car e) a) (eval (cadr e) a) (if (eval-env (car e) a) (eval-env (cadr e) a)
(if (pair? (cddr e)) (eval (caddr e) a)))) (if (pair? (cddr e)) (eval-env (caddr e) a))))
(define (eval-quasiquote e a) (define (eval-quasiquote e a)
(cond ((null? e) e) (cond ((null? e) e)
((atom? 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)) ((and (pair? (car e))
(eq? (caar e) 'unquote-splicing)) (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))))) (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
(define (sexp:define e a) (define (sexp:define e a)
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a)) (if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a)))) (cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))
(define (env:define a+ a) (define (env:define a+ a)
(set-cdr! a+ (cdr a)) (set-cdr! a+ (cdr a))

2
module/mes/repl.mes
View file

@ -160,7 +160,7 @@ along with Mes. If not, see <http://www.gnu.org/licenses/>.
(begin (begin
(meta (cadr sexp)) (meta (cadr sexp))
(loop a)) (loop a))
(let ((e (eval sexp a))) (let ((e (eval-env sexp a)))
(if (eq? e *unspecified*) (loop a) (if (eq? e *unspecified*) (loop a)
(let ((id (string->symbol (string-append "$" (number->string count))))) (let ((id (string->symbol (string-append "$" (number->string count)))))
(set! count (+ count 1)) (set! count (+ count 1))

8
quasiquote.c
View file

@ -39,10 +39,10 @@ eval_quasiquote (scm *e, scm *a)
if (e == &scm_nil) return e; if (e == &scm_nil) return e;
else if (atom_p (e) == &scm_t) return e; else if (atom_p (e) == &scm_t) return e;
else if (eq_p (car (e), &symbol_unquote) == &scm_t) 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 else if (e->type == PAIR && e->car->type == PAIR
&& eq_p (caar (e), &symbol_unquote_splicing) == &scm_t) && 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)); 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; if (e == &scm_nil) return e;
else if (atom_p (e) == &scm_t) return e; else if (atom_p (e) == &scm_t) return e;
else if (eq_p (car (e), &symbol_unsyntax) == &scm_t) 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 else if (e->type == PAIR && e->car->type == PAIR
&& eq_p (caar (e), &symbol_unsyntax_splicing) == &scm_t) && 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)); return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a));
} }