Avoid gratuitous consing with begin and quasiquote.

* mes.c (apply_env, main): Call begin rather than eval with cons'ed
  symbol begin.
* module/mes/mes-0.mes (apply-env): Likewise.
* quasiquote.c (add_unquoters): cons global unquoters rather than
  creating it fresh.
* module/mes/mes-0.mes (add-unquoters): Likewise.

diff --git a/mes.c b/mes.c
index a7b055efacc4e5cd358b665c7df6c1321a9612d5..b08a6e0cd777a898cc9f756522f701d3011cb965 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -332,7 +332,7 @@ apply_env (scm *fn, scm *x, scm *a)
   else if (fn->car == &scm_lambda) {
     scm *p = pairlis (cadr (fn), x, a);
     cache_invalidate_range (p, a->cdr);
-    scm *r = builtin_eval (cons (&symbol_begin, cddr (fn)), cons (cons (&scm_closure, p), p));
+    scm *r = begin (cddr (fn), cons (cons (&scm_closure, p), p));
     cache_invalidate_range (p, a->cdr);
     return r;
   }
@@ -343,7 +343,7 @@ apply_env (scm *fn, scm *x, scm *a)
     a = cdr (a);
     scm *p = pairlis (args, x, a);
     cache_invalidate_range (p, a->cdr);
-    scm *r = builtin_eval (cons (&symbol_begin, body), cons (cons (&scm_closure, p), p));
+    scm *r = begin (body, cons (cons (&scm_closure, p), p));
     cache_invalidate_range (p, a->cdr);
     return r;
   }
@@ -1038,7 +1038,7 @@ main (int argc, char *argv[])
   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
   if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.0\n");
   scm *a = mes_environment ();
-  display_ (stderr, builtin_eval (cons (&symbol_begin, read_file (read_env (a), a)), a));
+  display_ (stderr, begin (read_file (read_env (a), a), a));
   fputs ("", stderr);
   return 0;
 }

diff --git a/module/mes/mes-0.mes b/module/mes/mes-0.mes
index e5fbe0afd8aceb48bfb3206cd228582aac4d1b86..2fda9f71c60f79a0a1f8709688ed4ebea990348e 100644 (file)
--- a/module/mes/mes-0.mes
+++ b/module/mes/mes-0.mes
@@ -93,7 +93,7 @@
    ((eq? (car fn) 'lambda)
     (let ((p (pairlis (cadr fn) x a)))
       (cache-invalidate-range p (cdr a))
-      (let ((r (eval (cons 'begin (cddr fn)) (cons (cons '*closure* p) p))))
+      (let ((r (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
         (cache-invalidate-range p (cdr a))
         r)))
    ((eq? (car fn) '*closure*)
@@ -102,7 +102,7 @@
           (a (cddr (cadr fn))))
       (let ((p (pairlis args x a)))
         (cache-invalidate-range p (cdr a))
-        (let ((r (eval (cons 'begin body) (cons (cons '*closure* p) p))))
+        (let ((r (eval-begin-env body (cons (cons '*closure* p) p))))
           (cache-invalidate-range p (cdr a))
           r))))
    ;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
@@ -132,9 +132,13 @@
 (define (unquote x) (cons 'unquote x))
 (define (unquote-splicing x) (cons 'quasiquote x))
 
+(define %the-unquoters
+  (cons
+   (cons 'unquote unquote)
+   (cons (cons 'unquote-splicing unquote-splicing) '())))
+
 (define (add-unquoters a)
-  (cons (cons 'unquote unquote)
-        (cons (cons 'unquote-splicing unquote-splicing) a)))
+  (cons %the-unquoters a))
 
 (define (eval e a)
   (eval-expand (expand-macro-env e a) a))

diff --git a/module/mes/type-0.mes b/module/mes/type-0.mes
index 522b4a45441567843ec92bee9be6e47dd839cc33..81fc3edc656c0f364710226f386b7da010d7d007 100644 (file)
--- a/module/mes/type-0.mes
+++ b/module/mes/type-0.mes
@@ -23,9 +23,13 @@
 ;;; type-0.mes - to be loaded after loop-0.mes if type.i is not
 ;;; included in core.
 
+;;; This code is only loaded if environment variable TYPE0 is set.
+;;; There are two copies of the type enum, with manual numbering.  Not
+;;; good.
+
+
 ;;; Code:
 
-;; two copies of enum type, with manual numbering FIXME
 (define <char> 0)
 (define <macro> 1)
 (define <number> 2)

diff --git a/quasiquote.c b/quasiquote.c
index f724fe2aed0db9ae9556dbf9bcbd6fa7c9492475..f351aaa56c116a3e3548be609588c103647affe0 100644 (file)
--- a/quasiquote.c
+++ b/quasiquote.c
@@ -77,12 +77,17 @@ eval_quasisyntax (scm *e, scm *a)
 
 scm *add_environment (scm *a, char const *name, scm *x);
 
+scm *
+the_unquoters = &scm_nil;
+
 scm *
 add_unquoters (scm *a)
 {
-  a = cons (cons (&symbol_unquote, &scm_unquote), a);
-  a = cons (cons (&symbol_unquote_splicing, &scm_unquote_splicing), a);
-  return a;
+  if (the_unquoters == &scm_nil)
+    the_unquoters = cons (cons (&symbol_unquote, &scm_unquote),
+                          cons (cons (&symbol_unquote_splicing, &scm_unquote_splicing),
+                                &scm_nil));
+  return append2 (the_unquoters, a);
 }
 
 scm *