Ticket #1121: 0001-Allow-functor-arguments-to-be-optional-defaulting-to.patch

chicken-syntax.scm

@@ -1147 +1147 @@
  '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 +1160 @@
               ',(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

expand.scm

@@ -1459 +1459 @@
                              '(##core#undefined))))
                      (else
                       (##sys#check-syntax 
-                       'module x '(_ symbol _ (symbol . #(_ 1))))
+                       'module x '(_ symbol _ (symbol . #(_ 0))))
                       (##sys#instantiate-functor
                        name
                        (car app)        ; functor name

manual/Modules

@@ -460 +460 @@
 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:
 

modules.scm

@@ -823 +823 @@
              (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)) ; hjas 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))
-                         (mname (car as))
+                         (p1 (car p))
+                         (def? (pair? p1))
+                         (alias (if def? (car p1) p1))
+                         (mname (if def? (cadr p1) (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)

tests/functor-tests.scm

@@ -132 +132 @@
  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!))
+
+
 ;;
 
 (test-end)