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