[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] fix reexports (somewhat)
|
From: |
Felix |
|
Subject: |
[Chicken-hackers] [PATCH] fix reexports (somewhat) |
|
Date: |
Thu, 23 Aug 2012 21:59:13 +0200 (CEST) |
This patch fixes the bugs #900 and #901 (both reported by megane):
* When reexporting syntax in a module with "*" export list, the syntax
must be added to the modules' "exist" list, so that it can be retrieved
on import.
* When reexporting, indirect exports (of the form "(<syntax> <name> ...)")
must be copied from the module that is reexported into the module that
reexports, to make them available in the importing module (reexported
syntactic bindings may refer to indirect exports, but these do not exist
in the wrapper, the module that does the reexport. Yes, this is quite
confusing).
Test cases have been added. Note that rexport with renaming is known to
be broken and likely not to work.
cheers,
felix
>From cbed441e652ddd489699e45a74abeafe5111f5e6 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Thu, 23 Aug 2012 21:47:35 +0200
Subject: [PATCH] Fix problems with `reexport'.
This patch fixes the bugs #900 and #901 (both reported by megane):
* When reexporting syntax in a module with "*" export list, the syntax
must be added to the modules' "exist" list, so that it can be retrieved
on import.
* When reexporting, indirect exports (of the form "(<syntax> <name> ...)")
must be copied from the module that is reexported into the module that
reexports, to make them available in the importing module (reexported
syntactic bindings may refer to indirect exports, but these do not exist
in the wrapper, the module that does the reexport. Yes, this is quite
confusing).
Test cases have been added.
---
distribution/manifest | 3 +
modules.scm | 256 ++++++++++++++++++++++---------------------
tests/reexport-m1.scm | 2 +
tests/reexport-m2.scm | 2 +
tests/reexport-m3.scm | 9 ++
tests/reexport-m4.scm | 10 ++
tests/reexport-tests-2.scm | 2 +
tests/reexport-tests.scm | 20 ++++
tests/runtests.sh | 4 +
9 files changed, 183 insertions(+), 125 deletions(-)
create mode 100644 tests/reexport-m3.scm
create mode 100644 tests/reexport-m4.scm
create mode 100644 tests/reexport-tests-2.scm
diff --git a/distribution/manifest b/distribution/manifest
index 4be115b..9f63422 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -154,7 +154,10 @@ tests/syntax-tests-2.scm
tests/meta-syntax-test.scm
tests/reexport-m1.scm
tests/reexport-m2.scm
+tests/reexport-m3.scm
+tests/reexport-m4.scm
tests/reexport-tests.scm
+tests/reexport-tests-2.scm
tests/ec.scm
tests/ec-tests.scm
tests/test-chained-modules.scm
diff --git a/modules.scm b/modules.scm
index 078da0d..b1571c2 100644
--- a/modules.scm
+++ b/modules.scm
@@ -83,12 +83,13 @@
module-exist-list set-module-exist-list!
module-meta-expressions set-module-meta-expressions!
module-defined-syntax-list set-module-defined-syntax-list!
- module-saved-environments set-module-saved-environments!))
+ module-saved-environments set-module-saved-environments!
+ module-iexports set-module-iexports!))
(define-record-type module
(%make-module name export-list defined-list exist-list defined-syntax-list
undefined-list import-forms meta-import-forms meta-expressions
- vexports sexports saved-environments)
+ vexports sexports iexports saved-environments)
module?
(name module-name) ; SYMBOL
(export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL
...) ...)
@@ -101,6 +102,7 @@
(meta-expressions module-meta-expressions set-module-meta-expressions!) ;
(EXP ...)
(vexports module-vexports set-module-vexports!) ; ((SYMBOL .
SYMBOL) ...)
(sexports module-sexports set-module-sexports!) ; ((SYMBOL SE
TRANSFORMER) ...)
+ (iexports module-iexports set-module-iexports!) ; ((SYMBOL .
SYMBOL) ...)
;; for csi's ",m" command, holds (<env> . <macroenv>)
(saved-environments module-saved-environments
set-module-saved-environments!))
@@ -112,8 +114,8 @@
(module-vexports m)
(module-sexports m)))
-(define (make-module name explist vexports sexports)
- (%make-module name explist '() '() '() '() '() '() '() vexports sexports #f))
+(define (make-module name explist vexports sexports iexports)
+ (%make-module name explist '() '() '() '() '() '() '() vexports sexports
iexports #f))
(define (##sys#register-module-alias alias name)
(##sys#module-alias-environment
@@ -170,8 +172,7 @@
exps)
(set-module-sexports! mod (append sexps (module-sexports mod)))
(set-module-exist-list! mod (append el exps)))
- (set-module-export-list!
- mod (append xl exps)))))
+ (set-module-export-list! mod (append xl exps)))))
(define (##sys#toplevel-definition-hook sym mod exp val) #f)
@@ -236,7 +237,7 @@
(cons (cons sym (if where (list where) '())) ul)))))))
(define (##sys#register-module name explist #!optional (vexports '())
(sexports '()))
- (let ((mod (make-module name explist vexports sexports)))
+ (let ((mod (make-module name explist vexports sexports '())))
(set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
mod) )
@@ -318,7 +319,7 @@
(if (symbol? (cdr ie))
`'(,(car ie) . ,(cdr ie))
`(list ',(car ie) '() ,(cdr ie))))
- (module-indirect-exports mod)))
+ (module-iexports mod)))
',(module-vexports mod)
(list
,@(map (lambda (sexport)
@@ -366,7 +367,7 @@
(map (lambda (ne)
(list (car ne) #f (##sys#ensure-transformer (cdr ne) (car
ne))))
sdefs))
- (mod (make-module name '() vexports sexps))
+ (mod (make-module name '() vexports sexps iexps))
(senv (merge-se
(##sys#macro-environment)
(##sys#current-environment)
@@ -411,7 +412,8 @@
"unknown syntax referenced while registering
module"
se name))
se))
- sexports))))
+ sexports)
+ '())))
(set-module-saved-environments!
mod
(cons (merge-se (##sys#current-environment)
@@ -540,6 +542,9 @@
(SEXPORTS: ,@(map-se sexports))))
(set-module-vexports! mod vexports)
(set-module-sexports! mod sexports)
+ (set-module-iexports!
+ mod
+ (merge-se (module-iexports mod) iexports)) ; "reexport" may already
have added some
(set-module-saved-environments!
mod
(cons (merge-se (##sys#current-environment) vexports sexports)
@@ -589,8 +594,9 @@
(define (import-name spec)
(let* ((mod (##sys#find-module/import-library (##sys#strip-syntax spec)
'import))
(vexp (module-vexports mod))
- (sexp (module-sexports mod)))
- (cons vexp sexp)))
+ (sexp (module-sexports mod))
+ (iexp (module-iexports mod)))
+ (values vexp sexp iexp)))
(define (import-spec spec)
(cond ((symbol? spec) (import-name spec))
((or (not (list? spec)) (< (length spec) 2))
@@ -600,69 +606,67 @@
(##sys#intern-symbol
(##sys#string-append "srfi-" (##sys#number->string (cadr
spec))))))
(else
- (let* ((s (car spec))
- (imp (import-spec (cadr spec)))
- (impv (car imp))
- (imps (cdr imp)))
- (cond ((c %only s)
- (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let ((ids (map resolve (cddr spec))))
- (let loop ((ids ids) (v '()) (s '()))
- (cond ((null? ids) (cons v s))
- ((assq (car ids) impv) =>
- (lambda (a)
- (loop (cdr ids) (cons a v) s)))
- ((assq (car ids) imps) =>
- (lambda (a)
- (loop (cdr ids) v (cons a s))))
- (else (loop (cdr ids) v s))))))
- ((c %except s)
- (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let ((ids (map resolve (cddr spec))))
- (let loop ((impv impv) (v '()))
- (cond ((null? impv)
- (let loop ((imps imps) (s '()))
- (cond ((null? imps) (cons v s))
- ((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)
- (##sys#check-syntax loc spec '(_ _ . #((symbol symbol)
0)))
- (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids
(cddr spec)))
- (cond ((null? impv)
- (cond ((null? imps)
- (for-each
- (lambda (id)
- (##sys#warn "renamed identifier not
imported" id) )
- ids)
- (cons v s))
- ((assq (caar imps) ids) =>
- (lambda (a)
- (loop impv (cdr imps)
- v
- (cons (cons (cadr a) (cdar imps))
s)
- (##sys#delq a ids))))
- (else (loop impv (cdr imps) v (cons (car
imps) s) ids))))
- ((assq (caar impv) ids) =>
- (lambda (a)
- (loop (cdr impv) imps
- (cons (cons (cadr a) (cdar impv)) v)
- s
- (##sys#delq a ids))))
- (else (loop (cdr impv) imps
- (cons (car impv) v)
- s ids)))))
- ((c %prefix s)
- (##sys#check-syntax loc spec '(_ _ _))
- (let ((pref (tostr (caddr spec))))
- (define (ren imp)
- (cons
- (##sys#string->symbol
- (##sys#string-append pref (##sys#symbol->string
(car imp))) )
- (cdr imp) ) )
- (cons (map ren impv) (map ren imps))))
- (else (##sys#syntax-error-hook loc "invalid import
specification" spec)))))))
+ (let ((s (car spec)))
+ (let-values (((impv imps impi) (import-spec (cadr spec))))
+ (cond ((c %only s)
+ (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
+ (let ((ids (map resolve (cddr spec))))
+ (let loop ((ids ids) (v '()) (s '()))
+ (cond ((null? ids) (values v s impi))
+ ((assq (car ids) impv) =>
+ (lambda (a)
+ (loop (cdr ids) (cons a v) s)))
+ ((assq (car ids) imps) =>
+ (lambda (a)
+ (loop (cdr ids) v (cons a s))))
+ (else (loop (cdr ids) v s))))))
+ ((c %except s)
+ (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
+ (let ((ids (map resolve (cddr spec))))
+ (let loop ((impv impv) (v '()))
+ (cond ((null? impv)
+ (let loop ((imps imps) (s '()))
+ (cond ((null? imps) (values 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)
+ (##sys#check-syntax loc spec '(_ _ . #((symbol symbol)
0)))
+ (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids
(cddr spec)))
+ (cond ((null? impv)
+ (cond ((null? imps)
+ (for-each
+ (lambda (id)
+ (##sys#warn "renamed identifier not
imported" id) )
+ ids)
+ (values v s impi))
+ ((assq (caar imps) ids) =>
+ (lambda (a)
+ (loop impv (cdr imps)
+ v
+ (cons (cons (cadr a) (cdar
imps)) s)
+ (##sys#delq a ids))))
+ (else (loop impv (cdr imps) v (cons (car
imps) s) ids))))
+ ((assq (caar impv) ids) =>
+ (lambda (a)
+ (loop (cdr impv) imps
+ (cons (cons (cadr a) (cdar impv)) v)
+ s
+ (##sys#delq a ids))))
+ (else (loop (cdr impv) imps
+ (cons (car impv) v)
+ s ids)))))
+ ((c %prefix s)
+ (##sys#check-syntax loc spec '(_ _ _))
+ (let ((pref (tostr (caddr spec))))
+ (define (ren imp)
+ (cons
+ (##sys#string->symbol
+ (##sys#string-append pref (##sys#symbol->string
(car imp))) )
+ (cdr imp) ) )
+ (values (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
@@ -676,58 +680,60 @@
(append (module-import-forms cm) (cdr x)))))
(for-each
(lambda (spec)
- (let* ((vs (import-spec spec))
- (vsv (car vs))
- (vss (cdr vs))
- (prims '()))
- (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)))
- (##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
- (for-each
- (lambda (imp)
- (let* ((id (car imp))
- (aid (cdr imp))
- (prim (getp aid '##core#primitive)))
- (when prim
- (set! prims (cons imp prims)))
- (and-let* ((a (assq id (import-env)))
- ((not (eq? aid (cdr a)))))
- (##sys#notice "re-importing already imported identifier"
id))))
- vsv)
- (for-each
- (lambda (imp)
- (and-let* ((a (assq (car imp) (macro-env)))
- ((not (eq? (cdr imp) (cdr a)))))
- (##sys#notice "re-importing already imported syntax" (car
imp))) )
- vss)
- (when reexp?
- (unless cm
- (##sys#syntax-error-hook loc "`reexport' only valid inside a
module"))
-
- (if (eq? #t (module-export-list cm))
- (begin
- (set-module-exist-list!
- cm
- (append (module-exist-list cm)
- (map car vsv)
- (map car vss))))
- (set-module-export-list!
+ (let-values (((vsv vss vsi) (import-spec spec)))
+ (let ((prims '()))
+ (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)))
+ (##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
+ (for-each
+ (lambda (imp)
+ (let* ((id (car imp))
+ (aid (cdr imp))
+ (prim (getp aid '##core#primitive)))
+ (when prim
+ (set! prims (cons imp prims)))
+ (and-let* ((a (assq id (import-env)))
+ ((not (eq? aid (cdr a)))))
+ (##sys#notice "re-importing already imported identifier"
id))))
+ vsv)
+ (for-each
+ (lambda (imp)
+ (and-let* ((a (assq (car imp) (macro-env)))
+ ((not (eq? (cdr imp) (cdr a)))))
+ (##sys#notice "re-importing already imported syntax" (car
imp))) )
+ vss)
+ (when reexp?
+ (unless cm
+ (##sys#syntax-error-hook loc "`reexport' only valid inside a
module"))
+ (let ((el (module-export-list cm)))
+ (cond ((eq? #t el)
+ (set-module-sexports! cm (append vss (module-sexports
cm)))
+ (set-module-exist-list!
+ cm
+ (append (module-exist-list cm)
+ (map car vsv)
+ (map car vss))))
+ (else
+ (set-module-export-list!
+ cm
+ (append
+ (let ((xl (module-export-list cm)))
+ (if (eq? #t xl) '() xl))
+ (map car vsv)
+ (map car vss))))))
+ (set-module-iexports!
+ cm
+ (merge-se (module-iexports cm) vsi))
+ (when (pair? prims)
+ (set-module-meta-expressions!
cm
(append
- (let ((xl (module-export-list cm) ))
- (if (eq? #t xl) '() xl))
- (map car vsv)
- (map car vss))))
- (when (pair? prims)
- (set-module-meta-expressions!
- cm
- (append
- (module-meta-expressions cm)
- `((##sys#mark-primitive ',prims)))))
- (dm "export-list: " (module-export-list cm)))
- (import-env (append vsv (import-env)))
- (macro-env (append vss (macro-env)))))
+ (module-meta-expressions cm)
+ `((##sys#mark-primitive ',prims)))))
+ (dm "export-list: " (module-export-list cm)))
+ (import-env (append vsv (import-env)))
+ (macro-env (append vss (macro-env))))))
(cdr x))
'(##core#undefined))))
diff --git a/tests/reexport-m1.scm b/tests/reexport-m1.scm
index e08ddb5..96ac9bc 100644
--- a/tests/reexport-m1.scm
+++ b/tests/reexport-m1.scm
@@ -1,3 +1,5 @@
+;;;; module re-exporting from core module
+
(module reexport-m1 ()
(import scheme chicken)
(require-library srfi-1 srfi-13)
diff --git a/tests/reexport-m2.scm b/tests/reexport-m2.scm
index ec955f3..daee95f 100644
--- a/tests/reexport-m2.scm
+++ b/tests/reexport-m2.scm
@@ -1,3 +1,5 @@
+;;;; module importing from module that reexports core binding
+
(module foo ()
(import scheme chicken)
(use reexport-m1)
diff --git a/tests/reexport-m3.scm b/tests/reexport-m3.scm
new file mode 100644
index 0000000..202e6b3
--- /dev/null
+++ b/tests/reexport-m3.scm
@@ -0,0 +1,9 @@
+(module
+ reexport-m3
+ ((foo bar))
+ (import chicken scheme)
+ (define (bar) 1)
+ (define-syntax foo
+ (ir-macro-transformer
+ (lambda (e i c)
+ `(bar)))))
diff --git a/tests/reexport-m4.scm b/tests/reexport-m4.scm
new file mode 100644
index 0000000..c81287b
--- /dev/null
+++ b/tests/reexport-m4.scm
@@ -0,0 +1,10 @@
+(module
+ reexport-m4
+ (baz)
+ (import chicken scheme)
+ (use reexport-m3)
+ (reexport reexport-m3)
+ (define-syntax baz
+ (ir-macro-transformer
+ (lambda (e i c)
+ `(foo)))))
diff --git a/tests/reexport-tests-2.scm b/tests/reexport-tests-2.scm
new file mode 100644
index 0000000..35ef76d
--- /dev/null
+++ b/tests/reexport-tests-2.scm
@@ -0,0 +1,2 @@
+(use reexport-m4)
+(print (baz))
diff --git a/tests/reexport-tests.scm b/tests/reexport-tests.scm
index 892ad64..651ed47 100644
--- a/tests/reexport-tests.scm
+++ b/tests/reexport-tests.scm
@@ -36,3 +36,23 @@
(module m3 ()
(import scheme big-chicken)
(pp (string-intersperse '("abc" "def" "ghi") "-")))
+
+;;; #901 - reexport with "*" export list
+
+(module
+ m4
+ (foo-m4)
+ (import chicken scheme)
+ (define-syntax foo-m4
+ (ir-macro-transformer
+ (lambda (e i c)
+ ''1))))
+
+(module
+ m5
+ * ; () works here
+ (import chicken scheme)
+ (reexport m4))
+
+(import m5)
+(print (foo-m4))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 469ccd4..5b6113e 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -196,6 +196,10 @@ $compile_s reexport-m1.import.scm
$interpret -s reexport-m2.scm
$compile reexport-m2.scm
./a.out
+$compile_s reexport-m3.scm -J
+$compile_s reexport-m4.scm -J
+$compile reexport-tests-2.scm
+./a.out
echo "======================================== functor tests ..."
$interpret -bnq simple-functors-test.scm
--
1.6.0.4
- [Chicken-hackers] [PATCH] fix reexports (somewhat),
Felix <=