Commit | Line | Data |
---|---|---|
08394899 MS |
1 | ;;;; optargs.scm -- support for optional arguments |
2 | ;;;; | |
cdd69fd8 | 3 | ;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004 Free Software Foundation, Inc. |
afab82bc | 4 | ;;;; |
73be1d9e MV |
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, | |
08394899 | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
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 | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
a482f2cc | 18 | ;;;; |
08394899 MS |
19 | ;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu> |
20 | ||
21 | \f | |
22 | ||
afab82bc | 23 | ;;; Commentary: |
08394899 MS |
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: | |
08394899 MS |
33 | ;;; let-optional |
34 | ;;; let-optional* | |
35 | ;;; let-keywords | |
36 | ;;; let-keywords* | |
37 | ;;; lambda* | |
38 | ;;; define* | |
afab82bc | 39 | ;;; define*-public |
08394899 MS |
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 | ;;; | |
dfb49627 | 47 | ;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? |
afab82bc | 48 | ;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]? |
dfb49627 | 49 | ;;; [[#:rest identifier]|[. identifier]]? |
08394899 | 50 | ;;; |
afab82bc | 51 | ;;; ext-var-decl ::= identifier | ( identifier expression ) |
08394899 MS |
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 | ||
afab82bc | 58 | ;;; Code: |
08394899 | 59 | |
1a179b03 MD |
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)) | |
08394899 | 69 | |
08394899 MS |
70 | ;; let-optional rest-arg (binding ...) . body |
71 | ;; let-optional* rest-arg (binding ...) . body | |
72 | ;; macros used to bind optional arguments | |
73 | ;; | |
296ff5e7 MV |
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 | |
08394899 MS |
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 | |
296ff5e7 | 82 | ;; or to `#f' if no default value was specified. rest-arg remains |
08394899 MS |
83 | ;; bound to whatever may have been left of rest-arg. |
84 | ;; | |
85 | ||
1a179b03 | 86 | (defmacro let-optional (REST-ARG BINDINGS . BODY) |
08394899 MS |
87 | (let-optional-template REST-ARG BINDINGS BODY 'let)) |
88 | ||
1a179b03 | 89 | (defmacro let-optional* (REST-ARG BINDINGS . BODY) |
08394899 MS |
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 | |
afab82bc | 103 | ;; for let-optional. If allow-other-keys? is false, an error will be |
08394899 MS |
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 | ||
1a179b03 | 109 | (defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY) |
08394899 MS |
110 | (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let)) |
111 | ||
1a179b03 | 112 | (defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY) |
08394899 MS |
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) | |
afab82bc | 119 | (let ((bindings (map (lambda (x) |
08394899 MS |
120 | (if (list? x) |
121 | x | |
296ff5e7 | 122 | (list x #f))) |
08394899 MS |
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) | |
cdd69fd8 | 128 | `(let () ,@BODY) |
08394899 | 129 | (let-o-k-template REST-ARG BINDINGS BODY let-type |
afab82bc TTN |
130 | (lambda (optional) |
131 | `(,(car optional) | |
08394899 MS |
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) | |
cdd69fd8 | 143 | `(let () ,@BODY) |
08394899 MS |
144 | (let* ((kb-list-gensym (gensym "kb:G")) |
145 | (bindfilter (lambda (key) | |
146 | `(,(car key) | |
147 | (cond | |
afab82bc | 148 | ((assq ',(car key) ,kb-list-gensym) |
08394899 | 149 | => cdr) |
afab82bc | 150 | (else |
08394899 | 151 | ,(cadr key))))))) |
afab82bc | 152 | `(let* ((ra->kbl ,rest-arg->keyword-binding-list) |
08394899 MS |
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) | |
61819670 | 162 | '() |
08394899 MS |
163 | (let loop ((first (car rest-arg)) |
164 | (rest (cdr rest-arg)) | |
61819670 | 165 | (accum '())) |
08394899 MS |
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)))) | |
afab82bc | 177 | ((not allow-other-keys?) |
08394899 MS |
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 | ||
08394899 MS |
186 | |
187 | ;; lambda* args . body | |
188 | ;; lambda extended for optional and keyword arguments | |
afab82bc | 189 | ;; |
08394899 MS |
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, | |
dfb49627 | 193 | ;; (lambda* (a b #:optional c d . e) '()) |
08394899 MS |
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 | |
296ff5e7 | 196 | ;; in a call, the variables for them are bound to `#f'. |
08394899 MS |
197 | ;; |
198 | ;; lambda* can also take keyword arguments. For example, a procedure | |
199 | ;; defined like this: | |
dfb49627 | 200 | ;; (lambda* (#:key xyzzy larch) '()) |
08394899 MS |
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: | |
afab82bc | 208 | ;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz)) |
08394899 MS |
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 | |
afab82bc | 212 | ;; and until the procedure is called. |
08394899 MS |
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 | |
dfb49627 | 218 | ;; passed arguments. However, specifying #:allow-other-keys |
b4ad0dda | 219 | ;; immediately after the keyword argument declarations restores the |
08394899 MS |
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, | |
dfb49627 | 223 | ;; ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails))) |
08394899 MS |
224 | ;; #:heads 37 #:tails 42 #:heads 99) |
225 | ;; would result in (99 47) being displayed. | |
226 | ;; | |
dfb49627 MV |
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 | |
08394899 MS |
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 | ||
1a179b03 | 234 | (defmacro lambda* (ARGLIST . BODY) |
afab82bc | 235 | (parse-arglist |
08394899 MS |
236 | ARGLIST |
237 | (lambda (non-optional-args optionals keys aok? rest-arg) | |
4a69c751 | 238 | ;; Check for syntax errors. |
08394899 MS |
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. | |
4a69c751 TTN |
248 | (let ((rest-gensym (or rest-arg (gensym "lambda*:G"))) |
249 | (lambda-gensym (gensym "lambda*:L"))) | |
08394899 | 250 | (if (not (and (null? optionals) (null? keys))) |
4a69c751 TTN |
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) | |
afab82bc | 278 | `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '())) |
08394899 MS |
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) | |
afab82bc | 288 | (or (symbol? obj) |
08394899 MS |
289 | (and (list? obj) (= 2 (length obj)) (symbol? (car obj))))) |
290 | ||
2a052066 MV |
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 | ||
08394899 MS |
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)) | |
afab82bc | 303 | (error (with-output-to-string |
08394899 | 304 | (lambda () |
afab82bc | 305 | (map display `(,val |
08394899 MS |
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 | |
dfb49627 | 311 | #:optional arglist |
08394899 MS |
312 | (lambda (before after split?) |
313 | (if (and split? (null? after)) | |
dfb49627 | 314 | (error "#:optional specified but no optional arguments declared.") |
08394899 MS |
315 | (cont before after keys aok? rest))))) |
316 | (define (parse-keys arglist rest cont) | |
afab82bc | 317 | (split-list-at |
dfb49627 | 318 | #:allow-other-keys arglist |
08394899 MS |
319 | (lambda (aok-before aok-after aok-split?) |
320 | (if (and aok-split? (not (null? aok-after))) | |
dfb49627 | 321 | (error "#:allow-other-keys not at end of keyword argument declarations.") |
afab82bc | 322 | (split-list-at |
dfb49627 | 323 | #:key aok-before |
08394899 | 324 | (lambda (key-before key-after key-split?) |
afab82bc | 325 | (cond |
08394899 | 326 | ((and aok-split? (not key-split?)) |
dfb49627 | 327 | (error "#:allow-other-keys specified but no keyword arguments declared.")) |
afab82bc | 328 | (key-split? |
08394899 | 329 | (cond |
dfb49627 MV |
330 | ((null? key-after) (error "#:key specified but no keyword arguments declared.")) |
331 | ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments.")) | |
08394899 MS |
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) | |
afab82bc | 335 | (cond |
fcdd6672 | 336 | ((null? arglist) (cont '() '() '() #f #f)) |
08394899 MS |
337 | ((not (pair? arglist)) (cont '() '() '() #f arglist)) |
338 | ((not (list? arglist)) | |
2a052066 | 339 | (let* ((copy (improper-list-copy arglist)) |
08394899 MS |
340 | (lp (last-pair copy)) |
341 | (ra (cdr lp))) | |
342 | (set-cdr! lp '()) | |
dfb49627 MV |
343 | (if (memq #:rest copy) |
344 | (error "Cannot specify both #:rest and dotted rest argument.") | |
08394899 | 345 | (parse-keys copy ra cont)))) |
afab82bc TTN |
346 | (else (split-list-at |
347 | #:rest arglist | |
08394899 MS |
348 | (lambda (before after split?) |
349 | (if split? | |
350 | (case (length after) | |
dfb49627 | 351 | ((0) (error "#:rest not followed by argument.")) |
08394899 | 352 | ((1) (parse-keys before (car after) cont)) |
dfb49627 | 353 | (else (error "#:rest argument must be declared last."))) |
08394899 MS |
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: | |
dfb49627 | 367 | ;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u))) |
08394899 MS |
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. | |
dfb49627 | 371 | ;; (define-public* ((foo #:optional bar) #:optional baz) '()) |
08394899 MS |
372 | ;; This illustrates currying. A procedure foo is defined, which, |
373 | ;; when called with an optional argument bar, returns a procedure that | |
afab82bc | 374 | ;; takes an optional argument baz. |
08394899 | 375 | ;; |
dfb49627 | 376 | ;; Of course, define*[-public] also supports #:rest and #:allow-other-keys |
08394899 MS |
377 | ;; in the same way as lambda*. |
378 | ||
1a179b03 | 379 | (defmacro define* (ARGLIST . BODY) |
08394899 MS |
380 | (define*-guts 'define ARGLIST BODY)) |
381 | ||
1a179b03 | 382 | (defmacro define*-public (ARGLIST . BODY) |
08394899 MS |
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 | |
afab82bc | 406 | ;; |
08394899 | 407 | ;; These are just like defmacro and defmacro-public except that they |
dfb49627 MV |
408 | ;; take lambda*-style extended paramter lists, where #:optional, |
409 | ;; #:key, #:allow-other-keys and #:rest are allowed with the usual | |
08394899 | 410 | ;; semantics. Here is an example of a macro with an optional argument: |
dfb49627 | 411 | ;; (defmacro* transmorgify (a #:optional b) |
08394899 | 412 | |
1a179b03 | 413 | (defmacro defmacro* (NAME ARGLIST . BODY) |
08394899 MS |
414 | (defmacro*-guts 'define NAME ARGLIST BODY)) |
415 | ||
1a179b03 | 416 | (defmacro defmacro*-public (NAME ARGLIST . BODY) |
08394899 MS |
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)))) | |
afab82bc TTN |
424 | |
425 | ;;; optargs.scm ends here |