Hello!
Here another (and proper) patch: it allows functor arguments to be
optional, giving the author or a functor a way to provide a default,
which seems to be quite useful. I think this patch was submitted
before, but seems to have been forgotten.
This patch also fixes a bug in the functor-argument matching code:
when verifying whether a module given as argument exports the required
binding, the export-list was previously checked (that's the list given
in a module declaration, specifying the exports). But that was
incorrect, as, for example, builtin modules (like "scheme") do not
have export lists. This change uses the "vexports"/"sexports" lists
of a module instead, that is, the "real" exports.
felix
>From 409f2add49b6ccec225a766c457b5982ed3bb1f9 Mon Sep 17 00:00:00 2001
From: felix <fe...@call-with-current-continuation.org>
Date: Mon, 7 Jul 2014 22:46:00 +0200
Subject: [PATCH] Allow functor-arguments to be optional and having defaults,
and use the correct export-lists when matching functor
arguments.
---
chicken-syntax.scm | 11 +++++++--
expand.scm | 2 +-
manual/Modules | 5 ++++
modules.scm | 27 ++++++++++++++++++---
tests/functor-tests.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++++
5 files changed, 100 insertions(+), 7 deletions(-)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 7a28158..0120dda 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1147,10 +1147,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
@@ -1159,8 +1160,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 40f0c50..ecfddc9 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1459,7 +1459,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 758cd80..b4048fc 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 913d448..b79259c 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 1b307fd..1a05266 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)
--
1.7.9.5
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
