diff options
author | Andy Wingo <wingo@pobox.com> | 2011-06-02 17:41:45 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-06-02 17:45:58 +0200 |
commit | a881a4ae3bc1f2cc00ac7274e286271b6f55287c (patch) | |
tree | 7c7bd3456d31952f5db8fc180fba5b849d7407f9 /module/ice-9/psyntax.scm | |
parent | 7081d4f981a53ef488b823a1f76d33619d715d7f (diff) | |
download | guile-a881a4ae3bc1f2cc00ac7274e286271b6f55287c.tar.gz |
add <primcall> to tree-il
* libguile/expand.c:
* libguile/expand.h (SCM_EXPANDED_PRIMCALL_TYPE_NAME):
(SCM_EXPANDED_PRIMCALL_FIELD_NAMES):
(SCM_EXPANDED_PRIMCALL_SRC):
(SCM_EXPANDED_PRIMCALL_NAME):
(SCM_EXPANDED_PRIMCALL_ARGS):
(SCM_MAKE_EXPANDED_PRIMCALL): Add "primcall" Tree-IL type.
* doc/ref/compiler.texi (Tree-IL): Update docs.
* libguile/memoize.c (memoize): Memoizer for primcalls.
* module/ice-9/psyntax.scm: Build primcalls, sometimes. Also change
build-primref to just make a primitive-ref.
* module/language/tree-il.scm: Add primcall to the exports, parsers,
serializers, etc.
* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/fix-letrec.scm:
* module/language/tree-il/inline.scm:
* module/language/tree-il/primitives.scm:
* module/language/elisp/compile-tree-il.scm: Add primcall support.
* test-suite/tests/tree-il.test: Use primcalls sometimes.
Diffstat (limited to 'module/ice-9/psyntax.scm')
-rw-r--r-- | module/ice-9/psyntax.scm | 67 |
1 files changed, 32 insertions, 35 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index e63f6481e..85fda9ace 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -402,12 +402,14 @@ (lambda (src req opt rest kw inits vars body else-case) (make-lambda-case src req opt rest kw inits vars body else-case))) + (define build-primcall + (lambda (src name args) + (make-primcall src name args))) + (define build-primref (lambda (src name) - (if (equal? (module-name (current-module)) '(guile)) - (make-toplevel-ref src name) - (make-module-ref src '(guile) name #f)))) - + (make-primitive-ref src name))) + (define (build-data src exp) (make-const src exp)) @@ -1038,9 +1040,9 @@ (build-global-definition no-source name - (build-call + (build-primcall no-source - (build-primref no-source 'make-syntax-transformer) + 'make-syntax-transformer (list (build-data no-source name) (build-data no-source 'macro) e))))) @@ -1954,9 +1956,7 @@ (if (list? (cadr x)) (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) (error "how did we get here" x))) - (else (build-call no-source - (build-primref no-source (car x)) - (map regen (cdr x))))))) + (else (build-primcall no-source (car x) (map regen (cdr x))))))) (lambda (e r w s mod) (let ((e (source-wrap e w s mod))) @@ -2288,20 +2288,21 @@ (lambda (pvars exp y r mod) (let ((ids (map car pvars)) (levels (map cdr pvars))) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (build-call no-source - (build-primref no-source 'apply) - (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() - (chi exp - (extend-env - labels - (map (lambda (var level) - (make-binding 'syntax `(,var . ,level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels empty-wrap) - mod)) - y)))))) + (build-primcall + no-source + 'apply + (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() + (chi exp + (extend-env + labels + (map (lambda (var level) + (make-binding 'syntax `(,var . ,level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap) + mod)) + y)))))) (define gen-clause (lambda (x keys clauses r pat fender exp mod) @@ -2330,22 +2331,18 @@ (build-dispatch-call pvars exp y r mod) (gen-syntax-case x keys clauses r mod)))) (list (if (eq? p 'any) - (build-call no-source - (build-primref no-source 'list) - (list x)) - (build-call no-source - (build-primref no-source '$sc-dispatch) - (list x (build-data no-source p))))))))))))) + (build-primcall no-source 'list (list x)) + (build-primcall no-source '$sc-dispatch + (list x (build-data no-source p))))))))))))) (define gen-syntax-case (lambda (x keys clauses r mod) (if (null? clauses) - (build-call no-source - (build-primref no-source 'syntax-violation) - (list (build-data no-source #f) - (build-data no-source - "source expression failed to match any pattern") - x)) + (build-primcall no-source 'syntax-violation + (list (build-data no-source #f) + (build-data no-source + "source expression failed to match any pattern") + x)) (syntax-case (car clauses) () ((pat exp) (if (and (id? #'pat) |