guile18/ice-9/optargs.scm

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