| 1 | ;;;; optargs.scm -- support for optional arguments |
| 2 | ;;;; |
| 3 | ;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010, 2011 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 | rest-arg) |
| 114 | (error "sth" rest-arg))))))))))) |
| 115 | |
| 116 | (define-syntax let-optional* |
| 117 | (lambda (x) |
| 118 | (syntax-case x () |
| 119 | ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg) |
| 120 | (call-with-values (lambda () (vars&inits #'(binding ...))) |
| 121 | (lambda (vars inits) |
| 122 | (with-syntax ((n (length vars)) |
| 123 | (n+1 (1+ (length vars))) |
| 124 | (vars (append vars (list #'rest-arg))) |
| 125 | ((i ...) inits)) |
| 126 | #'(apply (lambda vars b0 b1 ...) |
| 127 | (or (parse-lambda-case '(0 n n n+1 #f '()) |
| 128 | (list (lambda vars i) ...) |
| 129 | rest-arg) |
| 130 | (error "sth" rest-arg)))))))))) |
| 131 | |
| 132 | |
| 133 | ;; let-keywords rest-arg allow-other-keys? (binding ...) . body |
| 134 | ;; let-keywords* rest-arg allow-other-keys? (binding ...) . body |
| 135 | ;; macros used to bind keyword arguments |
| 136 | ;; |
| 137 | ;; These macros pick out keyword arguments from rest-arg, but do not |
| 138 | ;; modify it. This is consistent at least with Common Lisp, which |
| 139 | ;; duplicates keyword args in the rest arg. More explanation of what |
| 140 | ;; keyword arguments in a lambda list look like can be found below in |
| 141 | ;; the documentation for lambda*. Bindings can have the same form as |
| 142 | ;; for let-optional. If allow-other-keys? is false, an error will be |
| 143 | ;; thrown if anything that looks like a keyword argument but does not |
| 144 | ;; match a known keyword parameter will result in an error. |
| 145 | ;; |
| 146 | |
| 147 | |
| 148 | (define-syntax let-keywords |
| 149 | (lambda (x) |
| 150 | (syntax-case x () |
| 151 | ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg) |
| 152 | (call-with-values (lambda () (vars&inits #'(binding ...))) |
| 153 | (lambda (vars inits) |
| 154 | (with-syntax ((n (length vars)) |
| 155 | (vars vars) |
| 156 | (ivars (generate-temporaries vars)) |
| 157 | ((kw ...) (map symbol->keyword |
| 158 | (map syntax->datum vars))) |
| 159 | ((idx ...) (iota (length vars))) |
| 160 | ((t ...) (generate-temporaries vars)) |
| 161 | ((i ...) inits)) |
| 162 | #'(let ((t (lambda ivars i)) |
| 163 | ...) |
| 164 | (apply (lambda vars b0 b1 ...) |
| 165 | (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...)) |
| 166 | (list t ...) |
| 167 | rest-arg) |
| 168 | (error "sth" rest-arg)))))))) |
| 169 | ((_ rest-arg aok (binding ...) b0 b1 ...) |
| 170 | #'(let ((r rest-arg)) |
| 171 | (let-keywords r aok (binding ...) b0 b1 ...)))))) |
| 172 | |
| 173 | (define-syntax let-keywords* |
| 174 | (lambda (x) |
| 175 | (syntax-case x () |
| 176 | ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg) |
| 177 | (call-with-values (lambda () (vars&inits #'(binding ...))) |
| 178 | (lambda (vars inits) |
| 179 | (with-syntax ((n (length vars)) |
| 180 | (vars vars) |
| 181 | ((kw ...) (map symbol->keyword |
| 182 | (map syntax->datum vars))) |
| 183 | ((idx ...) (iota (length vars))) |
| 184 | ((i ...) inits)) |
| 185 | #'(apply (lambda vars b0 b1 ...) |
| 186 | (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...)) |
| 187 | (list (lambda vars i) ...) |
| 188 | rest-arg) |
| 189 | (error "sth" rest-arg))))))) |
| 190 | ((_ rest-arg aok (binding ...) b0 b1 ...) |
| 191 | #'(let ((r rest-arg)) |
| 192 | (let-keywords* r aok (binding ...) b0 b1 ...)))))) |
| 193 | |
| 194 | ;; lambda* args . body |
| 195 | ;; lambda extended for optional and keyword arguments |
| 196 | ;; |
| 197 | ;; lambda* creates a procedure that takes optional arguments. These |
| 198 | ;; are specified by putting them inside brackets at the end of the |
| 199 | ;; paramater list, but before any dotted rest argument. For example, |
| 200 | ;; (lambda* (a b #:optional c d . e) '()) |
| 201 | ;; creates a procedure with fixed arguments a and b, optional arguments c |
| 202 | ;; and d, and rest argument e. If the optional arguments are omitted |
| 203 | ;; in a call, the variables for them are bound to `#f'. |
| 204 | ;; |
| 205 | ;; lambda* can also take keyword arguments. For example, a procedure |
| 206 | ;; defined like this: |
| 207 | ;; (lambda* (#:key xyzzy larch) '()) |
| 208 | ;; can be called with any of the argument lists (#:xyzzy 11) |
| 209 | ;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments |
| 210 | ;; are given as keywords are bound to values. |
| 211 | ;; |
| 212 | ;; Optional and keyword arguments can also be given default values |
| 213 | ;; which they take on when they are not present in a call, by giving a |
| 214 | ;; two-item list in place of an optional argument, for example in: |
| 215 | ;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz)) |
| 216 | ;; foo is a fixed argument, bar is an optional argument with default |
| 217 | ;; value 42, and baz is a keyword argument with default value 73. |
| 218 | ;; Default value expressions are not evaluated unless they are needed |
| 219 | ;; and until the procedure is called. |
| 220 | ;; |
| 221 | ;; lambda* now supports two more special parameter list keywords. |
| 222 | ;; |
| 223 | ;; lambda*-defined procedures now throw an error by default if a |
| 224 | ;; keyword other than one of those specified is found in the actual |
| 225 | ;; passed arguments. However, specifying #:allow-other-keys |
| 226 | ;; immediately after the keyword argument declarations restores the |
| 227 | ;; previous behavior of ignoring unknown keywords. lambda* also now |
| 228 | ;; guarantees that if the same keyword is passed more than once, the |
| 229 | ;; last one passed is the one that takes effect. For example, |
| 230 | ;; ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails))) |
| 231 | ;; #:heads 37 #:tails 42 #:heads 99) |
| 232 | ;; would result in (99 47) being displayed. |
| 233 | ;; |
| 234 | ;; #:rest is also now provided as a synonym for the dotted syntax rest |
| 235 | ;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in |
| 236 | ;; all respects to lambda*. This is provided for more similarity to DSSSL, |
| 237 | ;; MIT-Scheme and Kawa among others, as well as for refugees from other |
| 238 | ;; Lisp dialects. |
| 239 | |
| 240 | |
| 241 | ;; define* args . body |
| 242 | ;; define*-public args . body |
| 243 | ;; define and define-public extended for optional and keyword arguments |
| 244 | ;; |
| 245 | ;; define* and define*-public support optional arguments with |
| 246 | ;; a similar syntax to lambda*. Some examples: |
| 247 | ;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u))) |
| 248 | ;; defines a procedure x with a fixed argument y, an optional agument |
| 249 | ;; a, another optional argument z with default value 3, a keyword argument w, |
| 250 | ;; and a rest argument u. |
| 251 | ;; |
| 252 | ;; Of course, define*[-public] also supports #:rest and #:allow-other-keys |
| 253 | ;; in the same way as lambda*. |
| 254 | |
| 255 | (define-syntax define*-public |
| 256 | (lambda (x) |
| 257 | (syntax-case x () |
| 258 | ((_ (id . args) b0 b1 ...) |
| 259 | #'(define-public id (lambda* args b0 b1 ...))) |
| 260 | ((_ id val) (identifier? #'id) |
| 261 | #'(define-public id val))))) |
| 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* transmogrify (a #:optional b) |
| 273 | |
| 274 | (define-syntax defmacro* |
| 275 | (lambda (x) |
| 276 | (syntax-case x () |
| 277 | ((_ id args doc b0 b1 ...) (string? (syntax->datum #'doc)) |
| 278 | #'(define-macro id doc (lambda* args b0 b1 ...))) |
| 279 | ((_ id args b0 b1 ...) |
| 280 | #'(define-macro id #f (lambda* args b0 b1 ...)))))) |
| 281 | (define-syntax-rule (defmacro*-public id args b0 b1 ...) |
| 282 | (begin |
| 283 | (defmacro* id args b0 b1 ...) |
| 284 | (export-syntax id))) |
| 285 | |
| 286 | ;;; Support for optional & keyword args with the interpreter. |
| 287 | (define *uninitialized* (list 'uninitialized)) |
| 288 | (define (parse-lambda-case spec inits args) |
| 289 | (pmatch spec |
| 290 | ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices) |
| 291 | (define (req args prev tail n) |
| 292 | (cond |
| 293 | ((zero? n) |
| 294 | (if prev (set-cdr! prev '())) |
| 295 | (let ((slots-tail (make-list (- nargs nreq) *uninitialized*))) |
| 296 | (opt (if prev (append! args slots-tail) slots-tail) |
| 297 | slots-tail tail nopt inits))) |
| 298 | ((null? tail) |
| 299 | #f) ;; fail |
| 300 | (else |
| 301 | (req args tail (cdr tail) (1- n))))) |
| 302 | (define (opt slots slots-tail args-tail n inits) |
| 303 | (cond |
| 304 | ((zero? n) |
| 305 | (rest-or-key slots slots-tail args-tail inits rest-idx)) |
| 306 | ((null? args-tail) |
| 307 | (set-car! slots-tail (apply (car inits) slots)) |
| 308 | (opt slots (cdr slots-tail) '() (1- n) (cdr inits))) |
| 309 | (else |
| 310 | (set-car! slots-tail (car args-tail)) |
| 311 | (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits))))) |
| 312 | (define (rest-or-key slots slots-tail args-tail inits rest-idx) |
| 313 | (cond |
| 314 | (rest-idx |
| 315 | ;; it has to be this way, vars are allocated in this order |
| 316 | (set-car! slots-tail args-tail) |
| 317 | (if (pair? kw-indices) |
| 318 | (permissive-keys slots (cdr slots-tail) args-tail inits) |
| 319 | (rest-or-key slots (cdr slots-tail) '() inits #f))) |
| 320 | ((pair? kw-indices) |
| 321 | ;; fail early here, because once we're in keyword land we throw |
| 322 | ;; errors instead of failing |
| 323 | (and (or (null? args-tail) rest-idx (keyword? (car args-tail))) |
| 324 | (key slots slots-tail args-tail inits))) |
| 325 | ((pair? args-tail) |
| 326 | #f) ;; fail |
| 327 | (else |
| 328 | slots))) |
| 329 | (define (permissive-keys slots slots-tail args-tail inits) |
| 330 | (cond |
| 331 | ((null? args-tail) |
| 332 | (if (null? inits) |
| 333 | slots |
| 334 | (begin |
| 335 | (if (eq? (car slots-tail) *uninitialized*) |
| 336 | (set-car! slots-tail (apply (car inits) slots))) |
| 337 | (permissive-keys slots (cdr slots-tail) '() (cdr inits))))) |
| 338 | ((not (keyword? (car args-tail))) |
| 339 | (permissive-keys slots slots-tail (cdr args-tail) inits)) |
| 340 | ((and (keyword? (car args-tail)) |
| 341 | (pair? (cdr args-tail)) |
| 342 | (assq-ref kw-indices (car args-tail))) |
| 343 | => (lambda (i) |
| 344 | (list-set! slots i (cadr args-tail)) |
| 345 | (permissive-keys slots slots-tail (cddr args-tail) inits))) |
| 346 | ((and (keyword? (car args-tail)) |
| 347 | (pair? (cdr args-tail)) |
| 348 | allow-other-keys?) |
| 349 | (permissive-keys slots slots-tail (cddr args-tail) inits)) |
| 350 | (else (scm-error 'keyword-argument-error #f "Unrecognized keyword" |
| 351 | '() args-tail)))) |
| 352 | (define (key slots slots-tail args-tail inits) |
| 353 | (cond |
| 354 | ((null? args-tail) |
| 355 | (if (null? inits) |
| 356 | slots |
| 357 | (begin |
| 358 | (if (eq? (car slots-tail) *uninitialized*) |
| 359 | (set-car! slots-tail (apply (car inits) slots))) |
| 360 | (key slots (cdr slots-tail) '() (cdr inits))))) |
| 361 | ((not (keyword? (car args-tail))) |
| 362 | (if rest-idx |
| 363 | ;; no error checking, everything goes to the rest.. |
| 364 | (key slots slots-tail '() inits) |
| 365 | (scm-error 'keyword-argument-error #f "Invalid keyword" |
| 366 | '() args-tail))) |
| 367 | ((and (keyword? (car args-tail)) |
| 368 | (pair? (cdr args-tail)) |
| 369 | (assq-ref kw-indices (car args-tail))) |
| 370 | => (lambda (i) |
| 371 | (list-set! slots i (cadr args-tail)) |
| 372 | (key slots slots-tail (cddr args-tail) inits))) |
| 373 | ((and (keyword? (car args-tail)) |
| 374 | (pair? (cdr args-tail)) |
| 375 | allow-other-keys?) |
| 376 | (key slots slots-tail (cddr args-tail) inits)) |
| 377 | (else (scm-error 'keyword-argument-error #f "Unrecognized keyword" |
| 378 | '() args-tail)))) |
| 379 | (let ((args (list-copy args))) |
| 380 | (req args #f args nreq))) |
| 381 | (else (error "unexpected spec" spec)))) |