From 93c8e56092b4cb462f0669ab9892213fa8090b71 Mon Sep 17 00:00:00 2001 From: felix Date: Tue, 3 Oct 2023 12:50:53 +0200 Subject: [PATCH] allow renaming exports in "export" form --- expand.scm | 44 +++++++++------- manual/Modules | 7 +++ modules.scm | 112 +++++++++++++++++++++++++---------------- tests/module-tests.scm | 22 ++++++++ 4 files changed, 126 insertions(+), 59 deletions(-) diff --git a/expand.scm b/expand.scm index 13a7f553..a88ddda9 100644 --- a/expand.scm +++ b/expand.scm @@ -1175,7 +1175,10 @@ (cdr app)))))) ; functor arguments (else ;;XXX use module name in "loc" argument? - (let ((exports (##sys#validate-exports (strip-syntax (caddr x)) 'module))) + (let-values (((exports _) (##sys#validate-exports (strip-syntax (caddr x)) + 'module))) + ;;XXX we currently ignore renames here, to support this, we need to + ;; extend ##core#module `(##core#module ,name ,(if (eq? '* exports) @@ -1192,11 +1195,11 @@ 'export '() (##sys#er-transformer (lambda (x r c) - (let ((exps (##sys#validate-exports (strip-syntax (cdr x)) 'export)) - (mod (##sys#current-module))) - (when mod - (##sys#add-to-export-list mod exps)) - '(##core#undefined))))) + (let-values (((exps ren) (##sys#validate-exports (strip-syntax (cdr x)) 'export))) + (let ((mod (##sys#current-module))) + (when mod + (##sys#add-to-export-list mod exps ren)) + '(##core#undefined)))))) (##sys#extend-macro-environment 'reexport '() @@ -1223,17 +1226,20 @@ (##core#quote ,(library-id name)) (##core#quote ,(map (lambda (arg) - (let ((argname (car arg)) - (exps (##sys#validate-exports (cadr arg) 'functor))) - (unless (or (symbol? argname) - (and (list? argname) - (= 2 (length argname)) - (symbol? (car argname)) - (valid-library-specifier? (cadr argname)))) - (##sys#syntax-error-hook "invalid functor argument" name arg)) - (cons argname exps))) + (let ((argname (car arg))) + (let-values (((exps _) (##sys#validate-exports (cadr arg) + 'functor))) + ;;XXX renames currently ignored + (unless (or (symbol? argname) + (and (list? argname) + (= 2 (length argname)) + (symbol? (car argname)) + (valid-library-specifier? (cadr argname)))) + (##sys#syntax-error-hook "invalid functor argument" name arg)) + (cons argname exps)))) args)) - (##core#quote ,(##sys#validate-exports exps 'functor)) + (##core#quote ,(let-values (((exps _) (##sys#validate-exports exps 'functor))) + exps)) (##core#quote ,body)))) `(##core#module ,(library-id name) #t @@ -1260,7 +1266,11 @@ (cond ((eq? '* exps) '*) ((symbol? exps) `(#:interface ,exps)) ((list? exps) - (##sys#validate-exports exps 'define-interface)) + (let-values (((exps ren) (##sys#validate-exports exps 'define-interface))) + (unless (null? ren) + (syntax-error-hook 'define-interface + "renaming exports may not be used in interface definitions")) + exps)) (else (syntax-error-hook 'define-interface "invalid exports" (caddr x)))))))))))) diff --git a/manual/Modules b/manual/Modules index e562f460..e0f11ab0 100644 --- a/manual/Modules +++ b/manual/Modules @@ -119,6 +119,13 @@ Allows augmenting module-exports from inside the module-body. {{module}} export list. An export must precede its first occurrence (either use or definition). +{{EXPORT}} may also have the form + + {{(rename: OLD NEW)}} + +to specify that the local identifier OLD is renamed on export to NEW +and visible under the latter name. + If used outside of a module, then this form does nothing. ==== import diff --git a/modules.scm b/modules.scm index 61556fef..0204769d 100644 --- a/modules.scm +++ b/modules.scm @@ -90,12 +90,13 @@ module-meta-expressions set-module-meta-expressions! module-defined-syntax-list set-module-defined-syntax-list! module-saved-environments set-module-saved-environments! - module-iexports set-module-iexports!)) + module-iexports set-module-iexports! + module-rename-list set-module-rename-list!)) (define-record-type module (%make-module name library export-list defined-list exist-list defined-syntax-list undefined-list import-forms meta-import-forms meta-expressions - vexports sexports iexports saved-environments) + vexports sexports iexports saved-environments rename-list) module? (name module-name) ; SYMBOL (library module-library) ; SYMBOL @@ -111,7 +112,8 @@ (sexports module-sexports set-module-sexports!) ; ((SYMBOL SE TRANSFORMER) ...) (iexports module-iexports set-module-iexports!) ; ((SYMBOL . SYMBOL) ...) ;; for csi's ",m" command, holds ( . ) - (saved-environments module-saved-environments set-module-saved-environments!)) + (saved-environments module-saved-environments set-module-saved-environments!) + (rename-list module-rename-list set-module-rename-list!)) (define ##sys#module-name module-name) @@ -121,8 +123,9 @@ (module-vexports m) (module-sexports m))) -(define (make-module name lib explist vexports sexports iexports) - (%make-module name lib explist '() '() '() '() '() '() '() vexports sexports iexports #f)) +(define (make-module name lib explist vexports sexports iexports #!optional (renames '())) + (%make-module name lib explist '() '() '() '() '() '() '() vexports sexports iexports #f + renames)) (define (##sys#register-module-alias alias name) (##sys#module-alias-environment @@ -165,8 +168,9 @@ (##sys#macro-environment (cdr saved))) (##sys#current-module mod)))))) -(define (##sys#add-to-export-list mod exps) - (let ((xl (module-export-list mod))) +(define (##sys#add-to-export-list mod exps renames) + (let ((xl (module-export-list mod)) + (rl (module-rename-list mod))) (if (eq? xl #t) (let ((el (module-exist-list mod)) (me (##sys#macro-environment)) @@ -179,7 +183,8 @@ 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))) + (set-module-rename-list! mod (append rl renames)))) (define (##sys#toplevel-definition-hook sym renamed exported?) #f) @@ -303,8 +308,7 @@ ((or (eq? last-se (car ses)) (null? (car ses))) (loop (cdr ses) last-se se2)) ((not last-se) - (unless (null? ses) - (for-each (lambda (e) (hash-table-set! seen (car e) #t)) se2)) + (for-each (lambda (e) (hash-table-set! seen (car e) #t)) se2) (loop ses se2 se2)) (else (let lp ((se (car ses)) (se2 se2)) (cond ((null? se) (loop (cdr ses) (car ses) se2)) @@ -369,14 +373,18 @@ (else (let ((name (caar sd))) (cons `(scheme#cons ',(caar sd) ,(strip-syntax (cdar sd))) - (loop (cdr sd))))))))))))))) + (loop (cdr sd))))))))) + (scheme#list ; renames + ,@(map (lambda (ren) + `(scheme#cons ',(car ren) ',(cdr ren))) + (module-rename-list mod))))))))) ;; iexports = indirect exports (syntax dependencies on value idents, explicitly included in module export list) ;; vexports = value (non-syntax) exports ;; sexports = syntax exports ;; sdefs = unexported definitions from syntax environment used by exported macros (not in export list) (define (##sys#register-compiled-module name lib iexports vexports sexports #!optional - (sdefs '())) + (sdefs '()) (renames '())) (define (find-reexport name) (let ((a (assq name (##sys#macro-environment)))) (if (and a (pair? (cdr a))) @@ -396,7 +404,8 @@ (map (lambda (ne) (list (car ne) #f (##sys#ensure-transformer (cdr ne) (car ne)))) sdefs)) - (mod (make-module name lib '() vexports (append sexps reexp-sexps) iexports)) + (mod (make-module name lib '() vexports (append sexps reexp-sexps) iexports + renames)) (senv (if (or (not (null? sexps)) ; Only macros have an senv (not (null? nexps))) ; which must be patched up (merge-se @@ -660,6 +669,16 @@ ((symbol? x) (##sys#symbol->string x)) ((number? x) (number->string x)) (else (##sys#syntax-error-hook loc "invalid prefix" )))) + (define (export-rename mod lst) + (let ((ren (module-rename-list mod))) + (if (null? ren) + lst + (map (lambda (a) + (cond ((assq (car a) ren) => + (lambda (b) + (cons (cdr b) (cdr a)))) + (else a))) + lst)))) (call-with-current-continuation (lambda (k) (define (module-imports name) @@ -670,10 +689,10 @@ (values (module-name mod) (module-library mod) (module-name mod) - (module-vexports mod) - (module-sexports mod) + (export-rename mod (module-vexports mod)) + (export-rename mod (module-sexports mod)) (module-iexports mod))))) - (let loop ((x x)) + (let outer ((x x)) (cond ((symbol? x) (module-imports (strip-syntax x))) ((not (pair? x)) @@ -682,7 +701,7 @@ (let ((head (car x))) (cond ((c %only head) (##sys#check-syntax loc x '(_ _ . #(symbol 0))) - (let-values (((name lib spec impv imps impi) (loop (cadr x))) + (let-values (((name lib spec impv imps impi) (outer (cadr x))) ((imports) (strip-syntax (cddr x)))) (let loop ((ids imports) (v '()) (s '()) (missing '())) (cond ((null? ids) @@ -701,11 +720,11 @@ (loop (cdr ids) v s (cons (car ids) missing))))))) ((c %except head) (##sys#check-syntax loc x '(_ _ . #(symbol 0))) - (let-values (((name lib spec impv imps impi) (loop (cadr x))) + (let-values (((name lib spec impv imps impi) (outer (cadr x))) ((imports) (strip-syntax (cddr x)))) - (let loop ((impv impv) (v '()) (ids imports)) + (let loopv ((impv impv) (v '()) (ids imports)) (cond ((null? impv) - (let loop ((imps imps) (s '()) (ids ids)) + (let loops ((imps imps) (s '()) (ids ids)) (cond ((null? imps) (for-each (lambda (id) @@ -714,21 +733,21 @@ (values name lib `(,head ,spec ,@imports) v s impi)) ((memq (caar imps) ids) => (lambda (id) - (loop (cdr imps) s (delete (car id) ids eq?)))) + (loops (cdr imps) s (delete (car id) ids eq?)))) (else - (loop (cdr imps) (cons (car imps) s) ids))))) + (loops (cdr imps) (cons (car imps) s) ids))))) ((memq (caar impv) ids) => (lambda (id) - (loop (cdr impv) v (delete (car id) ids eq?)))) + (loopv (cdr impv) v (delete (car id) ids eq?)))) (else - (loop (cdr impv) (cons (car impv) v) ids)))))) + (loopv (cdr impv) (cons (car impv) v) ids)))))) ((c %rename head) (##sys#check-syntax loc x '(_ _ . #((symbol symbol) 0))) - (let-values (((name lib spec impv imps impi) (loop (cadr x))) + (let-values (((name lib spec impv imps impi) (outer (cadr x))) ((renames) (strip-syntax (cddr x)))) - (let loop ((impv impv) (v '()) (ids renames)) + (let loopv ((impv impv) (v '()) (ids renames)) (cond ((null? impv) - (let loop ((imps imps) (s '()) (ids ids)) + (let loops ((imps imps) (s '()) (ids ids)) (cond ((null? imps) (for-each (lambda (id) @@ -737,21 +756,21 @@ (values name lib `(,head ,spec ,@renames) v s impi)) ((assq (caar imps) ids) => (lambda (a) - (loop (cdr imps) + (loops (cdr imps) (cons (cons (cadr a) (cdar imps)) s) (delete a ids eq?)))) (else - (loop (cdr imps) (cons (car imps) s) ids))))) + (loops (cdr imps) (cons (car imps) s) ids))))) ((assq (caar impv) ids) => (lambda (a) - (loop (cdr impv) - (cons (cons (cadr a) (cdar impv)) v) - (delete a ids eq?)))) + (loopv (cdr impv) + (cons (cons (cadr a) (cdar impv)) v) + (delete a ids eq?)))) (else - (loop (cdr impv) (cons (car impv) v) ids)))))) + (loopv (cdr impv) (cons (car impv) v) ids)))))) ((c %prefix head) (##sys#check-syntax loc x '(_ _ _)) - (let-values (((name lib spec impv imps impi) (loop (cadr x))) + (let-values (((name lib spec impv imps impi) (outer (cadr x))) ((prefix) (strip-syntax (caddr x)))) (define (rename imp) (cons @@ -858,29 +877,38 @@ (define (iface name) (or (getp name '##core#interface) (err "unknown interface" name exps))) - (cond ((eq? '* exps) exps) - ((symbol? exps) (iface exps)) + (cond ((eq? '* exps) (values exps '())) + ((symbol? exps) (values (iface exps) '())) ((not (list? exps)) (err "invalid exports" exps)) (else - (let loop ((xps exps)) - (cond ((null? xps) '()) + (let loop ((xps exps) (xl '()) (rl '())) + (cond ((null? xps) (values (reverse xl) (reverse rl))) ((not (pair? xps)) (err "invalid exports" exps)) (else (let ((x (car xps))) - (cond ((symbol? x) (cons x (loop (cdr xps)))) + (cond ((symbol? x) + (loop (cdr xps) (cons x xl) rl)) ((not (list? x)) (err "invalid export" x exps)) ((eq? #:syntax (car x)) - (cons (cdr x) (loop (cdr xps)))) ; currently not used + (loop (cdr xps) (cons (cdr x) xl) rl)) ; currently not used + ((eq? #:rename (car x)) + (if (not (= (length x) 3)) + (err "invalid rename specification" x) + (loop (cdr xps) + (cons (cadr x) xl) + (cons (cons (cadr x) (caddr x)) rl)))) ((eq? #:interface (car x)) (if (and (pair? (cdr x)) (symbol? (cadr x))) - (append (iface (cadr x)) (loop (cdr xps))) + (loop (cdr xps) + (append (reverse (iface (cadr x))) xl) + rl) (err "invalid interface specification" x exps))) (else (let loop2 ((lst x)) - (cond ((null? lst) (cons x (loop (cdr xps)))) + (cond ((null? lst) (loop (cdr xps) (cons x xl) rl)) ((symbol? (car lst)) (loop2 (cdr lst))) (else (err "invalid export" x exps))))))))))))) diff --git a/tests/module-tests.scm b/tests/module-tests.scm index ec447e45..017ef1b9 100644 --- a/tests/module-tests.scm +++ b/tests/module-tests.scm @@ -380,6 +380,28 @@ (import (scheme) (chicken module)) (eq? (current-module) 'm33))) +(module m34 ((syn bar) alias) + (import scheme (chicken base) (chicken module)) + (export (rename: bar baz) (rename: syn syn2)) + (define bar 123) + (assert (equal? bar 123)) + (define-syntax alias + (syntax-rules () + ((_) (syn)))) + (define-syntax syn + (syntax-rules () + ((_) (list bar))))) + +(module m35 () + (import scheme (chicken base) (chicken module)) + (import (only (rename m34 (syn2 syn3)) syn3 alias)) + (import (rename m34 (baz bax))) + (define bar 99) + (assert (equal? bax 123)) + (assert (equal? (syn3) '(123))) + (assert (equal? (alias) '(123))) + (assert (equal? bar 99))) + (test-end "modules") (test-exit) -- 2.40.0