[Chicken-hackers] [PATCH] Allow optional functor arguments

[Felix Winkelmann]

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