add scheme apply, rename apply-> apply_env.

diff --git a/mes.c b/mes.c
index 62a89f0c4043ffdb60a16dfead5045872bc6a0a7..06a8c9a949cb924770a029eea8143d0806e77c4f 100644 (file)
--- 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 8c0d118a0144a7aa88e9f1c6ad7be451c6910d6a..ee371ba03f84e4cf07aa270e0fb4c864f980c5c9 100644 (file)
--- 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 e7bf3480d40148d0dad428c560c9bb168d8e46f6..6ec751e9b4e0ba0ead8be6006f87b8105f54856a 100755 (executable)
--- 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 c8768ecd317b2666bde7f4b50752c872927983f4..1dea3eba46692285d32dec644a264a043fd3235b 100755 (executable)
--- 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)))