>From 868ed4234c46d8588f39b8278d1844f30d8b535b Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Sun, 19 Oct 2014 15:39:37 +1300 Subject: [PATCH] Dealias module names in saved module import forms When import and meta-import forms are saved during module expansion, they need to respect module aliasing; otherwise, import libraries may refer to libraries by names that are no longer accessible. In particular, functors alias their arguments during instantiation, and the resulting module's import library must refer to these by alias target. Fixes #1149. Thanks to Juergen Lorenz for reporting this bug. --- modules.scm | 54 +++++++++++++++++++++++++++------------------------- tests/runtests.bat | 5 +++++ tests/runtests.sh | 3 +++ 3 files changed, 36 insertions(+), 26 deletions(-) diff --git a/modules.scm b/modules.scm index f5278c2..7afb516 100644 --- a/modules.scm +++ b/modules.scm @@ -596,7 +596,7 @@ (vexp (module-vexports mod)) (sexp (module-sexports mod)) (iexp (module-iexports mod))) - (values vexp sexp iexp))) + (values (module-name mod) vexp sexp iexp))) (define (import-spec spec) (cond ((symbol? spec) (import-name spec)) ((or (not (list? spec)) (< (length spec) 2)) @@ -606,13 +606,15 @@ (##sys#intern-symbol (##sys#string-append "srfi-" (##sys#number->string (cadr spec)))))) (else - (let ((s (car spec))) - (let-values (((impv imps impi) (import-spec (cadr spec)))) - (cond ((c %only s) + (let ((head (car spec)) + (imports (cddr spec))) + (let-values (((form impv imps impi) (import-spec (cadr spec)))) + (cond ((c %only head) (##sys#check-syntax loc spec '(_ _ . #(symbol 0))) - (let ((ids (map resolve (cddr spec)))) + (let ((ids (map resolve imports))) (let loop ((ids ids) (v '()) (s '())) - (cond ((null? ids) (values v s impi)) + (cond ((null? ids) + (values `(,head ,form ,@imports) v s impi)) ((assq (car ids) impv) => (lambda (a) (loop (cdr ids) (cons a v) s))) @@ -620,27 +622,28 @@ (lambda (a) (loop (cdr ids) v (cons a s)))) (else (loop (cdr ids) v s)))))) - ((c %except s) + ((c %except head) (##sys#check-syntax loc spec '(_ _ . #(symbol 0))) - (let ((ids (map resolve (cddr spec)))) + (let ((ids (map resolve imports))) (let loop ((impv impv) (v '())) (cond ((null? impv) (let loop ((imps imps) (s '())) - (cond ((null? imps) (values v s impi)) + (cond ((null? imps) + (values `(,head ,form ,@imports) v s impi)) ((memq (caar imps) ids) (loop (cdr imps) s)) (else (loop (cdr imps) (cons (car imps) s)))))) ((memq (caar impv) ids) (loop (cdr impv) v)) (else (loop (cdr impv) (cons (car impv) v))))))) - ((c %rename s) + ((c %rename head) (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0))) - (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec))) + (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids imports)) (cond ((null? impv) (cond ((null? imps) (for-each (lambda (id) (##sys#warn "renamed identifier not imported" id) ) ids) - (values v s impi)) + (values `(,head ,form ,@imports) v s impi)) ((assq (caar imps) ids) => (lambda (a) (loop impv (cdr imps) @@ -657,30 +660,29 @@ (else (loop (cdr impv) imps (cons (car impv) v) s ids))))) - ((c %prefix s) + ((c %prefix head) (##sys#check-syntax loc spec '(_ _ _)) - (let ((pref (tostr (caddr spec)))) + (let ((pref (caddr spec))) (define (ren imp) (cons (##sys#string->symbol - (##sys#string-append pref (##sys#symbol->string (car imp))) ) + (##sys#string-append (tostr pref) (##sys#symbol->string (car imp)))) (cdr imp) ) ) - (values (map ren impv) (map ren imps) impi))) + (values (list head form pref) (map ren impv) (map ren imps) impi))) (else (##sys#syntax-error-hook loc "invalid import specification" spec)))))))) (##sys#check-syntax loc x '(_ . #(_ 1))) (let ((cm (##sys#current-module))) - (when cm - ;; save import form - (if meta? - (set-module-meta-import-forms! - cm - (append (module-meta-import-forms cm) (cdr x))) - (set-module-import-forms! - cm - (append (module-import-forms cm) (cdr x))))) (for-each (lambda (spec) - (let-values (((vsv vss vsi) (import-spec spec))) + (let-values (((form vsv vss vsi) (import-spec spec))) + (when cm ; save import form + (if meta? + (set-module-meta-import-forms! + cm + (append (module-meta-import-forms cm) (list form))) + (set-module-import-forms! + cm + (append (module-import-forms cm) (list form))))) (dd `(IMPORT: ,loc)) (dd `(V: ,(if cm (module-name cm) ') ,(map-se vsv))) (dd `(S: ,(if cm (module-name cm) ') ,(map-se vss))) diff --git a/tests/runtests.bat b/tests/runtests.bat index b037cb7..942e234 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -249,6 +249,11 @@ if errorlevel 1 exit /b 1 if errorlevel 1 exit /b 1 a.out if errorlevel 1 exit /b 1 +%compile% -s use-square-functor.scm -J +if errorlevel 1 exit /b 1 +%interpret% -nqe "(import sf1)" -e "(import sf2)" +if errorlevel 1 exit /b 1 +del /f /q sf1.import.* sf2.import.* lst.import.* mod.import.* echo ======================================== compiler syntax tests ... %compile% compiler-syntax-tests.scm diff --git a/tests/runtests.sh b/tests/runtests.sh index 5b6f83c..ba4449e 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -223,6 +223,9 @@ $compile -s square-functor.import.scm $interpret -bnq use-square-functor.scm $compile use-square-functor.scm ./a.out +$compile -s use-square-functor.scm -J +$interpret -nqe '(import sf1)' -e '(import sf2)' +rm -f sf1.import.* sf2.import.* lst.import.* mod.import.* echo "======================================== compiler syntax tests ..." $compile compiler-syntax-tests.scm -- 1.7.10.4