ice-9/optargs.scm

   1 ;;;; optargs.scm -- support for optional arguments
   2 ;;;;
   3 ;;;;    Copyright (C) 1997, 1998, 1999, 2001 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program 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
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 ;;;; As a special exception, the Free Software Foundation gives permission
  21 ;;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;;
  23 ;;;; The exception is that, if you link the GUILE library with other files
  24 ;;;; to produce an executable, this does not by itself cause the
  25 ;;;; resulting executable to be covered by the GNU General Public License.
  26 ;;;; Your use of that executable is in no way restricted on account of
  27 ;;;; linking the GUILE library code into it.
  28 ;;;;
  29 ;;;; This exception does not however invalidate any other reasons why
  30 ;;;; the executable file might be covered by the GNU General Public License.
  31 ;;;;
  32 ;;;; This exception applies only to the code released by the
  33 ;;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;;; code from other Free Software Foundation releases into a copy of
  35 ;;;; GUILE, as the General Public License permits, the exception does
  36 ;;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;;; anyone as to the status of such modified files, you must delete
  38 ;;;; this exception notice from them.
  39 ;;;;
  40 ;;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;;; whether to permit this exception to apply to your modifications.
  42 ;;;; If you do not wish that, delete this exception notice.
  43 ;;;;
  44 ;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
  45
  46 \f
  47
  48 ;;; Commentary:
  49
  50 ;;; {Optional Arguments}
  51 ;;;
  52 ;;; The C interface for creating Guile procedures has a very handy
  53 ;;; "optional argument" feature. This module attempts to provide
  54 ;;; similar functionality for procedures defined in Scheme with
  55 ;;; a convenient and attractive syntax.
  56 ;;;
  57 ;;; exported macros are:
  58 ;;;   let-optional
  59 ;;;   let-optional*
  60 ;;;   let-keywords
  61 ;;;   let-keywords*
  62 ;;;   lambda*
  63 ;;;   define*
  64 ;;;   define*-public
  65 ;;;   defmacro*
  66 ;;;   defmacro*-public
  67 ;;;
  68 ;;;
  69 ;;; Summary of the lambda* extended parameter list syntax (brackets
  70 ;;; are used to indicate grouping only):
  71 ;;;
  72 ;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
  73 ;;;   [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
  74 ;;;   [[#:rest identifier]|[. identifier]]?
  75 ;;;
  76 ;;; ext-var-decl ::= identifier | ( identifier expression )
  77 ;;;
  78 ;;; The characters `*', `+' and `?' are not to be taken literally; they
  79 ;;; mean respectively, zero or more occurences, one or more occurences,
  80 ;;; and one or zero occurences.
  81 ;;;
  82
  83 ;;; Code:
  84
  85 (define-module (ice-9 optargs))
  86
  87 ;; let-optional rest-arg (binding ...) . body
  88 ;; let-optional* rest-arg (binding ...) . body
  89 ;;   macros used to bind optional arguments
  90 ;;
  91 ;; These two macros give you an optional argument interface that is
  92 ;; very "Schemey" and introduces no fancy syntax. They are compatible
  93 ;; with the scsh macros of the same name, but are slightly
  94 ;; extended. Each of binding may be of one of the forms <var> or
  95 ;; (<var> <default-value>). rest-arg should be the rest-argument of
  96 ;; the procedures these are used from. The items in rest-arg are
  97 ;; sequentially bound to the variable namess are given. When rest-arg
  98 ;; runs out, the remaining vars are bound either to the default values
  99 ;; or to `#f' if no default value was specified. rest-arg remains
 100 ;; bound to whatever may have been left of rest-arg.
 101 ;;
 102
 103 (defmacro-public let-optional (REST-ARG BINDINGS . BODY)
 104   (let-optional-template REST-ARG BINDINGS BODY 'let))
 105
 106 (defmacro-public let-optional* (REST-ARG BINDINGS . BODY)
 107   (let-optional-template REST-ARG BINDINGS BODY 'let*))
 108
 109
 110
 111 ;; let-keywords rest-arg allow-other-keys? (binding ...) . body
 112 ;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
 113 ;;   macros used to bind keyword arguments
 114 ;;
 115 ;; These macros pick out keyword arguments from rest-arg, but do not
 116 ;; modify it. This is consistent at least with Common Lisp, which
 117 ;; duplicates keyword args in the rest arg. More explanation of what
 118 ;; keyword arguments in a lambda list look like can be found below in
 119 ;; the documentation for lambda*.  Bindings can have the same form as
 120 ;; for let-optional. If allow-other-keys? is false, an error will be
 121 ;; thrown if anything that looks like a keyword argument but does not
 122 ;; match a known keyword parameter will result in an error.
 123 ;;
 124
 125
 126 (defmacro-public let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
 127   (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
 128
 129 (defmacro-public let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
 130   (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
 131
 132
 133 ;; some utility procedures for implementing the various let-forms.
 134
 135 (define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
 136   (let ((bindings (map (lambda (x)
 137                          (if (list? x)
 138                              x
 139                              (list x #f)))
 140                        BINDINGS)))
 141     `(,let-type ,(map proc bindings) ,@BODY)))
 142
 143 (define (let-optional-template REST-ARG BINDINGS BODY let-type)
 144     (if (null? BINDINGS)
 145         `(begin ,@BODY)
 146         (let-o-k-template REST-ARG BINDINGS BODY let-type
 147                           (lambda (optional)
 148                             `(,(car optional)
 149                               (cond
 150                                ((not (null? ,REST-ARG))
 151                                 (let ((result (car ,REST-ARG)))
 152                                   ,(list 'set! REST-ARG
 153                                          `(cdr ,REST-ARG))
 154                                   result))
 155                                (else
 156                                 ,(cadr optional))))))))
 157
 158 (define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
 159     (if (null? BINDINGS)
 160         `(begin ,@BODY)
 161         (let* ((kb-list-gensym (gensym "kb:G"))
 162                (bindfilter (lambda (key)
 163                              `(,(car key)
 164                                (cond
 165                                 ((assq ',(car key) ,kb-list-gensym)
 166                                  => cdr)
 167                                 (else
 168                                  ,(cadr key)))))))
 169           `(let* ((ra->kbl ,rest-arg->keyword-binding-list)
 170                   (,kb-list-gensym (ra->kbl ,REST-ARG ',(map
 171                                                          (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
 172                                                          BINDINGS)
 173                                             ,ALLOW-OTHER-KEYS?)))
 174              ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
 175
 176
 177 (define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
 178   (if (null? rest-arg)
 179       '()
 180       (let loop ((first (car rest-arg))
 181                  (rest (cdr rest-arg))
 182                  (accum '()))
 183         (let ((next (lambda (a)
 184                       (if (null? (cdr rest))
 185                           a
 186                           (loop (cadr rest) (cddr rest) a)))))
 187           (if (keyword? first)
 188               (cond
 189                ((memq first keywords)
 190                 (if (null? rest)
 191                     (error "Keyword argument has no value.")
 192                     (next (cons (cons (keyword->symbol first)
 193                                       (car rest)) accum))))
 194                ((not allow-other-keys?)
 195                 (error "Unknown keyword in arguments."))
 196                (else (if (null? rest)
 197                          accum
 198                          (next accum))))
 199               (if (null? rest)
 200                   accum
 201                   (loop (car rest) (cdr rest) accum)))))))
 202
 203 ;; This is a reader extension to support the (deprecated) use of
 204 ;; "#&optional" instead of "#:optional"
 205
 206 (read-hash-extend #\& (lambda (c port)
 207                         (issue-deprecation-warning
 208                          "`#&' is deprecated, use `#:' instead.")
 209                         (case (read port)
 210                           ((optional) #:optional)
 211                           ((key) #:key)
 212                           ((rest) #:rest)
 213                           ((allow-other-keys) #:allow-other-keys)
 214                           (else (error "Bad #& value.")))))
 215
 216
 217 ;; lambda* args . body
 218 ;;   lambda extended for optional and keyword arguments
 219 ;;
 220 ;; lambda* creates a procedure that takes optional arguments. These
 221 ;; are specified by putting them inside brackets at the end of the
 222 ;; paramater list, but before any dotted rest argument. For example,
 223 ;;   (lambda* (a b #:optional c d . e) '())
 224 ;; creates a procedure with fixed arguments a and b, optional arguments c
 225 ;; and d, and rest argument e. If the optional arguments are omitted
 226 ;; in a call, the variables for them are bound to `#f'.
 227 ;;
 228 ;; lambda* can also take keyword arguments. For example, a procedure
 229 ;; defined like this:
 230 ;;   (lambda* (#:key xyzzy larch) '())
 231 ;; can be called with any of the argument lists (#:xyzzy 11)
 232 ;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
 233 ;; are given as keywords are bound to values.
 234 ;;
 235 ;; Optional and keyword arguments can also be given default values
 236 ;; which they take on when they are not present in a call, by giving a
 237 ;; two-item list in place of an optional argument, for example in:
 238 ;;   (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
 239 ;; foo is a fixed argument, bar is an optional argument with default
 240 ;; value 42, and baz is a keyword argument with default value 73.
 241 ;; Default value expressions are not evaluated unless they are needed
 242 ;; and until the procedure is called.
 243 ;;
 244 ;; lambda* now supports two more special parameter list keywords.
 245 ;;
 246 ;; lambda*-defined procedures now throw an error by default if a
 247 ;; keyword other than one of those specified is found in the actual
 248 ;; passed arguments. However, specifying #:allow-other-keys
 249 ;; immediately after the keyword argument declarations restores the
 250 ;; previous behavior of ignoring unknown keywords. lambda* also now
 251 ;; guarantees that if the same keyword is passed more than once, the
 252 ;; last one passed is the one that takes effect. For example,
 253 ;;   ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
 254 ;;    #:heads 37 #:tails 42 #:heads 99)
 255 ;; would result in (99 47) being displayed.
 256 ;;
 257 ;; #:rest is also now provided as a synonym for the dotted syntax rest
 258 ;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
 259 ;; all respects to lambda*. This is provided for more similarity to DSSSL,
 260 ;; MIT-Scheme and Kawa among others, as well as for refugees from other
 261 ;; Lisp dialects.
 262
 263
 264 (defmacro-public lambda* (ARGLIST . BODY)
 265   (parse-arglist
 266    ARGLIST
 267    (lambda (non-optional-args optionals keys aok? rest-arg)
 268      ; Check for syntax errors.
 269      (if (not (every? symbol? non-optional-args))
 270          (error "Syntax error in fixed argument declaration."))
 271      (if (not (every? ext-decl? optionals))
 272          (error "Syntax error in optional argument declaration."))
 273      (if (not (every? ext-decl? keys))
 274          (error "Syntax error in keyword argument declaration."))
 275      (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
 276          (error "Syntax error in rest argument declaration."))
 277      ;; generate the code.
 278      (let ((rest-gensym (or rest-arg (gensym "lambda*:G"))))
 279        (if (not (and (null? optionals) (null? keys)))
 280            `(lambda (,@non-optional-args . ,rest-gensym)
 281               ;; Make sure that if the proc had a docstring, we put it
 282               ;; here where it will be visible.
 283               ,@(if (and (not (null? BODY))
 284                          (string? (car BODY)))
 285                     (list (car BODY))
 286                     '())
 287               (let-optional*
 288                ,rest-gensym
 289                ,optionals
 290                (let-keywords* ,rest-gensym
 291                               ,aok?
 292                               ,keys
 293                               ,@(if (and (not rest-arg) (null? keys))
 294                                     `((if (not (null? ,rest-gensym))
 295                                           (error "Too many arguments.")))
 296                                     '())
 297                               (let ()
 298                                 ,@BODY))))
 299            `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
 300               ,@BODY))))))
 301
 302
 303 (define (every? pred lst)
 304   (or (null? lst)
 305       (and (pred (car lst))
 306            (every? pred (cdr lst)))))
 307
 308 (define (ext-decl? obj)
 309   (or (symbol? obj)
 310       (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
 311
 312 (define (parse-arglist arglist cont)
 313   (define (split-list-at val lst cont)
 314     (cond
 315      ((memq val lst)
 316       => (lambda (pos)
 317            (if (memq val (cdr pos))
 318                (error (with-output-to-string
 319                         (lambda ()
 320                           (map display `(,val
 321                                          " specified more than once in argument list.")))))
 322                (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
 323      (else (cont lst '() #f))))
 324   (define (parse-opt-and-fixed arglist keys aok? rest cont)
 325     (split-list-at
 326      #:optional arglist
 327      (lambda (before after split?)
 328        (if (and split? (null? after))
 329            (error "#:optional specified but no optional arguments declared.")
 330            (cont before after keys aok? rest)))))
 331   (define (parse-keys arglist rest cont)
 332     (split-list-at
 333      #:allow-other-keys arglist
 334      (lambda (aok-before aok-after aok-split?)
 335        (if (and aok-split? (not (null? aok-after)))
 336            (error "#:allow-other-keys not at end of keyword argument declarations.")
 337            (split-list-at
 338             #:key aok-before
 339             (lambda (key-before key-after key-split?)
 340               (cond
 341                ((and aok-split? (not key-split?))
 342                 (error "#:allow-other-keys specified but no keyword arguments declared."))
 343                (key-split?
 344                 (cond
 345                  ((null? key-after) (error "#:key specified but no keyword arguments declared."))
 346                  ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
 347                  (else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
 348                (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
 349   (define (parse-rest arglist cont)
 350     (cond
 351      ((null? arglist) (cont '() '() '() #f #f))
 352      ((not (pair? arglist)) (cont '() '() '() #f arglist))
 353      ((not (list? arglist))
 354           (let* ((copy (list-copy arglist))
 355                  (lp (last-pair copy))
 356                  (ra (cdr lp)))
 357             (set-cdr! lp '())
 358             (if (memq #:rest copy)
 359                 (error "Cannot specify both #:rest and dotted rest argument.")
 360                 (parse-keys copy ra cont))))
 361      (else (split-list-at
 362             #:rest arglist
 363             (lambda (before after split?)
 364               (if split?
 365                   (case (length after)
 366                     ((0) (error "#:rest not followed by argument."))
 367                     ((1) (parse-keys before (car after) cont))
 368                     (else (error "#:rest argument must be declared last.")))
 369                   (parse-keys before #f cont)))))))
 370
 371   (parse-rest arglist cont))
 372
 373
 374
 375 ;; define* args . body
 376 ;; define*-public args . body
 377 ;;   define and define-public extended for optional and keyword arguments
 378 ;;
 379 ;; define* and define*-public support optional arguments with
 380 ;; a similar syntax to lambda*. They also support arbitrary-depth
 381 ;; currying, just like Guile's define. Some examples:
 382 ;;   (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
 383 ;; defines a procedure x with a fixed argument y, an optional agument
 384 ;; a, another optional argument z with default value 3, a keyword argument w,
 385 ;; and a rest argument u.
 386 ;;   (define-public* ((foo #:optional bar) #:optional baz) '())
 387 ;; This illustrates currying. A procedure foo is defined, which,
 388 ;; when called with an optional argument bar, returns a procedure that
 389 ;; takes an optional argument baz.
 390 ;;
 391 ;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
 392 ;; in the same way as lambda*.
 393
 394 (defmacro-public define* (ARGLIST . BODY)
 395   (define*-guts 'define ARGLIST BODY))
 396
 397 (defmacro-public define*-public (ARGLIST . BODY)
 398   (define*-guts 'define-public ARGLIST BODY))
 399
 400 ;; The guts of define* and define*-public.
 401 (define (define*-guts DT ARGLIST BODY)
 402   (define (nest-lambda*s arglists)
 403     (if (null? arglists)
 404         BODY
 405         `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
 406   (define (define*-guts-helper ARGLIST arglists)
 407     (let ((first (car ARGLIST))
 408           (al (cons (cdr ARGLIST) arglists)))
 409       (if (symbol? first)
 410           `(,DT ,first ,@(nest-lambda*s al))
 411           (define*-guts-helper first al))))
 412   (if (symbol? ARGLIST)
 413       `(,DT ,ARGLIST ,@BODY)
 414       (define*-guts-helper ARGLIST '())))
 415
 416
 417
 418 ;; defmacro* name args . body
 419 ;; defmacro*-public args . body
 420 ;;   defmacro and defmacro-public extended for optional and keyword arguments
 421 ;;
 422 ;; These are just like defmacro and defmacro-public except that they
 423 ;; take lambda*-style extended paramter lists, where #:optional,
 424 ;; #:key, #:allow-other-keys and #:rest are allowed with the usual
 425 ;; semantics. Here is an example of a macro with an optional argument:
 426 ;;   (defmacro* transmorgify (a #:optional b)
 427
 428 (defmacro-public defmacro* (NAME ARGLIST . BODY)
 429   (defmacro*-guts 'define NAME ARGLIST BODY))
 430
 431 (defmacro-public defmacro*-public (NAME ARGLIST . BODY)
 432   (defmacro*-guts 'define-public NAME ARGLIST BODY))
 433
 434 ;; The guts of defmacro* and defmacro*-public
 435 (define (defmacro*-guts DT NAME ARGLIST BODY)
 436   `(,DT ,NAME
 437         (,(lambda (transformer) (defmacro:transformer transformer))
 438          (lambda* ,ARGLIST ,@BODY))))
 439
 440 ;;; optargs.scm ends here