~ chicken-core (chicken-5) 4e3d990030e490bb8fb489e731b2f9c5e23eaded
commit 4e3d990030e490bb8fb489e731b2f9c5e23eaded
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Oct 19 15:39:37 2014 +1300
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Oct 19 15:27:31 2014 +0200
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.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/NEWS b/NEWS
index 00b14751..6fa2a4b1 100644
--- a/NEWS
+++ b/NEWS
@@ -45,6 +45,8 @@
- Allow functor arguments to be optional, with default implementations.
- Fixed a bug that prevented functors from being instantiated with
built-in modules.
+ - Fixed generation of import libraries for instantiated functors
+ (#1149, thanks to Juergen Lorenz).
- Syntax expander
- define-values, set!-values and letrec-values now support full lambda
diff --git a/modules.scm b/modules.scm
index f5278c20..7afb5167 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) '<toplevel>) ,(map-se vsv)))
(dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index b037cb72..942e234b 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 5b6f83c0..ba4449eb 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
Trap