~ chicken-core (chicken-5) df0eb601874c78131fb6a61af4f053729ff1888f
commit df0eb601874c78131fb6a61af4f053729ff1888f
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Jul 7 22:46:00 2014 +0200
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Jul 12 17:59:21 2014 +0200
Allow functor-arguments to be optional and having defaults, and use the correct export-lists when matching functor arguments.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/NEWS b/NEWS
index 6efec544..a9c7732a 100644
--- a/NEWS
+++ b/NEWS
@@ -29,6 +29,11 @@
##sys#zap-strings, ##sys#round, ##sys#foreign-number-vector-argument,
##sys#check-port-mode, ##sys#check-port*
+- Module system
+ - Allow functor arguments to be optional, with default implementations.
+ - Fixed a bug that prevented functors from being instantiated with
+ built-in modules.
+
- Syntax expander
- define-values, set!-values and letrec-values now support full lambda
lists as binding forms
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index c815bc80..448ebf4d 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1133,10 +1133,11 @@
'functor '()
(##sys#er-transformer
(lambda (x r c)
- (##sys#check-syntax 'functor x '(_ (symbol . #((symbol _) 0)) _ . _))
+ (##sys#check-syntax 'functor x '(_ (symbol . #((_ _) 0)) _ . _))
(let* ((x (##sys#strip-syntax x))
(head (cadr x))
(name (car head))
+ (args (cdr head))
(exps (caddr x))
(body (cdddr x))
(registration
@@ -1145,8 +1146,14 @@
',(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))
+ (symbol? (cadr argname))))
+ (##sys#syntax-error-hook "invalid functor argument" name arg))
(cons argname exps)))
- (cdr head))
+ args)
',(##sys#validate-exports exps 'functor)
',body)))
`(##core#module
diff --git a/expand.scm b/expand.scm
index 72e246a4..1b5a74e3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1475,7 +1475,7 @@
'(##core#undefined))))
(else
(##sys#check-syntax
- 'module x '(_ symbol _ (symbol . #(_ 1))))
+ 'module x '(_ symbol _ (symbol . #(_ 0))))
(##sys#instantiate-functor
name
(car app) ; functor name
diff --git a/manual/Modules b/manual/Modules
index 758cd80f..b4048fc3 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -460,6 +460,11 @@ requirement that a specific export of an argument-module must be
syntax or non-syntax - it can be syntax in one instantiation and a
procedure definition in another.
+{{ARGUMENTMODULE}} may also be a list of the form {{(ALIAS DEFAULT)}}
+to allow specifying a default- or optional functor argument in case
+the instanation doesn't provide one. Optional functor
+arguments may only be followed by non-optional functor arguments.
+
The common case of using a functor with a single argument module
that is not used elsewhere can be expressed in the following way:
diff --git a/modules.scm b/modules.scm
index 913d4489..439c7091 100644
--- a/modules.scm
+++ b/modules.scm
@@ -823,15 +823,33 @@
(cons name args) (cons fname (map car fargs))))
`(##core#let-module-alias
,(let loop ((as args) (fas fargs))
- (cond ((null? as) (if (null? fas) '() (merr)))
+ (cond ((null? as)
+ ;; use default arguments (if available) or bail out
+ (let loop2 ((fas fas))
+ (if (null? fas)
+ '()
+ (let ((p (car fas)))
+ (if (pair? (car p)) ; has default argument?
+ (let ((alias (caar p))
+ (mname (cadar p))
+ (exps (cdr 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
+ (merr))))))
+ ;; more arguments given as defined for the functor
((null? fas) (merr))
(else
+ ;; otherwise match provided argument to functor argument
(let* ((p (car fas))
- (alias (car p))
+ (p1 (car p))
+ (def? (pair? p1))
+ (alias (if def? (car p1) p1))
(mname (car as))
(exps (cdr p)))
(##sys#match-functor-argument alias name mname exps fname)
- (cons (list alias mname) (loop (cdr as) (cdr fas)))))))
+ (cons (list alias mname)
+ (loop (cdr as) (cdr fas)))))))
(##core#module
,name
,(if (eq? '* exports) #t exports)
@@ -844,7 +862,8 @@
(for-each
(lambda (exp)
(let ((sym (if (symbol? exp) exp (car exp))))
- (unless (##sys#find-export sym mod #f)
+ (unless (or (assq sym (module-vexports mod))
+ (assq sym (module-sexports mod)))
(set! missing (cons sym missing)))))
exps)
(when (pair? missing)
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index 1b307fd5..1a05266c 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -132,6 +132,68 @@
99)
+;; Test optional functor arguments
+
+(functor (greet ((X default-writer) (write-greeting))) *
+ (import scheme X)
+ (define (greetings) (write-greeting 'Hello!)))
+
+(module default-writer (write-greeting)
+ (import scheme)
+ (define write-greeting list))
+
+(module writer (write-greeting)
+ (import scheme)
+ (define write-greeting vector))
+
+(module greet1 = (greet writer))
+(module greet2 = (greet))
+
+(test-equal
+ "optional functor argument #1"
+ (module m2 ()
+ (import greet1)
+ (greetings))
+ '#(Hello!))
+
+(test-equal
+ "optional functor argument #2"
+ (module m3 ()
+ (import greet2)
+ (greetings))
+ '(Hello!))
+
+
+;; Optional functor syntax with builtin ("primitive") modules:
+
+(functor (wrapper ((X scheme) (vector))) *
+ (import (except scheme vector) X)
+ (define (wrap x) (vector x)))
+
+(module default-wrapper (vector)
+ (import scheme))
+
+(module list-wrapper (vector)
+ (import (rename (only scheme list) (list vector))))
+
+(module lwrap = (wrapper list-wrapper))
+(module vwrap = (wrapper))
+
+(test-equal
+ "primitive optional functor argument #1"
+ (module m4 ()
+ (import lwrap)
+ (wrap 99))
+ '(99))
+
+(test-equal
+ "primitive optional functor argument #2"
+ (module m5 ()
+ (import vwrap)
+ (wrap 99))
+ '#(99))
+
+
;;
(test-end)
Trap