Hi!
This patch adds a counterpart for the export syntax form.
The implementation is pretty straightforward. A new slot, called
module-unexport-list, is added to the module record. Unexport adds
identifiers to this list if the module export list is *. In
##sys#finalize-module all identifiers about to be added to syntax-exports or
variable-exports are dropped if they are found in module-unexport-list.
Export form also drops identifiers from the unexport list.
If the module export list is not *, module-unexport-list is not used. In
this case, it's enough to just remove the identifier to be unexported
from the module-export-list.
I tried implement this without a new module record slot at first but
failed. And even if that was possible the logic for unexports and
exports would be quite convoluted.
This patch applies to the 4.12.0 tarball. (I'm unable to compile from
the git currently, it gives errors like posixunix.c:385:43: error:
‘struct tm’ has no member named ‘tm_gmtoff’)
I'm OK if this gets pushed back until 5, but nothing seems to break
obviously in my tests.
diff --git a/expand.scm b/expand.scm
index 8020be3..1268f79 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1527,6 +1527,19 @@
(##sys#add-to-export-list mod exps))
'(##core#undefined)))))
+(##sys#extend-macro-environment
+ 'unexport
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (let ((exps
+ (##sys#validate-exports
+ (##sys#strip-syntax (cdr x))
+ 'unexport))
+ (mod (##sys#current-module)))
+ (when mod
+ (##sys#remove-from-export-list mod exps))
+ '(##core#undefined)))))
;;; syntax-rules
diff --git a/manual/Modules b/manual/Modules
index b4048fc..bd2bb82 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -105,16 +105,19 @@ Syntax expansions may result in module-definitions, but must be
at toplevel.
-==== export
+==== export and unexport
<macro>(export EXPORT ...)</macro>
+<macro>(unexport EXPORT ...)</macro>
Allows augmenting module-exports from inside the module-body.
-{{EXPORT}} is if the same form as an export-specifier in a
-{{module}} export list. An export must precede its first occurrence
-(either use or definition).
+{{EXPORT}} is of the same form as an export-specifier in a {{module}}
+export list.
-If used outside of a module, then this form does nothing.
+An export of an identifier must precede its first occurrence (either
+use or definition).
+
+When used outside of a module these forms do nothing.
==== import
diff --git a/modules.scm b/modules.scm
index 25c9b03..fbcd529 100644
--- a/modules.scm
+++ b/modules.scm
@@ -76,7 +76,8 @@
(hide make-module module? %make-module
module-name module-vexports module-sexports
set-module-vexports! set-module-sexports!
- module-export-list set-module-export-list!
+ module-export-list set-module-export-list!
+ module-unexport-list set-module-unexport-list!
module-defined-list set-module-defined-list!
module-import-forms set-module-import-forms!
module-meta-import-forms set-module-meta-import-forms!
@@ -87,12 +88,13 @@
module-iexports set-module-iexports!))
(define-record-type module
- (%make-module name export-list defined-list exist-list defined-syntax-list
+ (%make-module name export-list unexport-list defined-list exist-list defined-syntax-list
undefined-list import-forms meta-import-forms meta-expressions
vexports sexports iexports saved-environments)
module?
(name module-name) ; SYMBOL
(export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
+ (unexport-list module-unexport-list set-module-unexport-list!) ; #f | (SYMBOL ...)
(defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...) - *exported* value definitions
(exist-list module-exist-list set-module-exist-list!) ; (SYMBOL ...) - only for checking refs to undef'd
(defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
@@ -115,7 +117,9 @@
(module-sexports m)))
(define (make-module name explist vexports sexports iexports)
- (%make-module name explist '() '() '() '() '() '() '() vexports sexports iexports #f))
+ (%make-module name explist
+ (if (eq? #t explist) '() #f)
+ '() '() '() '() '() '() '() vexports sexports iexports #f))
(define (##sys#register-module-alias alias name)
(##sys#module-alias-environment
@@ -158,6 +162,18 @@
(##sys#macro-environment (cdr saved)))
(##sys#current-module mod))))))
+(define (drop-ids lst ids)
+ (let lp ((lst lst)
+ (res '()))
+ (cond
+ ((null? lst)
+ (##sys#fast-reverse res))
+ ((or (and (symbol? (car lst)) (memq (car lst) ids))
+ (and (pair? (car lst)) (memq (caar lst) ids)))
+ (lp (cdr lst) res))
+ (else
+ (lp (cdr lst) (cons (car lst) res))))))
+
(define (##sys#add-to-export-list mod exps)
(let ((xl (module-export-list mod)))
(if (eq? xl #t)
@@ -171,9 +187,16 @@
(set! sexps (cons a sexps))))))
exps)
(set-module-sexports! mod (append sexps (module-sexports mod)))
- (set-module-exist-list! mod (append el exps)))
+ (set-module-exist-list! mod (append el exps))
+ (set-module-unexport-list! mod (drop-ids (module-unexport-list mod) exps)))
(set-module-export-list! mod (append xl exps)))))
+(define (##sys#remove-from-export-list mod unexps)
+ (let ((xl (module-export-list mod)))
+ (if (eq? xl #t)
+ (set-module-unexport-list! mod (append unexps (module-unexport-list mod)))
+ (set-module-export-list! mod (drop-ids xl unexps)))))
+
(define (##sys#toplevel-definition-hook sym mod exp val) #f)
(define (##sys#register-meta-expression exp)
@@ -200,6 +223,8 @@
(set-module-exist-list! mod (cons sym (module-exist-list mod)))
(when exp
(dm "defined: " sym)
+ (when (eq? #t (module-export-list mod))
+ (set-module-unexport-list! mod (drop-ids (module-unexport-list mod) (list sym))))
(set-module-defined-list!
mod
(cons (cons sym #f)
@@ -443,6 +468,7 @@
(write-char write-char))
(lambda (mod)
(let* ((explist (module-export-list mod))
+ (unexplist (module-unexport-list mod))
(name (module-name mod))
(dlist (module-defined-list mod))
(elist (module-exist-list mod))
@@ -451,14 +477,16 @@
(module-defined-syntax-list mod)))
(sexports
(if (eq? #t explist)
- (merge-se (module-sexports mod) sdlist)
- (let loop ((me (##sys#macro-environment)))
- (cond ((null? me) '())
- ((##sys#find-export (caar me) mod #f)
- (cons (car me) (loop (cdr me))))
- (else (loop (cdr me)))))))
+ (drop-ids (merge-se (module-sexports mod) sdlist) unexplist)
+ (let loop ((me (##sys#macro-environment)))
+ (cond ((null? me) '())
+ ((##sys#find-export (caar me) mod #f)
+ (cons (car me) (loop (cdr me))))
+ (else (loop (cdr me)))))))
(vexports
- (let loop ((xl (if (eq? #t explist) elist explist)))
+ (let loop ((xl (if (eq? #t explist)
+ (drop-ids elist unexplist)
+ explist)))
(if (null? xl)
'()
(let* ((h (car xl))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index f61b4ef..7109b64 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -256,6 +256,11 @@ $compile compiler-syntax-tests.scm
echo "======================================== import tests ..."
$interpret -bnq import-tests.scm
+echo "======================================== unexport tests ..."
+$compile -c -unit unexport-tests -J unexport-tests-modules.scm -o unexport-tests-modules.o
+$compile -uses unexport-tests unexport-tests.scm unexport-tests-modules.o
+./a.out
+
echo "======================================== import library tests ..."
rm -f ../foo.import.* foo.import.*
$compile import-library-test1.scm -emit-import-library foo
diff --git a/tests/unexport-tests-modules.scm b/tests/unexport-tests-modules.scm
index e69de29..bc58551 100644
--- a/tests/unexport-tests-modules.scm
+++ b/tests/unexport-tests-modules.scm
@@ -0,0 +1,171 @@
+;; SHOULD NOT export
+(module
+ unexport-m1
+ *
+ (import chicken scheme)
+ (define foo1 999)
+ (unexport foo1)
+ (define-syntax bar1 (lambda _ 999))
+ (unexport bar1)
+ (include "test.scm")
+ (use data-structures)
+ (test-equal foo1 999)
+ (test-equal (bar1) 999))
+
+;; SHOULD export (before def)
+(module
+ unexport-m0
+ *
+ (import chicken scheme)
+ (unexport foo0)
+ (define foo0 999)
+ (unexport bar0)
+ (define-syntax bar0 (lambda _ 999)))
+
+;; SHOULD NOT export
+(module
+ unexport-m2
+ (foo2 bar2)
+ (import chicken scheme)
+ (export foo2)
+ (unexport foo2)
+ (define foo2 999)
+ (export bar2)
+ (unexport bar2)
+ (define-syntax bar2 (lambda _ 999))
+ (include "test.scm")
+ (use data-structures)
+ (test-equal foo2 999)
+ (test-equal (bar2) 999))
+
+;; SHOULD export
+(module
+ unexport-m3
+ (foo3 bar3)
+ (import chicken scheme)
+ (unexport foo3)
+ (export foo3)
+ (define foo3 999)
+ (unexport bar3)
+ (export bar3)
+ (define-syntax bar3 (lambda _ 999)))
+
+;; SHOULD export
+(module
+ unexport-m4
+ *
+ (import chicken scheme)
+ (unexport foo4)
+ (export foo4)
+ (define foo4 999)
+ (unexport bar4)
+ (export bar4)
+ (define-syntax bar4 (lambda _ 999)))
+
+;; Let's pick SHOULD NOT export
+(module
+ unexport-m5
+ ()
+ (import chicken scheme)
+ (export foo5)
+ (unexport foo5)
+ (define foo5 999)
+ (export bar5)
+ (unexport bar5)
+ (define-syntax bar5 (lambda _ 999))
+ (include "test.scm")
+ (use data-structures)
+ (test-equal foo5 999)
+ (test-equal (bar5) 999))
+
+;; SHOULD NOT export
+(module
+ unexport-m6
+ ()
+ (import chicken scheme)
+ (export foo6)
+ (define foo6 999)
+ (unexport foo6)
+ (export bar6)
+ (define-syntax bar6 (lambda _ 999))
+ (unexport bar6)
+ (include "test.scm")
+ (use data-structures)
+ (test-equal foo6 999)
+ (test-equal (bar6) 999))
+
+;; SHOULD NOT export
+(module
+ unexport-m7
+ (foo7 bar7)
+ (import chicken scheme)
+ (unexport foo7)
+ (define foo7 999)
+ (unexport bar7)
+ (define-syntax bar7 (lambda _ 999))
+ (include "test.scm")
+ (use data-structures)
+ (test-equal foo7 999)
+ (test-equal (bar7) 999))
+
+;; SHOULD NOT export
+(module
+ unexport-m8
+ *
+ (import chicken scheme)
+ (define foo8 999)
+ (unexport foo8)
+ (define-syntax bar8 (lambda _ 999))
+ (unexport bar8)
+ (include "test.scm")
+ (use data-structures)
+ (test-equal foo8 999)
+ (test-equal (bar8) 999))
+
+;; SHOULD export
+(module
+ unexport-m9
+ *
+ (import chicken scheme)
+ (define foo9 999)
+ (unexport foo9)
+ (export foo9)
+ (define-syntax bar9 (lambda _ 999))
+ (unexport bar9)
+ (export bar9))
+
+;; SHOULD export
+(module
+ unexport-m10
+ (foo10 bar10)
+ (import chicken scheme)
+ (define foo10 999)
+ (unexport foo10)
+ (export foo10)
+ (define-syntax bar10 (lambda _ 999))
+ (unexport bar10)
+ (export bar10))
+
+;; SHOULD export
+(module
+ unexport-m11
+ ()
+ (import chicken scheme)
+ (export foo11)
+ (define foo11 999)
+ (unexport foo11)
+ (export foo11)
+ (export bar11)
+ (define-syntax bar11 (lambda _ 999))
+ (unexport bar11)
+ (export bar11))
+
+;; SHOULD export
+;; (module
+;; unexport-m12
+;; ()
+;; (import chicken scheme)
+;; (define foo12 999)
+;; (export foo12)
+;; (define-syntax bar12 (lambda _ 999))
+;; (export bar12))
diff --git a/tests/unexport-tests.scm b/tests/unexport-tests.scm
index e69de29..324a634 100644
--- a/tests/unexport-tests.scm
+++ b/tests/unexport-tests.scm
@@ -0,0 +1,57 @@
+(use data-structures)
+(include "test.scm")
+(test-begin)
+
+(import unexport-m0)
+(test-equal foo0 999)
+(test-equal (bar0) 999)
+
+(import unexport-m1)
+(test-error foo1)
+(test-error (bar1))
+
+(import unexport-m2)
+(test-error foo2)
+(test-error (bar2))
+
+(import unexport-m3)
+(test-equal foo3 999)
+(test-equal (bar3) 999)
+
+(import unexport-m4)
+(test-equal foo4 999)
+(test-equal (bar4) 999)
+
+(import unexport-m5)
+(test-error foo5)
+(test-error (bar5))
+
+(import unexport-m6)
+(test-error foo6)
+(test-error (bar6))
+
+(import unexport-m7)
+(test-error foo7)
+(test-error (bar7))
+
+(import unexport-m8)
+(test-error foo8)
+(test-error (bar8))
+
+(import unexport-m9)
+(test-equal foo9 999)
+(test-equal (bar9) 999)
+
+(import unexport-m10)
+(test-equal foo10 999)
+(test-equal (bar10) 999)
+
+(import unexport-m11)
+(test-equal foo11 999)
+(test-equal (bar11) 999)
+
+;; (import unexport-m12)
+;; (test-equal foo12 999)
+;; (test-equal (bar12) 999)
+
+(test-end)
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
