Re: [Chicken-hackers] [PATCH] Add unexport form for modules (updated for chicken 5)

[megane]

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 <address@hidden>
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