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
(export EXPORT ...)
+(unexport EXPORT ...)
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)