module/ice-9/optargs.scm

   1 ;;;; optargs.scm -- support for optional arguments
   2 ;;;;
   3 ;;;;    Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 ;;;;
  19 ;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
  20
  21 \f
  22
  23 ;;; Commentary:
  24
  25 ;;; {Optional Arguments}
  26 ;;;
  27 ;;; The C interface for creating Guile procedures has a very handy
  28 ;;; "optional argument" feature. This module attempts to provide
  29 ;;; similar functionality for procedures defined in Scheme with
  30 ;;; a convenient and attractive syntax.
  31 ;;;
  32 ;;; exported macros are:
  33 ;;;   let-optional
  34 ;;;   let-optional*
  35 ;;;   let-keywords
  36 ;;;   let-keywords*
  37 ;;;   lambda*
  38 ;;;   define*
  39 ;;;   define*-public
  40 ;;;   defmacro*
  41 ;;;   defmacro*-public
  42 ;;;
  43 ;;;
  44 ;;; Summary of the lambda* extended parameter list syntax (brackets
  45 ;;; are used to indicate grouping only):
  46 ;;;
  47 ;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
  48 ;;;   [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
  49 ;;;   [[#:rest identifier]|[. identifier]]?
  50 ;;;
  51 ;;; ext-var-decl ::= identifier | ( identifier expression )
  52 ;;;
  53 ;;; The characters `*', `+' and `?' are not to be taken literally; they
  54 ;;; mean respectively, zero or more occurences, one or more occurences,
  55 ;;; and one or zero occurences.
  56 ;;;
  57
  58 ;;; Code:
  59
  60 (define-module (ice-9 optargs)
  61   #:use-module (system base pmatch)
  62   #:re-export (lambda* define*)
  63   #:export (let-optional
  64             let-optional*
  65             let-keywords
  66             let-keywords*
  67             define*-public
  68             defmacro*
  69             defmacro*-public))
  70
  71 ;; let-optional rest-arg (binding ...) . body
  72 ;; let-optional* rest-arg (binding ...) . body
  73 ;;   macros used to bind optional arguments
  74 ;;
  75 ;; These two macros give you an optional argument interface that is
  76 ;; very "Schemey" and introduces no fancy syntax. They are compatible
  77 ;; with the scsh macros of the same name, but are slightly
  78 ;; extended. Each of binding may be of one of the forms <var> or
  79 ;; (<var> <default-value>). rest-arg should be the rest-argument of
  80 ;; the procedures these are used from. The items in rest-arg are
  81 ;; sequentially bound to the variable namess are given. When rest-arg
  82 ;; runs out, the remaining vars are bound either to the default values
  83 ;; or to `#f' if no default value was specified. rest-arg remains
  84 ;; bound to whatever may have been left of rest-arg.
  85 ;;
  86
  87 (define (vars&inits bindings)
  88   (let lp ((bindings bindings) (vars '()) (inits '()))
  89     (syntax-case bindings ()
  90       (()
  91        (values (reverse vars) (reverse inits)))
  92       (((v init) . rest) (identifier? #'v)
  93        (lp #'rest (cons #'v vars) (cons #'init inits)))
  94       ((v . rest) (identifier? #'v)
  95        (lp #'rest (cons #'v vars) (cons #'#f inits))))))
  96
  97 (define-syntax let-optional
  98   (lambda (x)
  99     (syntax-case x ()
 100       ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
 101        (call-with-values (lambda () (vars&inits #'(binding ...)))
 102          (lambda (vars inits)
 103            (with-syntax ((n (length vars))
 104                          (n+1 (1+ (length vars)))
 105                          (vars (append vars (list #'rest-arg)))
 106                          ((t ...) (generate-temporaries vars))
 107                          ((i ...) inits))
 108              #'(let ((t (lambda vars i))
 109                      ...)
 110                  (apply (lambda vars b0 b1 ...)
 111                         (or (parse-lambda-case '(0 n n n+1 #f '())
 112                                                (list t ...)
 113                                                #f
 114                                                rest-arg)
 115                             (error "sth" rest-arg)))))))))))
 116
 117 (define-syntax let-optional*
 118   (lambda (x)
 119     (syntax-case x ()
 120       ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
 121        (call-with-values (lambda () (vars&inits #'(binding ...)))
 122          (lambda (vars inits)
 123            (with-syntax ((n (length vars))
 124                          (n+1 (1+ (length vars)))
 125                          (vars (append vars (list #'rest-arg)))
 126                          ((i ...) inits))
 127              #'(apply (lambda vars b0 b1 ...)
 128                       (or (parse-lambda-case '(0 n n n+1 #f '())
 129                                              (list (lambda vars i) ...)
 130                                              #f
 131                                              rest-arg)
 132                           (error "sth" rest-arg))))))))))
 133
 134
 135 ;; let-keywords rest-arg allow-other-keys? (binding ...) . body
 136 ;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
 137 ;;   macros used to bind keyword arguments
 138 ;;
 139 ;; These macros pick out keyword arguments from rest-arg, but do not
 140 ;; modify it. This is consistent at least with Common Lisp, which
 141 ;; duplicates keyword args in the rest arg. More explanation of what
 142 ;; keyword arguments in a lambda list look like can be found below in
 143 ;; the documentation for lambda*.  Bindings can have the same form as
 144 ;; for let-optional. If allow-other-keys? is false, an error will be
 145 ;; thrown if anything that looks like a keyword argument but does not
 146 ;; match a known keyword parameter will result in an error.
 147 ;;
 148
 149
 150 (define-syntax let-keywords
 151   (lambda (x)
 152     (syntax-case x ()
 153       ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
 154        (call-with-values (lambda () (vars&inits #'(binding ...)))
 155          (lambda (vars inits)
 156            (with-syntax ((n (length vars))
 157                          (vars vars)
 158                          ((kw ...) (map symbol->keyword
 159                                         (map syntax->datum vars)))
 160                          ((idx ...) (iota (length vars)))
 161                          ((t ...) (generate-temporaries vars))
 162                          ((i ...) inits))
 163              #'(let ((t (lambda vars i))
 164                      ...)
 165                  (apply (lambda vars b0 b1 ...)
 166                         (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
 167                                                (list t ...)
 168                                                #f
 169                                                rest-arg)
 170                             (error "sth" rest-arg))))))))
 171       ((_ rest-arg aok (binding ...) b0 b1 ...)
 172        #'(let ((r rest-arg))
 173            (let-keywords r aok (binding ...) b0 b1 ...))))))
 174
 175 (define-syntax let-keywords*
 176   (lambda (x)
 177     (syntax-case x ()
 178       ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
 179        (call-with-values (lambda () (vars&inits #'(binding ...)))
 180          (lambda (vars inits)
 181            (with-syntax ((n (length vars))
 182                          (vars vars)
 183                          ((kw ...) (map symbol->keyword
 184                                         (map syntax->datum vars)))
 185                          ((idx ...) (iota (length vars)))
 186                          ((i ...) inits))
 187              #'(apply (lambda vars b0 b1 ...)
 188                       (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
 189                                              (list (lambda vars i) ...)
 190                                              #f
 191                                              rest-arg)
 192                           (error "sth" rest-arg)))))))
 193       ((_ rest-arg aok (binding ...) b0 b1 ...)
 194        #'(let ((r rest-arg))
 195            (let-keywords* r aok (binding ...) b0 b1 ...))))))
 196
 197 ;; lambda* args . body
 198 ;;   lambda extended for optional and keyword arguments
 199 ;;
 200 ;; lambda* creates a procedure that takes optional arguments. These
 201 ;; are specified by putting them inside brackets at the end of the
 202 ;; paramater list, but before any dotted rest argument. For example,
 203 ;;   (lambda* (a b #:optional c d . e) '())
 204 ;; creates a procedure with fixed arguments a and b, optional arguments c
 205 ;; and d, and rest argument e. If the optional arguments are omitted
 206 ;; in a call, the variables for them are bound to `#f'.
 207 ;;
 208 ;; lambda* can also take keyword arguments. For example, a procedure
 209 ;; defined like this:
 210 ;;   (lambda* (#:key xyzzy larch) '())
 211 ;; can be called with any of the argument lists (#:xyzzy 11)
 212 ;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
 213 ;; are given as keywords are bound to values.
 214 ;;
 215 ;; Optional and keyword arguments can also be given default values
 216 ;; which they take on when they are not present in a call, by giving a
 217 ;; two-item list in place of an optional argument, for example in:
 218 ;;   (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
 219 ;; foo is a fixed argument, bar is an optional argument with default
 220 ;; value 42, and baz is a keyword argument with default value 73.
 221 ;; Default value expressions are not evaluated unless they are needed
 222 ;; and until the procedure is called.
 223 ;;
 224 ;; lambda* now supports two more special parameter list keywords.
 225 ;;
 226 ;; lambda*-defined procedures now throw an error by default if a
 227 ;; keyword other than one of those specified is found in the actual
 228 ;; passed arguments. However, specifying #:allow-other-keys
 229 ;; immediately after the keyword argument declarations restores the
 230 ;; previous behavior of ignoring unknown keywords. lambda* also now
 231 ;; guarantees that if the same keyword is passed more than once, the
 232 ;; last one passed is the one that takes effect. For example,
 233 ;;   ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
 234 ;;    #:heads 37 #:tails 42 #:heads 99)
 235 ;; would result in (99 47) being displayed.
 236 ;;
 237 ;; #:rest is also now provided as a synonym for the dotted syntax rest
 238 ;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
 239 ;; all respects to lambda*. This is provided for more similarity to DSSSL,
 240 ;; MIT-Scheme and Kawa among others, as well as for refugees from other
 241 ;; Lisp dialects.
 242
 243
 244 ;; define* args . body
 245 ;; define*-public args . body
 246 ;;   define and define-public extended for optional and keyword arguments
 247 ;;
 248 ;; define* and define*-public support optional arguments with
 249 ;; a similar syntax to lambda*. Some examples:
 250 ;;   (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
 251 ;; defines a procedure x with a fixed argument y, an optional agument
 252 ;; a, another optional argument z with default value 3, a keyword argument w,
 253 ;; and a rest argument u.
 254 ;;
 255 ;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
 256 ;; in the same way as lambda*.
 257
 258 (define-syntax define*-public
 259   (syntax-rules ()
 260     ((_ (id . args) b0 b1 ...)
 261      (define-public id (lambda* args b0 b1 ...)))))
 262
 263
 264 ;; defmacro* name args . body
 265 ;; defmacro*-public args . body
 266 ;;   defmacro and defmacro-public extended for optional and keyword arguments
 267 ;;
 268 ;; These are just like defmacro and defmacro-public except that they
 269 ;; take lambda*-style extended paramter lists, where #:optional,
 270 ;; #:key, #:allow-other-keys and #:rest are allowed with the usual
 271 ;; semantics. Here is an example of a macro with an optional argument:
 272 ;;   (defmacro* transmorgify (a #:optional b)
 273
 274 (define-syntax defmacro*
 275   (syntax-rules ()
 276     ((_ (id . args) b0 b1 ...)
 277      (defmacro id (lambda* args b0 b1 ...)))))
 278 (define-syntax defmacro*-public
 279   (syntax-rules ()
 280     ((_ (id . args) b0 b1 ...)
 281      (begin
 282        (defmacro id (lambda* args b0 b1 ...))
 283        (export-syntax id)))))
 284
 285 ;;; Support for optional & keyword args with the interpreter.
 286 (define *uninitialized* (list 'uninitialized))
 287 (define (parse-lambda-case spec inits predicate args)
 288   (pmatch spec
 289     ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
 290      (define (req args prev tail n)
 291        (cond
 292         ((zero? n)
 293          (if prev (set-cdr! prev '()))
 294          (let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
 295            (opt (if prev (append! args slots-tail) slots-tail)
 296                 slots-tail tail nopt inits)))
 297         ((null? tail)
 298          #f) ;; fail
 299         (else
 300          (req args tail (cdr tail) (1- n)))))
 301      (define (opt slots slots-tail args-tail n inits)
 302        (cond
 303         ((zero? n)
 304          (rest-or-key slots slots-tail args-tail inits rest-idx))
 305         ((null? args-tail)
 306          (set-car! slots-tail (apply (car inits) slots))
 307          (opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
 308         (else
 309          (set-car! slots-tail (car args-tail))
 310          (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
 311      (define (rest-or-key slots slots-tail args-tail inits rest-idx)
 312        (cond
 313         (rest-idx
 314          ;; it has to be this way, vars are allocated in this order
 315          (set-car! slots-tail args-tail)
 316          (if (pair? kw-indices)
 317              (key slots (cdr slots-tail) args-tail inits)
 318              (rest-or-key slots (cdr slots-tail) '() inits #f)))
 319         ((pair? kw-indices)
 320          ;; fail early here, because once we're in keyword land we throw
 321          ;; errors instead of failing
 322          (and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
 323               (key slots slots-tail args-tail inits)))
 324         ((pair? args-tail)
 325          #f) ;; fail
 326         (else
 327          (pred slots))))
 328      (define (key slots slots-tail args-tail inits)
 329        (cond
 330         ((null? args-tail)
 331          (if (null? inits)
 332              (pred slots)
 333              (begin
 334                (if (eq? (car slots-tail) *uninitialized*)
 335                    (set-car! slots-tail (apply (car inits) slots)))
 336                (key slots (cdr slots-tail) '() (cdr inits)))))
 337         ((not (keyword? (car args-tail)))
 338          (if rest-idx
 339              ;; no error checking, everything goes to the rest..
 340              (key slots slots-tail '() inits)
 341              (error "bad keyword argument list" args-tail)))
 342         ((and (keyword? (car args-tail))
 343               (pair? (cdr args-tail))
 344               (assq-ref kw-indices (car args-tail)))
 345          => (lambda (i)
 346               (list-set! slots i (cadr args-tail))
 347               (key slots slots-tail (cddr args-tail) inits)))
 348         ((and (keyword? (car args-tail))
 349               (pair? (cdr args-tail))
 350               allow-other-keys?)
 351          (key slots slots-tail (cddr args-tail) inits))
 352         (else (error "unrecognized keyword" args-tail))))
 353      (define (pred slots)
 354        (cond
 355         (predicate
 356          (if (apply predicate slots)
 357              slots
 358              #f))
 359         (else slots)))
 360      (let ((args (list-copy args)))
 361        (req args #f args nreq)))
 362     (else (error "unexpected spec" spec))))