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 *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);

75
mes.c
View file

@ -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;
}

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

@ -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 /)

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

@ -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))
()

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

@ -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))

2
module/mes/repl.mes
View file

@ -160,7 +160,7 @@ along with Mes. If not, see <http://www.gnu.org/licenses/>.
(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))

8
quasiquote.c
View file

@ -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));
}