fix else in cond, letrec env corruption, syntax.scm compile, define-module side effects

* module/language/scheme/translate.scm (primitive-syntax-table):
  Translate the `else' clause of a cond as (begin ...). We used to use
  trans-body, which processes internal defines, which are not legal
  syntax here.

* module/system/base/syntax.scm (define-record): Unfortunately, we can't
  unquote in the actual procedure for `%compute-initargs', because that
  doesn't work with compilation. So reference %compute-initargs by name,
  and export it.

* module/system/il/ghil.scm (apopq!): Gaaaaar. The order of the arguments
  to assq-remove! was reversed, which was the badness, causing corruption
  to the env after calling call-with-ghil-bindings. Grrrrrr.

  (fix-ghil-mod!, ghil-lookup, ghil-define): As amply commented in the
  code, deal with compile-time side effects to the current module by
  lazily noticing and patching up the compile-time environment. A hacky
  solution until such a time as we special-case something for
  `define-module'.

diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 05a2e8a..f26b37d 100644 (file)
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -203,7 +203,7 @@
    (cond
     ;; (cond (CLAUSE BODY...) ...)
     (() (retrans '(begin)))
-    (((else . ,body)) (trans-body e l body))
+    (((else . ,body)) (retrans `(begin ,@body)))
     (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
     (((,test => ,proc) . ,rest)
      ;; FIXME hygiene!

diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 488ff3b..ffdac84 100644 (file)
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -20,6 +20,7 @@
 ;;; Code:
 
 (define-module (system base syntax)
+  :export (%compute-initargs)
   :export-syntax (define-type define-record record-case))
 (export-syntax |) ;; emacs doesn't like the |
 
@@ -57,10 +58,10 @@
                                      (if (pair? slot)
                                          `(cons ',(car slot) ,(cadr slot))
                                          `',slot))
-                                   slots))))
+                                   slots)))
+               (constructor (record-constructor ,name)))
            (lambda args
-             (apply ,(record-constructor type)
-                    (,%compute-initargs args slots)))))
+             (apply constructor (%compute-initargs args slots)))))
        (define ,(symbol-append stem '?) ,(record-predicate type))
        ,@(map (lambda (sname)
                 `(define ,(symbol-append stem '- sname)

diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 0def60a..7bfeb15 100644 (file)
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -171,7 +171,7 @@
 (define-macro (apush! k v loc)
   `(set! ,loc (acons ,k ,v ,loc)))
 (define-macro (apopq! k loc)
-  `(set! ,loc (assq-remove! ,k ,loc)))
+  `(set! ,loc (assq-remove! ,loc ,k)))
 
 (define (ghil-env-add! env var)
   (apush! (ghil-var-name var) var (ghil-env-table env))
@@ -190,19 +190,39 @@
     (and iface
          (make-ghil-env (make-ghil-mod iface)))))
 
+(define (fix-ghil-mod! mod for-sym)
+  (warn "during lookup of" for-sym ":" (ghil-mod-module mod) "!= current" (current-module))
+  (if (not (null? (ghil-mod-table mod)))
+      (warn "throwing away old variable table" (ghil-mod-table mod)))
+  (set! (ghil-mod-module mod) (current-module))
+  (set! (ghil-mod-table mod) '())
+  (set! (ghil-mod-imports mod) '()))
+
 ;; looking up a var has side effects?
 (define (ghil-lookup env sym)
   (or (ghil-env-ref env sym)
       (let loop ((e (ghil-env-parent env)))
         (record-case e
           ((<ghil-mod> module table imports)
-           (cond ((assq-ref table sym))
+           (cond ((not (eq? module (current-module)))
+                  ;; FIXME: the primitive-eval in eval-case and/or macro
+                  ;; expansion can have side effects on the compilation
+                  ;; environment, for example changing the current
+                  ;; module. We probably need to add a special case in
+                  ;; compilation to handle define-module.
+                  (fix-ghil-mod! e sym)
+                  (loop e))
+                 ((assq-ref table sym)) ;; when does this hit?
                  ((module-lookup module sym)
                   => (lambda (found-env)
                        (make-ghil-var found-env sym 'module)))
                  (else
                   ;; a free variable that we have not resolved
-                  (warn "unresolved variable during compilation:" sym)
+                  (if (not (module-locally-bound? module sym))
+                      ;; For the benefit of repl compilation, that
+                      ;; doesn't compile modules all-at-once, don't warn
+                      ;; if we find the symbol locally.
+                      (warn "unresolved variable during compilation:" sym))
                   (make-ghil-var #f sym 'module))))
           ((<ghil-env> mod parent table variables)
            (let ((found (assq-ref table sym)))
@@ -211,6 +231,8 @@
                  (loop parent))))))))
 
 (define (ghil-define mod sym)
+  (if (not (eq? (ghil-mod-module mod) (current-module)))
+      (fix-ghil-mod! mod sym))
   (or (assq-ref (ghil-mod-table mod) sym)
       (let ((var (make-ghil-var (make-ghil-env mod) sym 'module)))
         (apush! sym var (ghil-mod-table mod))