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

File 0001-Allow-functor-arguments-to-be-optional-defaulting-to.patch, 4.9 KB (added by felix winkelmann, 8 years ago)
  • chicken-syntax.scm

    From 568d638bfdb726f7b85790b759c8b4592b689e9d Mon Sep 17 00:00:00 2001
    From: felix <felix@call-with-current-continuation.org>
    Date: Sun, 4 May 2014 14:26:30 +0200
    Subject: [PATCH 1/2] Allow functor arguments to be optional, defaulting to a
     module given in the functor definition.
    
    ---
     chicken-syntax.scm      |   11 +++++++++--
     expand.scm              |    2 +-
     manual/Modules          |    5 +++++
     modules.scm             |   26 ++++++++++++++++++++++----
     tests/functor-tests.scm |   32 ++++++++++++++++++++++++++++++++
     5 files changed, 69 insertions(+), 7 deletions(-)
    
    diff --git a/chicken-syntax.scm b/chicken-syntax.scm
    index 7a28158..0120dda 100644
    a b  
    11471147 'functor '()
    11481148 (##sys#er-transformer
    11491149  (lambda (x r c)
    1150     (##sys#check-syntax 'functor x '(_ (symbol . #((symbol _) 0)) _ . _))
     1150    (##sys#check-syntax 'functor x '(_ (symbol . #((_ _) 0)) _ . _))
    11511151    (let* ((x (##sys#strip-syntax x))
    11521152           (head (cadr x))
    11531153           (name (car head))
     1154           (args (cdr head))
    11541155           (exps (caddr x))
    11551156           (body (cdddr x))
    11561157           (registration
     
    11591160              ',(map (lambda (arg)
    11601161                       (let ((argname (car arg))
    11611162                             (exps (##sys#validate-exports (cadr arg) 'functor)))
     1163                         (unless (or (symbol? argname)
     1164                                     (and (list? argname)
     1165                                          (= 2 (length argname))
     1166                                          (symbol? (car argname))
     1167                                          (symbol? (cadr argname))))
     1168                           (##sys#syntax-error-hook "invalid functor argument" name arg))
    11621169                         (cons argname exps)))
    1163                      (cdr head))
     1170                     args)
    11641171              ',(##sys#validate-exports exps 'functor)
    11651172              ',body)))
    11661173      `(##core#module
  • expand.scm

    diff --git a/expand.scm b/expand.scm
    index 40f0c50..ecfddc9 100644
    a b  
    14591459                             '(##core#undefined))))
    14601460                     (else
    14611461                      (##sys#check-syntax
    1462                        'module x '(_ symbol _ (symbol . #(_ 1))))
     1462                       'module x '(_ symbol _ (symbol . #(_ 0))))
    14631463                      (##sys#instantiate-functor
    14641464                       name
    14651465                       (car app)        ; functor name
  • manual/Modules

    diff --git a/manual/Modules b/manual/Modules
    index 38bad00..140cf74 100644
    a b requirement that a specific export of an argument-module must be 
    460460syntax or non-syntax - it can be syntax in one instantiation and a
    461461procedure definition in another.
    462462
     463{{ARGUMENTMODULE}} may also be a list of the form {{(ALIAS DEFAULT)}}
     464to allow specifying a default- or optional functor argument in case
     465the instanation doesn't provide one. Optional functor
     466arguments may only be followed by non-optional functor arguments.
     467
    463468The common case of using a functor with a single argument module
    464469that is not used elsewhere can be expressed in the following way:
    465470
  • modules.scm

    diff --git a/modules.scm b/modules.scm
    index 913d448..d8a3dd5 100644
    a b  
    823823             (cons name args) (cons fname (map car fargs))))
    824824      `(##core#let-module-alias
    825825        ,(let loop ((as args) (fas fargs))
    826            (cond ((null? as) (if (null? fas) '() (merr)))
     826           (cond ((null? as)
     827                  ;; use default arguments (if available) or bail out
     828                  (let loop2 ((fas fas))
     829                    (if (null? fas)
     830                        '()
     831                        (let ((p (car fas)))
     832                          (if (pair? (car p)) ; hjas default argument?
     833                              (let ((alias (caar p))
     834                                    (mname (cadar p))
     835                                    (exps (cdr p)))
     836                                (##sys#match-functor-argument alias name mname exps fname)
     837                                (cons (list alias mname) (loop2 (cdr fas))))
     838                              ;; no default argument, we have too few argument modules
     839                              (merr))))))
     840                 ;; more arguments given as defined for the functor
    827841                 ((null? fas) (merr))
    828842                 (else
     843                  ;; otherwise match provided argument to functor argument
    829844                  (let* ((p (car fas))
    830                          (alias (car p))
    831                          (mname (car as))
     845                         (p1 (car p))
     846                         (def? (pair? p1))
     847                         (alias (if def? (car p1) p1))
     848                         (mname (if def? (cadr p1) (car as)))
    832849                         (exps (cdr p)))
    833850                    (##sys#match-functor-argument alias name mname exps fname)
    834                     (cons (list alias mname) (loop (cdr as) (cdr fas)))))))
     851                    (cons (list alias mname)
     852                          (loop (cdr as) (cdr fas)))))))
    835853        (##core#module
    836854         ,name
    837855         ,(if (eq? '* exports) #t exports)
  • tests/functor-tests.scm

    diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
    index 1b307fd..b0f5a3b 100644
    a b  
    132132 99)
    133133
    134134
     135;; Test optional functor arguments
     136
     137(functor (greet ((X default-writer) (write-greeting))) *
     138  (import scheme X)
     139  (define (greetings) (write-greeting 'Hello!)))
     140
     141(module default-writer (write-greeting)
     142  (import scheme)
     143  (define write-greeting list))
     144
     145(module writer (write-greeting)
     146  (import scheme)
     147  (define write-greeting vector))
     148
     149(module greet1 = (greet writer))
     150(module greet2 = (greet))
     151
     152(test-equal
     153 "optional functor argument #1"
     154 (module m2 ()
     155         (import greet1)
     156         (greetings))
     157 '(Hello!))
     158
     159(test-equal
     160 "optional functor argument #2"
     161 (module m3 ()
     162         (import greet2)
     163         (greetings))
     164 '#(Hello!))
     165
     166
    135167;;
    136168
    137169(test-end)