From c1886195e61f0d3b7f36c2c7b5af3b57943d1613 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 16 Jul 2016 08:17:56 +0200 Subject: [PATCH] add scheme apply, rename apply-> apply_env. --- mes.c | 36 +++++++++++++++--------------------- mes.mes | 20 ++++++++++---------- mes.scm | 11 +++++------ scm.mes | 3 +++ 4 files changed, 33 insertions(+), 37 deletions(-) diff --git a/mes.c b/mes.c index 62a89f0c..06a8c9a9 100644 --- a/mes.c +++ b/mes.c @@ -260,16 +260,10 @@ assq (scm *x, scm *a) } scm * -eval_quote (scm *fn, scm *x) -{ - return apply (fn, x, &scm_nil); -} - -scm * -apply_ (scm *fn, scm *x, scm *a) +apply_env_ (scm *fn, scm *x, scm *a) { #if DEBUG - printf ("apply fn="); + printf ("apply_env fn="); display (fn); printf (" x="); display (x); @@ -283,12 +277,12 @@ apply_ (scm *fn, scm *x, scm *a) return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil))); if (builtin_p (fn) == &scm_t) return call (fn, x); - return apply (eval (fn, a), x, a); + return apply_env (eval (fn, a), x, a); } else if (car (fn) == &scm_lambda) return begin_env (cddr (fn), pairlis (cadr (fn), x, a)); else if (car (fn) == &scm_label) - return apply (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a)); + return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a)); return &scm_unspecified; } @@ -358,11 +352,11 @@ eval_ (scm *e, scm *a) return evcon (cdr (e), a); #if MACROS else if ((macro = assq (car (e), cdr (assq (&scm_macro, a)))) != &scm_f) - return eval (apply_ (cdr (macro), cdr (e), a), a); + return eval (apply_env_ (cdr (macro), cdr (e), a), a); #endif // MACROS - return apply (car (e), evlis (cdr (e), a), a); + return apply_env (car (e), evlis (cdr (e), a), a); } - return apply (car (e), evlis (cdr (e), a), a); + return apply_env (car (e), evlis (cdr (e), a), a); } scm * @@ -633,10 +627,10 @@ values (scm *x/*...*/) scm * call_with_values_env (scm *producer, scm *consumer, scm *a) { - scm *v = apply_ (producer, &scm_nil, a); + scm *v = apply_env_ (producer, &scm_nil, a); if (v->type == VALUES) v = v->cdr; - return apply_ (consumer, v, a); + return apply_env_ (consumer, v, a); } scm * @@ -1173,7 +1167,7 @@ loop (scm *r, scm *e, scm *a) if (e == &scm_nil) return r; else if (eq_p (e, &scm_symbol_EOF) == &scm_t) - return apply (cdr (assq (&scm_symbol_loop2, a)), + return apply_env (cdr (assq (&scm_symbol_loop2, a)), cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a); else if (eq_p (e, &scm_symbol_EOF2) == &scm_t) return r; @@ -1202,18 +1196,18 @@ main (int argc, char *argv[]) } scm * -apply (scm *fn, scm *x, scm *a) +apply_env (scm *fn, scm *x, scm *a) { #if DEBUG - printf ("\nc:apply fn="); + printf ("\nc:apply_env fn="); display (fn); printf (" x="); display (x); puts (""); #endif - if (fn == &scm_apply_) + if (fn == &scm_apply_env_) return eval_ (x, a); - return apply_ (fn, x, a); + return apply_env_ (fn, x, a); } bool evalling_p = false; @@ -1234,7 +1228,7 @@ eval (scm *e, scm *a) || evalling_p) return eval_ (e, a); evalling_p = true; - scm *r = apply (eval__, cons (e, cons (a, &scm_nil)), a); + scm *r = apply_env (eval__, cons (e, cons (a, &scm_nil)), a); evalling_p = false; return r; } diff --git a/mes.mes b/mes.mes index 8c0d118a..ee371ba0 100644 --- a/mes.mes +++ b/mes.mes @@ -52,7 +52,7 @@ ;; ;; Page 13 ;; (define (eval-quote fn x) ;; ;(debug "eval-quote fn=~a x=~a" fn x) -;; (apply fn x '())) +;; (apply-env fn x '())) (define (evcon c a) ;;(debug "evcon c=~a a=~a\n" c a) @@ -78,8 +78,8 @@ (#t (cons (eval (car m) a) (evlis (cdr m) a))))) -(define (apply fn x a) - ;; (display 'mes-apply:) +(define (apply-env fn x a) + ;; (display 'mes-apply-env:) ;; (newline) ;; (display 'fn:) ;; (display fn) @@ -94,15 +94,15 @@ ((atom? fn) (cond ((eq? fn 'current-module) - (c:apply current-module '() a)) + (c:apply-env current-module '() a)) ((eq? fn 'call-with-values) - (c:apply 'call-with-values x a)) + (c:apply-env 'call-with-values x a)) ((builtin? fn) (call fn x)) - (#t (apply (eval fn a) x a)))) + (#t (apply-env (eval fn a) x a)))) ((eq? (car fn) 'lambda) (begin-env (cddr fn) (pairlis (cadr fn) x a))) - ((eq? (car fn) 'label) (apply (caddr fn) x (cons (cons (cadr fn) + ((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a))))) (define (begin-env body a) @@ -142,13 +142,13 @@ ((eq? (car e) 'cond) (evcon (cdr e) a)) ((pair? (assq (car e) (cdr (assq '*macro* a)))) (c:eval - (c:apply + (c:apply-env (cdr (assq (car e) (cdr (assq '*macro* a)))) (cdr e) a) a)) - (#t (apply (car e) (evlis (cdr e) a) a)))) - (#t (apply (car e) (evlis (cdr e) a) a)))) + (#t (apply-env (car e) (evlis (cdr e) a) a)))) + (#t (apply-env (car e) (evlis (cdr e) a) a)))) (define (eval-quasiquote e a) ;; (display 'mes-eval-quasiquote:) diff --git a/mes.scm b/mes.scm index e7bf3480..6ec751e9 100755 --- a/mes.scm +++ b/mes.scm @@ -58,7 +58,6 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" pair? ;; ADDITIONAL PRIMITIVES - apply number? procedure? < @@ -124,7 +123,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (eval e (append a environment))) (define (apply-environment fn e a) - (apply fn e (append a environment))) + (apply-env fn e (append a environment))) (define (readenv a) (let ((x (guile:read))) @@ -156,7 +155,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (assq . ,assq) (eval . ,eval-environment) - (apply . ,apply-environment) + (apply-env . ,apply-environment) (readenv . ,readenv) (display . ,guile:display) @@ -205,9 +204,9 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (define (loop r e a) (cond ((null? e) r) ((eq? e 'exit) - (apply (cdr (assq 'loop a)) - (cons *unspecified* (cons #t (cons a '()))) - a)) + (apply-env (cdr (assq 'loop a)) + (cons *unspecified* (cons #t (cons a '()))) + a)) ((atom? e) (loop (eval e a) (readenv a) a)) ((eq? (car e) 'define) (loop *unspecified* (readenv a) (cons (mes-define e a) a))) diff --git a/scm.mes b/scm.mes index c8768ecd..1dea3eba 100755 --- a/scm.mes +++ b/scm.mes @@ -108,3 +108,6 @@ (define (begin . rest) (let () rest)) + +(define (apply f args) + (c:eval (cons f args) (current-module)))