~ chicken-core (chicken-5) d2d195ac1757b86caaf503535da97b1afc604b85
commit d2d195ac1757b86caaf503535da97b1afc604b85
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Fri Oct 9 20:36:33 2015 +1300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Mon Nov 2 21:29:01 2015 +0100
Add support for library lists in functors and functor arguments
Also removes the syntax for creating module aliases to avoid ambiguity
between that and instantiation of a functor with a list-style name.
diff --git a/NEWS b/NEWS
index 19b69369..eba4c910 100644
--- a/NEWS
+++ b/NEWS
@@ -28,6 +28,7 @@
program's (macro) namespace anymore.
- The core units have been converted to modules under the "chicken"
namespace.
+ - Added support for list-style library names.
4.10.2
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index a739cb51..6464808c 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1138,7 +1138,7 @@
'functor '()
(##sys#er-transformer
(lambda (x r c)
- (##sys#check-syntax 'functor x '(_ (symbol . #((_ _) 0)) _ . _))
+ (##sys#check-syntax 'functor x '(_ (_ . #((_ _) 0)) _ . _))
(let* ((x (chicken.expand#strip-syntax x))
(head (cadr x))
(name (car head))
@@ -1147,7 +1147,7 @@
(body (cdddr x))
(registration
`(##sys#register-functor
- ',name
+ ',(chicken.internal#library-id name)
',(map (lambda (arg)
(let ((argname (car arg))
(exps (##sys#validate-exports (cadr arg) 'functor)))
@@ -1155,14 +1155,17 @@
(and (list? argname)
(= 2 (length argname))
(symbol? (car argname))
- (symbol? (cadr argname))))
+ (let ((param (cadr argname)))
+ (or (symbol? param)
+ (and (list? param)
+ (every symbol? param))))))
(##sys#syntax-error-hook "invalid functor argument" name arg))
(cons argname exps)))
args)
',(##sys#validate-exports exps 'functor)
',body)))
`(##core#module
- ,name
+ ,(chicken.internal#library-id name)
#t
(import scheme chicken)
(begin-for-syntax ,registration))))))
diff --git a/expand.scm b/expand.scm
index e7ad3a13..257214d9 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1448,38 +1448,34 @@
(cond ((and (fx>= len 4) (c (r '=) (caddr x)))
(let* ((x (chicken.expand#strip-syntax x))
(app (cadddr x)))
- (cond ((symbol? app)
- (cond ((fx> len 4)
- ;; feature suggested by syn:
- ;;
- ;; (module NAME = FUNCTORNAME BODY ...)
- ;; ~>
- ;; (begin
- ;; (module _NAME * BODY ...)
- ;; (module NAME = (FUNCTORNAME _NAME)))
- ;;
- ;; - the use of "_NAME" is a bit stupid, but it must be
- ;; externally visible to generate an import library from
- ;; and compiling "NAME" separately may need an import-lib
- ;; for stuff in "BODY" (say, syntax needed by syntax exported
- ;; from the functor, or something like this...)
- (let ((mtmp (string->symbol
- (##sys#string-append
- "_"
- (symbol->string name))))
- (%module (r 'module)))
- `(##core#begin
- (,%module ,mtmp * ,@(cddddr x))
- (,%module ,name = (,app ,mtmp)))))
- (else
- (##sys#register-module-alias name app)
- '(##core#undefined))))
+ (cond ((fx> len 4)
+ ;; feature suggested by syn:
+ ;;
+ ;; (module NAME = FUNCTORNAME BODY ...)
+ ;; ~>
+ ;; (begin
+ ;; (module _NAME * BODY ...)
+ ;; (module NAME = (FUNCTORNAME _NAME)))
+ ;;
+ ;; - the use of "_NAME" is a bit stupid, but it must be
+ ;; externally visible to generate an import library from
+ ;; and compiling "NAME" separately may need an import-lib
+ ;; for stuff in "BODY" (say, syntax needed by syntax exported
+ ;; from the functor, or something like this...)
+ (let ((mtmp (string->symbol
+ (##sys#string-append
+ "_"
+ (symbol->string name))))
+ (%module (r 'module)))
+ `(##core#begin
+ (,%module ,mtmp * ,@(cddddr x))
+ (,%module ,name = (,app ,mtmp)))))
(else
(##sys#check-syntax
- 'module x '(_ symbol _ (symbol . #(_ 0))))
+ 'module x '(_ _ _ (_ . #(_ 0))))
(##sys#instantiate-functor
name
- (car app) ; functor name
+ (chicken.internal#library-id (car app))
(cdr app)))))) ; functor arguments
(else
;;XXX use module name in "loc" argument?
diff --git a/manual/Modules b/manual/Modules
index 34da3bbd..57a0c9d8 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -43,8 +43,8 @@ CHICKEN's module system has the following features:
<macro>(module NAME (EXPORT ...) BODY ...)</macro>
<macro>(module NAME (EXPORT ...) FILENAME)</macro>
<macro>(module NAME * BODY ...)</macro>
-<macro>(module NAME1 = NAME2 [BODY ...])</macro>
<macro>(module NAME = (FUNCTORNAME MODULENAME1 ...))</macro>
+<macro>(module NAME = FUNCTORNAME BODY ...)</macro>
Defines a module with the name {{NAME}}, a set of exported bindings
and a contained sequence of toplevel expressions that are evaluated in
@@ -79,15 +79,12 @@ like {{(include FILENAME)}}.
{{(module NAME = (FUNCTORNAME MODULENAME1 ...))}} instantiates
a ''functor'' (see below for information about functors).
-The syntax {{(module NAME1 = NAME2)}} defines an alias {{NAME1}} for
-the module {{NAME2}}, so {{NAME1}} can be used in place of {{NAME2}}
-in all forms that accept module names. Module aliases defined inside a
-module are local to that module. If followed by a module body, then
-this is a special form of ''functor instantiation''.
+{{(module NAME = FUNCTORNAME BODY ...)}} is a special form of
+''functor instantiation'' where the {{BODY}} implements a module
+satisfying a single functor argument to {{FUNCTORNAME}}.
Nested modules, modules not at toplevel (i.e. local modules) or
-mutually recursive modules are not supported. As an exception
-module alias definitions are allowed inside a module definition.
+mutually recursive modules are not supported.
When compiled, the module information, including exported macros
is stored in the generated binary and available when loading
@@ -265,7 +262,7 @@ available:
[module] r4rs
[module] r5rs
-Exports the definitions given in R4RS or R5RS. {{r5rs}} is a module alias
+Exports the definitions given in R4RS or R5RS. {{r5rs}} is an alias
for {{scheme}}.
[module] chicken
diff --git a/modules.scm b/modules.scm
index 5afdbbf4..ae4452ae 100644
--- a/modules.scm
+++ b/modules.scm
@@ -840,9 +840,9 @@
'()
(let ((p (car fas)))
(if (pair? (car p)) ; has default argument?
- (let ((alias (caar p))
- (mname (cadar p))
- (exps (cdr p)))
+ (let ((exps (cdr p))
+ (alias (caar p))
+ (mname (chicken.internal#library-id (cadar p))))
(##sys#match-functor-argument alias name mname exps fname)
(cons (list alias mname) (loop2 (cdr fas))))
;; no default argument, we have too few argument modules
@@ -853,10 +853,10 @@
;; otherwise match provided argument to functor argument
(let* ((p (car fas))
(p1 (car p))
+ (exps (cdr p))
(def? (pair? p1))
(alias (if def? (car p1) p1))
- (mname (car as))
- (exps (cdr p)))
+ (mname (chicken.internal#library-id (car as))))
(##sys#match-functor-argument alias name mname exps fname)
(cons (list alias mname)
(loop (cdr as) (cdr fas)))))))
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index 1c71ddf2..5db07414 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -1,7 +1,7 @@
;;;; functor-tests.scm
-(use data-structures extras)
+(use data-structures extras ports)
(include "test.scm")
@@ -101,6 +101,35 @@
;;XXX shows (""), which looks wrong:
(pp (show 8 (search next-char '()))) ;XXX assert
+;; list-style library names
+
+(functor ((double printer) ((P (chicken)) (print))) (print-twice)
+ (import (scheme) P)
+ (define (print-twice x) (print x) (print x)))
+
+(module (noop printer) *
+ (import (only (scheme) define) (only (chicken) void))
+ (define print void))
+
+(module (2x print) = ((double printer)))
+
+(module (2x noop) = ((double printer) (noop printer)))
+
+(module (2x write) = (double printer)
+ (reexport (rename (scheme) (write print))))
+
+(define output
+ (with-output-to-string
+ (lambda ()
+ (import (2x print))
+ (print-twice #\a)
+ (import (2x noop))
+ (print-twice #\a)
+ (import (2x write))
+ (print-twice #\a))))
+
+(test-equal "double printer" output "a\na\n#\\a#\\a")
+
;; Test for errors
#+csi
diff --git a/tests/module-tests.scm b/tests/module-tests.scm
index df782a98..421560e6 100644
--- a/tests/module-tests.scm
+++ b/tests/module-tests.scm
@@ -197,7 +197,8 @@
'abc (abc))
(module m17 (a) (import scheme) (define a 1))
-(module m18 = m17)
+(begin-for-syntax ; XXX workaround for missing module alias functionality
+ (##sys#register-module-alias 'm18 'm17))
(module m19 (a) (import scheme) (define a 2))
(test-equal
@@ -212,7 +213,8 @@
"local module alias scope"
(module m21 ()
(import scheme)
- (module m18 = m19)
+ (begin-for-syntax ; XXX s.a.
+ (##sys#register-module-alias 'm18 'm19))
(import m18)
a)
2)
@@ -298,6 +300,22 @@
(m29-baz))
'foo)
+;; list-style library names
+
+(test-assert
+ (module (m33 a) *
+ (import (scheme))
+ (define (foo) 'ok)))
+
+(test-assert
+ (module (m33 b) ()
+ (import (scheme) (m33 a))
+ (eq? (foo) 'ok)))
+
+(test-assert (import (prefix (m33 a) m33/a/)))
+(test-assert (eq? (m33/a/foo) 'ok))
+(test-assert (module-environment '(m33 a)))
+
;; Ensure that the modules system is simply an aliasing mechanism:
;; Module instantion does not create multiple variable copies.
diff --git a/tests/simple-functors-test.scm b/tests/simple-functors-test.scm
index f72e9662..3e69a3db 100644
--- a/tests/simple-functors-test.scm
+++ b/tests/simple-functors-test.scm
@@ -8,14 +8,12 @@
(define a 1)
(define b 2))
-(module f = foo)
-
(functor
(do-things (arg STUFF)) (do-it)
(import scheme arg)
(define (do-it) (list a b)))
-(module bar = (do-things f))
+(module bar = (do-things foo))
(import bar)
(assert (equal? '(1 2) (do-it)))
Trap