scm: Fix psyntax/keyword/optargs interaction bug.
[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:" first)
177                     (next (cons (cons (keyword->symbol first)
178                                       (car rest)) accum))))
179                ((not allow-other-keys?)
180                 (error "Unknown keyword in arguments:" first))
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))))