replace sc-expand with sc-expand3, removing binding for sc-expand3

[bpt/guile.git] / module / language / scheme / compile-ghil.scm

diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
index 587a173..5ff16b9 100644 (file)
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -27,16 +27,16 @@
   #: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 ((system base compile) #:select (syntax-error))
   #:export (compile-ghil translate-1
             *translate-table* define-scheme-translator))
 
+(module-ref (current-module) 'receive)
 
 ;;; 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 +47,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 +58,8 @@
         ((pair? env) (cddr env))
         (else (error "bad environment" env))))
 
+(define (make-cenv module lexicals externals)
+  (cons module (cons lexicals externals)))
 
 \f
 
@@ -65,11 +69,13 @@
      (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 (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))))))))
 
 \f
 ;;;
@@ -88,37 +94,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 +162,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)