summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/scheme/translate.scm2
-rw-r--r--module/system/base/syntax.scm7
-rw-r--r--module/system/il/ghil.scm28
3 files changed, 30 insertions, 7 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 05a2e8a98..f26b37d84 100644
--- 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 488ff3b56..ffdac8414 100644
--- 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 0def60ad0..7bfeb1580 100644
--- 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))