Hi, Here's a version with more extensive test suite. Tested to work with master.
>From f2ed6123151b96604cf6409cb3f169a7e93b475b Mon Sep 17 00:00:00 2001 From: megane <megan...@gmail.com> Date: Tue, 11 Dec 2018 09:08:42 +0200 Subject: [PATCH] Add 'unexport form for modules --- expand.scm | 11 +++ manual/Modules | 16 ++-- modules.scm | 50 ++++++++--- tests/runtests.sh | 5 ++ tests/unexport-tests-modules.scm | 184 +++++++++++++++++++++++++++++++++++++++ tests/unexport-tests.scm | 43 +++++++++ 6 files changed, 293 insertions(+), 16 deletions(-) create mode 100644 tests/unexport-tests-modules.scm create mode 100644 tests/unexport-tests.scm diff --git a/expand.scm b/expand.scm index c228735..827d628 100644 --- a/expand.scm +++ b/expand.scm @@ -1117,6 +1117,17 @@ '(##core#undefined))))) (##sys#extend-macro-environment + 'unexport + '() + (##sys#er-transformer + (lambda (x r c) + (let ((unexps (##sys#validate-exports (strip-syntax (cdr x)) 'unexport)) + (mod (##sys#current-module))) + (when mod + (##sys#remove-from-export-list mod unexps)) + '(##core#undefined))))) + +(##sys#extend-macro-environment 'reexport '() (##sys#er-transformer (cut ##sys#expand-import <> <> <> diff --git a/manual/Modules b/manual/Modules index 6622275..9f3e2a9 100644 --- a/manual/Modules +++ b/manual/Modules @@ -110,16 +110,22 @@ 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. An export of an identifier must precede its first +occurrence (either use or definition). -If used outside of a module, then this form does nothing. +With {{UNEXPORT}} form identifiers can be removed from the module's +export list. Note that an {{UNEXPORT}}ed identifier is exported if the +module's export list is {{*}} and the definition of the identifier +succeeds the {{UNEXPORT}} form. + +When used outside of a module these forms do nothing. ==== import diff --git a/modules.scm b/modules.scm index b0cdce5..f56e5fe 100644 --- a/modules.scm +++ b/modules.scm @@ -80,7 +80,8 @@ module-name module-library 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! @@ -91,13 +92,14 @@ module-iexports set-module-iexports!)) (define-record-type module - (%make-module name library export-list defined-list exist-list defined-syntax-list + (%make-module name library 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 (library module-library) ; 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) ...) @@ -120,7 +122,9 @@ (module-sexports m))) (define (make-module name lib explist vexports sexports iexports) - (%make-module name lib explist '() '() '() '() '() '() '() vexports sexports iexports #f)) + (%make-module name lib explist + (if (eq? #t explist) '() #f) + '() '() '() '() '() '() '() vexports sexports iexports #f)) (define (##sys#register-module-alias alias name) (##sys#module-alias-environment @@ -163,6 +167,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) @@ -176,9 +192,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 renamed exported?) #f) (define (##sys#register-meta-expression exp) @@ -204,6 +227,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) @@ -439,6 +464,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)) @@ -447,14 +473,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) '()) - ((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) '()) + ((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 6da7630..36a7af3 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -280,6 +280,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 new file mode 100644 index 0000000..8f68980 --- /dev/null +++ b/tests/unexport-tests-modules.scm @@ -0,0 +1,184 @@ +;; | Export list | Actions | Should export? | Case | +;; |-------------+----------------------------------+---------------------+------------------| +;; | () | def > export | (maybe should?) | unexport-m00-yes | +;; | () | export > def > unexport | No | unexport-m01-no | +;; | () | export > def > unexport > export | Yes | unexport-m02-yes | +;; | () | export > unexport > def | No | unexport-m03-no | +;; | (ids ...) | export > unexport > def | No | unexport-m04-no | +;; | (ids ...) | unexport > export > def | Yes | unexport-m05-yes | +;; | (ids ...) | def > unexport > export | Yes | unexport-m06-yes | +;; | (ids ...) | unexport > def | No | unexport-m07-no | +;; | star | unexport > def | Yes | unexport-m08-yes | +;; | star | def > export > unexport | No | unexport-m09-no | +;; | star | def > unexport | No | unexport-m10-no | +;; | star | def > unexport > export | Yes | unexport-m11-yes | +;; | star | export > unexport > def | Yes | unexport-m12-yes | +;; | star | unexport > export > def | Yes | unexport-m13-yes | +(module + test + * + (import (chicken base) scheme) + (include "test.scm")) + +;; From manual: "An export must precede its first occurrence (either use or definition)." +;; (module +;; unexport-m00-yes +;; () +;; (import (chicken base) (chicken syntax) (chicken module) scheme test) +;; (define foo00 'foo00) +;; (export foo00) +;; (define-syntax bar00 (ir-macro-transformer (lambda _ "bar00"))) +;; (export bar00)) + +(module + unexport-m01-no + () + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (export foo01) + (define foo01 'foo01) + (unexport foo01) + (export bar01) + (define-syntax bar01 (ir-macro-transformer (lambda _ "bar01"))) + (unexport bar01) + (test-equal foo01 'foo01) + (test-equal (bar01) "bar01")) + +(module + unexport-m02-yes + () + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (export foo02) + (define foo02 'foo02) + (unexport foo02) + (export foo02) + (export bar02) + (define-syntax bar02 (ir-macro-transformer (lambda _ "bar02"))) + (unexport bar02) + (export bar02)) + +(module + unexport-m03-no + () + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (export foo03) + (unexport foo03) + (define foo03 'foo03) + (export bar03) + (unexport bar03) + (define-syntax bar03 (ir-macro-transformer (lambda _ "bar03"))) + (test-equal foo03 'foo03) + (test-equal (bar03) "bar03")) + +(module + unexport-m04-no + (foo04 bar04) + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (export foo04) + (unexport foo04) + (define foo04 'foo04) + (export bar04) + (unexport bar04) + (define-syntax bar04 (ir-macro-transformer (lambda _ "bar04"))) + (test-equal foo04 'foo04) + (test-equal (bar04) "bar04")) + +(module + unexport-m05-yes + (foo05 bar05) + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (unexport foo05) + (export foo05) + (define foo05 'foo05) + (unexport bar05) + (export bar05) + (define-syntax bar05 (ir-macro-transformer (lambda _ "bar05")))) + +(module + unexport-m06-yes + (foo06 bar06) + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (define foo06 'foo06) + (unexport foo06) + (export foo06) + (define-syntax bar06 (ir-macro-transformer (lambda _ "bar06"))) + (unexport bar06) + (export bar06)) + +(module + unexport-m07-no + (foo07 bar07) + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (unexport foo07) + (define foo07 'foo07) + (unexport bar07) + (define-syntax bar07 (ir-macro-transformer (lambda _ "bar07"))) + (test-equal foo07 'foo07) + (test-equal (bar07) "bar07")) + +(module + unexport-m08-yes + * + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (unexport foo08) + (define foo08 'foo08) + (unexport bar08) + (define-syntax bar08 (ir-macro-transformer (lambda _ "bar08")))) + +(module + unexport-m09-no + * + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (define foo09 'foo09) + (export foo09) + (unexport foo09) + (define-syntax bar09 (ir-macro-transformer (lambda _ "bar09"))) + (export bar09) + (unexport bar09) + (test-equal foo09 'foo09) + (test-equal (bar09) "bar09")) + +(module + unexport-m10-no + * + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (define foo10 'foo10) + (unexport foo10) + (define-syntax bar10 (ir-macro-transformer (lambda _ "bar10"))) + (unexport bar10) + (test-equal foo10 'foo10) + (test-equal (bar10) "bar10")) + +(module + unexport-m11-yes + * + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (define foo11 'foo11) + (unexport foo11) + (export foo11) + (define-syntax bar11 (ir-macro-transformer (lambda _ "bar11"))) + (unexport bar11) + (export bar11)) + +(module + unexport-m12-yes + * + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (export foo12) + (unexport foo12) + (define foo12 'foo12) + (export bar12) + (unexport bar12) + (define-syntax bar12 (ir-macro-transformer (lambda _ "bar12"))) + (test-equal foo12 'foo12) + (test-equal (bar12) "bar12")) + +(module + unexport-m13-yes + * + (import (chicken base) (chicken syntax) (chicken module) scheme test) + (unexport foo13) + (export foo13) + (define foo13 'foo13) + (unexport bar13) + (export bar13) + (define-syntax bar13 (ir-macro-transformer (lambda _ "bar13")))) diff --git a/tests/unexport-tests.scm b/tests/unexport-tests.scm new file mode 100644 index 0000000..fb069e6 --- /dev/null +++ b/tests/unexport-tests.scm @@ -0,0 +1,43 @@ +(import test) +(import (only (chicken format) format)) +(define-syntax test-mod + ;; (begin + ;; (import unexport-m00-yes) + ;; (test-equal foo00 'foo00) + ;; (test-equal (bar00) "bar00")) + ;; OR + ;; (begin + ;; (import unexport-m00-no) + ;; (test-error foo00) + ;; (test-error (bar00))) + (ir-macro-transformer + (lambda (e i cmp) + (apply + (lambda (number-str should-export?) + `(begin + (import ,(i (symbol-append 'unexport-m (string->symbol number-str) + '- (if should-export? 'yes 'no)))) + ,@(let ((c (lambda (sym) (symbol-append sym (string->symbol number-str))))) + (if should-export? + `((test-equal (format "bound ~a" ',(c 'foo)) ,(i (c 'foo)) ',(c 'foo)) + (test-equal (format "bound ~a" ',(c 'bar)) + (,(i (c 'bar))) ,(symbol->string (c 'bar)))) + `((test-error (format "unbound ~a" ',(c 'foo)) ,(i (c 'foo))) + (test-error (format "unbound ~a" ',(c 'bar)) (,(i (c 'bar))))))))) + (cdr e))))) +(test-group "unexport" + ;; (test-mod "00" #t) + (test-mod "01" #f) + (test-mod "02" #t) + (test-mod "03" #f) + (test-mod "04" #f) + (test-mod "05" #t) + (test-mod "06" #t) + (test-mod "07" #f) + (test-mod "08" #t) + (test-mod "09" #f) + (test-mod "10" #f) + (test-mod "11" #t) + (test-mod "12" #t) + (test-mod "13" #t)) +(test-exit) -- 2.7.4
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers