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.
This commit is contained in:
Jan Nieuwenhuizen 2016-10-23 10:08:04 +02:00
parent 011102bc12
commit 2823fca025
4 changed files with 24 additions and 11 deletions

6
mes.c
View file

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

View file

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

View file

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

View file

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