summaryrefslogtreecommitdiff
path: root/module/language/scheme/compile-ghil.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-08-17 23:39:56 +0200
committerLudovic Courtès <ludo@gnu.org>2009-08-18 00:06:45 +0200
commitfbb857a472eb4e69c1cba05e86646b7004f32df6 (patch)
treeff23e64de5a558b575ed812349d8af6e64d8ceb4 /module/language/scheme/compile-ghil.scm
parent49c9839eae84f7f3cd10db45f389fa1ea1050659 (diff)
parente33a910dd0f430f34c32fe6846899aee33fc2cf6 (diff)
downloadguile-fbb857a472eb4e69c1cba05e86646b7004f32df6.tar.gz
Merge branch 'master' into boehm-demers-weiser-gc
Conflicts: lib/Makefile.am libguile/Makefile.am libguile/frames.c libguile/gc-card.c libguile/gc-freelist.c libguile/gc-mark.c libguile/gc-segment.c libguile/gc_os_dep.c libguile/load.c libguile/macros.c libguile/objcodes.c libguile/programs.c libguile/strings.c libguile/vm.c m4/gnulib-cache.m4 m4/gnulib-comp.m4 m4/inline.m4
Diffstat (limited to 'module/language/scheme/compile-ghil.scm')
-rw-r--r--module/language/scheme/compile-ghil.scm102
1 files changed, 43 insertions, 59 deletions
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
index 587a173fe..dc03af6cf 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2001 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -27,16 +26,15 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
+ #:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
-
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
-;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS)
(define (cenv-module env)
(cond ((not env) #f)
((module? env) env)
@@ -47,7 +45,9 @@
(cond ((not env) (make-ghil-toplevel-env))
((module? env) (make-ghil-toplevel-env))
((pair? env)
- (ghil-env-dereify (cadr env)))
+ (if (struct? (cadr env))
+ (cadr env)
+ (ghil-env-dereify (cadr env))))
(else (error "bad environment" env))))
(define (cenv-externals env)
@@ -56,6 +56,8 @@
((pair? env) (cddr env))
(else (error "bad environment" env))))
+(define (make-cenv module lexicals externals)
+ (cons module (cons lexicals externals)))
@@ -65,11 +67,14 @@
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
- (values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))
- (and e
- (cons* (cenv-module e)
- (ghil-env-parent env)
- (cenv-externals e)))))))))
+ (let ((x (tree-il->scheme
+ (sc-expand x 'c '(compile load eval)))))
+ (let ((x (make-ghil-lambda env #f vars #f '()
+ (translate-1 env #f x)))
+ (cenv (make-cenv (current-module)
+ (ghil-env-parent env)
+ (if e (cenv-externals e) '()))))
+ (values x cenv cenv))))))))
;;;
@@ -88,37 +93,26 @@
;;
;; FIXME shadowing lexicals?
(define (lookup-transformer head retrans)
+ (define (module-ref/safe mod sym)
+ (and mod
+ (and=> (module-variable mod sym)
+ (lambda (var)
+ ;; unbound vars can happen if the module
+ ;; definition forward-declared them
+ (and (variable-bound? var) (variable-ref var))))))
(let* ((mod (current-module))
(val (cond
- ((symbol? head)
- (and=> (module-variable mod head)
- (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var)))))
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((macro? head) head)
+ ((symbol? head) (module-ref/safe mod head))
+ ((pmatch head
+ ((@ ,modname ,sym)
+ (module-ref/safe (resolve-interface modname) sym))
+ ((@@ ,modname ,sym)
+ (module-ref/safe (resolve-module modname) sym))
+ (else #f)))
(else #f))))
(cond
((hashq-ref *translate-table* val))
- ((defmacro? val)
- (lambda (env loc exp)
- (retrans (apply (defmacro-transformer val) (cdr exp)))))
-
- ((eq? val sc-macro)
- ;; syncase!
- (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
- (sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (lambda (env loc exp)
- (retrans
- (with-fluids ((eec (module-eval-closure mod)))
- (sc-expand3 exp 'c '(compile load eval)))))))
-
- ((primitive-macro? val)
- (syntax-error #f "unhandled primitive macro" head))
-
((macro? val)
(syntax-error #f "unknown kind of macro" head))
@@ -167,7 +161,7 @@
(define-macro (define-scheme-translator sym . clauses)
`(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
- ,sym
+ (module-ref (current-module) ',sym)
(lambda (e l exp)
(define (retrans x)
((@ (language scheme compile-ghil) translate-1)
@@ -419,16 +413,6 @@
(,args
(-> (values (map retrans args)))))
-(define-scheme-translator compile-time-environment
- ;; (compile-time-environment)
- ;; => (MODULE LEXICALS . EXTERNALS)
- (()
- (-> (inline 'cons
- (list (retrans '(current-module))
- (-> (inline 'cons
- (list (-> (reified-env))
- (-> (inline 'externals '()))))))))))
-
(define (lookup-apply-transformer proc)
(cond ((eq? proc values)
(lambda (e l args)