Commit | Line | Data |
---|---|---|
08394899 MS |
1 | ;;;; optargs.scm -- support for optional arguments |
2 | ;;;; | |
e39bbe80 | 3 | ;;;; Copyright (C) 1997, 1998, 1999, 2001 Free Software Foundation, Inc. |
afab82bc | 4 | ;;;; |
08394899 MS |
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. | |
afab82bc | 9 | ;;;; |
08394899 MS |
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. | |
afab82bc | 14 | ;;;; |
08394899 MS |
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 | |
c6e23ea2 JB |
17 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
18 | ;;;; Boston, MA 02111-1307 USA | |
afab82bc | 19 | ;;;; |
a482f2cc MV |
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 | ;;;; | |
08394899 MS |
44 | ;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu> |
45 | ||
46 | \f | |
47 | ||
afab82bc | 48 | ;;; Commentary: |
08394899 MS |
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: | |
08394899 MS |
58 | ;;; let-optional |
59 | ;;; let-optional* | |
60 | ;;; let-keywords | |
61 | ;;; let-keywords* | |
62 | ;;; lambda* | |
63 | ;;; define* | |
afab82bc | 64 | ;;; define*-public |
08394899 MS |
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 | ;;; | |
dfb49627 | 72 | ;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? |
afab82bc | 73 | ;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]? |
dfb49627 | 74 | ;;; [[#:rest identifier]|[. identifier]]? |
08394899 | 75 | ;;; |
afab82bc | 76 | ;;; ext-var-decl ::= identifier | ( identifier expression ) |
08394899 MS |
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 | ||
afab82bc | 83 | ;;; Code: |
08394899 | 84 | |
afab82bc | 85 | (define-module (ice-9 optargs)) |
08394899 | 86 | |
08394899 MS |
87 | ;; let-optional rest-arg (binding ...) . body |
88 | ;; let-optional* rest-arg (binding ...) . body | |
89 | ;; macros used to bind optional arguments | |
90 | ;; | |
296ff5e7 MV |
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 | |
08394899 MS |
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 | |
296ff5e7 | 99 | ;; or to `#f' if no default value was specified. rest-arg remains |
08394899 MS |
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 | |
afab82bc | 120 | ;; for let-optional. If allow-other-keys? is false, an error will be |
08394899 MS |
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) | |
afab82bc | 136 | (let ((bindings (map (lambda (x) |
08394899 MS |
137 | (if (list? x) |
138 | x | |
296ff5e7 | 139 | (list x #f))) |
08394899 MS |
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 | |
afab82bc TTN |
147 | (lambda (optional) |
148 | `(,(car optional) | |
08394899 MS |
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 | |
afab82bc | 165 | ((assq ',(car key) ,kb-list-gensym) |
08394899 | 166 | => cdr) |
afab82bc | 167 | (else |
08394899 | 168 | ,(cadr key))))))) |
afab82bc | 169 | `(let* ((ra->kbl ,rest-arg->keyword-binding-list) |
08394899 MS |
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) | |
61819670 | 179 | '() |
08394899 MS |
180 | (let loop ((first (car rest-arg)) |
181 | (rest (cdr rest-arg)) | |
61819670 | 182 | (accum '())) |
08394899 MS |
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)))) | |
afab82bc | 194 | ((not allow-other-keys?) |
08394899 MS |
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 | ||
dfb49627 MV |
203 | ;; This is a reader extension to support the (deprecated) use of |
204 | ;; "#&optional" instead of "#:optional" | |
08394899 MS |
205 | |
206 | (read-hash-extend #\& (lambda (c port) | |
33485be9 MV |
207 | (issue-deprecation-warning |
208 | "`#&' is deprecated, use `#:' instead.") | |
08394899 | 209 | (case (read port) |
dfb49627 MV |
210 | ((optional) #:optional) |
211 | ((key) #:key) | |
212 | ((rest) #:rest) | |
b1ee756f | 213 | ((allow-other-keys) #:allow-other-keys) |
08394899 MS |
214 | (else (error "Bad #& value."))))) |
215 | ||
216 | ||
217 | ;; lambda* args . body | |
218 | ;; lambda extended for optional and keyword arguments | |
afab82bc | 219 | ;; |
08394899 MS |
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, | |
dfb49627 | 223 | ;; (lambda* (a b #:optional c d . e) '()) |
08394899 MS |
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 | |
296ff5e7 | 226 | ;; in a call, the variables for them are bound to `#f'. |
08394899 MS |
227 | ;; |
228 | ;; lambda* can also take keyword arguments. For example, a procedure | |
229 | ;; defined like this: | |
dfb49627 | 230 | ;; (lambda* (#:key xyzzy larch) '()) |
08394899 MS |
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: | |
afab82bc | 238 | ;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz)) |
08394899 MS |
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 | |
afab82bc | 242 | ;; and until the procedure is called. |
08394899 MS |
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 | |
dfb49627 | 248 | ;; passed arguments. However, specifying #:allow-other-keys |
b4ad0dda | 249 | ;; immediately after the keyword argument declarations restores the |
08394899 MS |
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, | |
dfb49627 | 253 | ;; ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails))) |
08394899 MS |
254 | ;; #:heads 37 #:tails 42 #:heads 99) |
255 | ;; would result in (99 47) being displayed. | |
256 | ;; | |
dfb49627 MV |
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 | |
08394899 MS |
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) | |
afab82bc | 265 | (parse-arglist |
08394899 MS |
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 | '()) | |
afab82bc | 287 | (let-optional* |
08394899 MS |
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 | '()) | |
1987c8ee MV |
297 | (let () |
298 | ,@BODY)))) | |
afab82bc | 299 | `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '())) |
08394899 MS |
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) | |
afab82bc | 309 | (or (symbol? obj) |
08394899 MS |
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)) | |
afab82bc | 318 | (error (with-output-to-string |
08394899 | 319 | (lambda () |
afab82bc | 320 | (map display `(,val |
08394899 MS |
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 | |
dfb49627 | 326 | #:optional arglist |
08394899 MS |
327 | (lambda (before after split?) |
328 | (if (and split? (null? after)) | |
dfb49627 | 329 | (error "#:optional specified but no optional arguments declared.") |
08394899 MS |
330 | (cont before after keys aok? rest))))) |
331 | (define (parse-keys arglist rest cont) | |
afab82bc | 332 | (split-list-at |
dfb49627 | 333 | #:allow-other-keys arglist |
08394899 MS |
334 | (lambda (aok-before aok-after aok-split?) |
335 | (if (and aok-split? (not (null? aok-after))) | |
dfb49627 | 336 | (error "#:allow-other-keys not at end of keyword argument declarations.") |
afab82bc | 337 | (split-list-at |
dfb49627 | 338 | #:key aok-before |
08394899 | 339 | (lambda (key-before key-after key-split?) |
afab82bc | 340 | (cond |
08394899 | 341 | ((and aok-split? (not key-split?)) |
dfb49627 | 342 | (error "#:allow-other-keys specified but no keyword arguments declared.")) |
afab82bc | 343 | (key-split? |
08394899 | 344 | (cond |
dfb49627 MV |
345 | ((null? key-after) (error "#:key specified but no keyword arguments declared.")) |
346 | ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments.")) | |
08394899 MS |
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) | |
afab82bc | 350 | (cond |
fcdd6672 | 351 | ((null? arglist) (cont '() '() '() #f #f)) |
08394899 MS |
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 '()) | |
dfb49627 MV |
358 | (if (memq #:rest copy) |
359 | (error "Cannot specify both #:rest and dotted rest argument.") | |
08394899 | 360 | (parse-keys copy ra cont)))) |
afab82bc TTN |
361 | (else (split-list-at |
362 | #:rest arglist | |
08394899 MS |
363 | (lambda (before after split?) |
364 | (if split? | |
365 | (case (length after) | |
dfb49627 | 366 | ((0) (error "#:rest not followed by argument.")) |
08394899 | 367 | ((1) (parse-keys before (car after) cont)) |
dfb49627 | 368 | (else (error "#:rest argument must be declared last."))) |
08394899 MS |
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: | |
dfb49627 | 382 | ;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u))) |
08394899 MS |
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. | |
dfb49627 | 386 | ;; (define-public* ((foo #:optional bar) #:optional baz) '()) |
08394899 MS |
387 | ;; This illustrates currying. A procedure foo is defined, which, |
388 | ;; when called with an optional argument bar, returns a procedure that | |
afab82bc | 389 | ;; takes an optional argument baz. |
08394899 | 390 | ;; |
dfb49627 | 391 | ;; Of course, define*[-public] also supports #:rest and #:allow-other-keys |
08394899 MS |
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 | |
afab82bc | 421 | ;; |
08394899 | 422 | ;; These are just like defmacro and defmacro-public except that they |
dfb49627 MV |
423 | ;; take lambda*-style extended paramter lists, where #:optional, |
424 | ;; #:key, #:allow-other-keys and #:rest are allowed with the usual | |
08394899 | 425 | ;; semantics. Here is an example of a macro with an optional argument: |
dfb49627 | 426 | ;; (defmacro* transmorgify (a #:optional b) |
08394899 MS |
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)))) | |
afab82bc TTN |
439 | |
440 | ;;; optargs.scm ends here |