ice-9/optargs.scm

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