diff options
-rw-r--r-- | module/language/scheme/translate.scm | 2 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 7 | ||||
-rw-r--r-- | module/system/il/ghil.scm | 28 |
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)) |