Title
CHECKLAMBDA and CONDLAMBDA
Author
Joo ChurlSoo
Abstract
This SRFI introduces CHECKLAMBDA and CHECKLAMBDA*, each of which creates a
procedure that takes optional arguments and checks the states of actual
arguments, and another two macros, CONDLAMBDA and CONDLAMBDA* that return
different procedures according to the states of actual arguments as well as
the number of them.
Rationale
The CHECKLAMBDA reduces not only the clutter of various error conditionals by
checking actual arguments but also somewhat lengthy code by combining optional
argument handling methods such as LETOPTIONALS and LETKEYWORDS into a single
syntax. The optional parameters include not only positional fixed parameters
but also nonfixed named parameters using simple symbols as keywords without
introducing a new data type such as keyword object. The CONDLAMBDA can
reduce the clutter of procedures more precisely than CASELAMBDA of SRFI16 by
adding tests for the states of actual arguments to its formal argument list.
The CHECKLAMBDA* and CONDLAMBDA* are LET* equivalents corresponding to
CHECKLAMBDA and CONDLAMBDA.
Specification
The syntax is defined in the extended BNF of R5RS.
(checklambda )
(checklambda* )
>
 (* * *)
 (* * * )

 (+ * * . )
 (+ * * . )
 (+ * . )
 (+ * . )
 (+ . )
 (+ . )
>
 ( +)
> "opt" +
> "key" + *
>  ( *)
>  ( *)
 (( ))
 (( ) *)
> "cat"
> #f  #t  *
> "allowotherkeys"  "allownonkeys"
 "allowduplicatekeys"
>
>
>
Required variables correspond to identifiers that appear before any string
marker in . They determine the minimum arity of the resulting
procedure. Each required argument can take the form of a parenthesized
variable and s. The s are used to check the state of actual
argument. The required variables are bound to successive actual arguments
starting with the first actual argument. An error is signaled if there are
fewer actual arguments than required variables. When there are s, an
error is signaled if any of them returns a false value.
The fixed optional variables follow an "opt" marker in . They are
bound to the remaining actual arguments sequentially from left to right. Each
optional argument can take the form of a parenthesized variable, , and s. The is used if a value is not given at
the call site. The and s can be omitted with the
parentheses, in which case #f is the default. When there are s, they
are evaluated only when the variable is bound to an actual argument. If any
of them returns a false value, an error is signaled.
The named optional variables follow a "key" marker in . Like fixed
optional arguments, each named optional argument is specified as a
parenthesized variable name, , and s. The and s can be omitted with the parentheses, in which case #f is
the default value. The keyword used at a call site for the corresponding
variable has the same name as the variable. Another form of named optional
variables is specified as a double parenthesized variable name and a keyword,
to allow the name of the locally bound variable to differ from the keyword
used at call sites. When calling a function with named optional arguments,
the required argument (and all optional arguments, if specified) must be
followed by an even number of arguments. They are sequentially interpreted as
a series of pairs, where the first member of each pair is a keyword specifying
the variable name, and the second is the corresponding value. If there is no
actual argument for a particular keyword, the variable is bound to the result
of evaluating . When there are s, they are evaluated
only when the variable is bound to an actual argument. If any of them returns
a false value, an error is signaled.
The following namedoption/namedoptionmodifiers can be used to control
binding behaviour and error reporting when there are named optional variables.
named option modifier:
1. allowduplicatekeys  the keywordvalue list at the call site can
include duplicate values associated with same keyword, the first one is
used.
2. allowotherkeys  the keywordvalue sequence at the call site can
include keywords that are not listed in the keyword part of .
3. allownonkeys  the keywordvalue sequence at the call site can include
nonsymbols. All remaining variables including the variable at the site
are bound to the corresponding s.
#f  all of the above are forbidden (default). An error is signaled in each
case.
#t  all of the above are allowed. And the keywordvalue sequence at the
call site can include a single keyword at the end of an argument list.
When there is a "cat" option, the binding process is the same as above if
there are no s. When there are s, the process is changed: A
variable is temporarily bound to each of actual arguments (selected by keyword
in case of named optional arguments) sequentially from left to right, until
all s return true values, then the variable is finally bound to the
passed argument. If a variable is not bound to any of actual arguments, an
error is signaled in case of requried variables. In case of optional
variables, they are bound to the corresponding s instead of
signaling an error.
If dotted rest variable is given, it is bound to the remaining actual
arguments. When there are no named optional variables, an error is signaled
if dotted rest variable is not given in spite of the remaining actual
arguments. But when there are named optional variables, even though dotted
rest variable is not given, an error is not signaled if any option except #f
is given.
(condlambda +)
(condlambda* +)
> ( )
> (*)

 (+ . )
>
 ( +)
>
CONDLAMBDA is an extended form of CASELAMBDA of SRFI16. Like CASELAMBDA,
it returns a procedure of the first , the of which is
matched with the number of actual arguments. But if there are s and any
of them returns a false value, the subsequent is processed in spite
of the match. If no matches, an error is signaled. Each of
CONDLAMBDA* sees the values of the previous s of like
LET*.
Examples
(define check
(checklambda* (a
(b (number? b))
(c (number? c) (< b c))
(d (number? d))
"opt" (e #\e (char? e)) (f (+ b c) (number? f))
. g)
(list a b c d e f g)))
(check #\a 1 2 3) => (#\a 1 2 3 #\e 3 ())
(check #\a 2 1 3) => error
(check #\a 1 2 3 #\b) => (#\a 1 2 3 #\b 3 ())
(check #\a 1 2 3 4) => error
(check #\a 1 2 3 #\b 4 5) => (#\a 1 2 3 #\b 4 (5))
(define float
(checklambda* (a
(b (number? b))
(c (number? c) (< b c))
(d (number? d))
"opt" (e #\e (char? e)) (f (+ b c) (number? f))
"cat"
. g)
(list a b c d e f g)))
(float #\a 1 2 3) => (#\a 1 2 3 #\e 3 ())
(float #\a 2 1 3) => (#\a 2 3 1 #\e 5 ())
(float #\a 1 2 3 #\b) => (#\a 1 2 3 #\b 3 ())
(float #\a 1 2 3 4) => (#\a 1 2 3 #\e 4 ())
(float #\a 1 2 3 #\b 4 5) => (#\a 1 2 3 #\b 4 (5))
(alet* ((() (define a '(1 2 3 a 30 y 20 x 10)))
(opt a (a 10) (b 20) (c 30) . d)
(key d (x 1) (y 2) (a 3)))
(list a b c x y)) => (30 2 3 10 20)
((checklambda* ("opt" (a 10) (b 20) (c 30)
"key" (x 1) (y 2) (a 3))
(list a b c x y))
1 2 3 'a 30 'y 20 'x 10) => (30 2 3 10 20)
((checklambda (a
(b (number? b) (< 0 b))
"opt" (c 10)
"key" ((d dd) 30 (number? d)) e (f 40)
. g)
(list a b c d e f g))
0 1 2 'dd 3 'd 4 'dd 5 'f 6) => unknown keysymbol d
((checklambda (a
(b (number? b) (< 0 b))
"opt" (c 10)
"key" ((d dd) 30 (number? d)) e (f 40)
"allowotherkeys"
. g)
(list a b c d e f g))
0 1 2 'dd 3 'd 4 'dd 5 'f 6) => duplicate keysymbol dd
((checklambda (a
(b (number? b) (< 0 b))
"opt" (c 10)
"key" ((d dd) 30 (number? d)) e (f 40)
"allowotherkeys"
"allowduplicatekeys"
. g)
(list a b c d e f g))
0 1 2 'dd 3 'd 4 'dd 5 'f 6) => (0 1 2 3 #f 6 (d 4 dd 5))
((checklambda (a
(b (number? b) (< 0 b))
"opt" (c 10)
"key" ((d dd) 30 (number? d)) e (f 40)
#t
. g)
(list a b c d e f g))
0 1 2 'dd 3 'd 4 'dd 5 'f 6) => (0 1 2 3 #f 6 (d 4 dd 5))
(define condtest
(condlambda*
((a) a)
(((a (number? a)) (b (number? b) (< a b)))
(+ a b))
(((a (number? a)) (b (number? b)))
( a b))
(((a (string? a)) (b (string? b) (< (stringlength a) (stringlength b))))
(stringappend a b))
(((a (string? a)) (b (string? b)))
(stringappend b a))
((a b) (vector a b))
((a b . c) (apply list a b c))))
(condtest 1 2) => 3
(condtest 2 1) => 1
(condtest "a" "bc") => "abc"
(condtest "ab" "c") => "cab"
(condtest "a" 1) => #2("a" 1)
(condtest "a" 1 2) => ("a" 1 2)
Implementation
The following implementation is written in R5RS hygienic macros and requires
SRFI23 (Error reporting mechanism).
(definesyntax checklambda
(syntaxrules ()
((checklambda (a . e) bd ...)
(checklambda "chk" () () () () () () (a . e) bd ...))
((checklambda "key" () () (tt ...) (nt ...)
(v ...) (k kn ...) (#t . e) bd ...)
(checklambda "key" (allowanything) (#t) (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda "key" () () (tt ...) (nt ...)
(v ...) (k kn ...) (#f . e) bd ...)
(checklambda "key" () (#f) (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda "chk" () () (tt ...) (nt ...) () () ("opt" . e) bd ...)
(checklambda "opt" () () (tt ...) (nt ...) () () e bd ...))
((checklambda "chk" () () (tt ...) (nt ...) () () ("key" . e) bd ...)
(checklambda "key" () () (tt ...) (nt ...) () () e bd ...))
((checklambda "opt" () () (tt ...) (nt ...)
(v vv ...) () ("key" . e) bd ...)
(checklambda "key" () () (tt ...) (nt ...) (v vv ...) () e bd ...))
((checklambda "key" (o ...) () (tt ...) (nt ...)
(v ...) (k kn ...) ("allowotherkeys" . e) bd ...)
(checklambda "key" (o ... allowotherkeys) () (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda "key" (o ...) () (tt ...) (nt ...)
(v ...) (k kn ...) ("allowduplicatekeys" . e) bd ...)
(checklambda "key" (o ... allowduplicatekeys) () (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda "key" (o ...) () (tt ...) (nt ...)
(v ...) (k kn ...) ("allownonkeys" . e) bd ...)
(checklambda "key" (o ... allownonkeys) () (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda chk (o ...) (f ...) (tt ...) (nt ...)
(v ...) (k ...) ("cat" . e) bd ...)
(checklambda "cat" (o ...) (f ...) (tt ...) (nt ...)
(v ...) (k ...) e bd ...))
((checklambda "chk" () () (tt ...) (nt ...) () () ((n t ...) . e) bd ...)
(checklambda "chk" () () (tt ... tn) (nt ... (n t ...)) () () e bd ...))
((checklambda "chk" () () (tt ...) (nt ...) () () (n . e) bd ...)
(checklambda "chk" () () (tt ... tn) (nt ... (n)) () () e bd ...))
((checklambda "opt" () () (tt ...) (nt ...)
(v ...) () ((n d t ...) . e) bd ...)
(checklambda "opt" () () (tt ...) (nt ...)
(v ... (n d t ...)) () e bd ...))
((checklambda "opt" () () (tt ...) (nt ...) (v ...) () (n . e) bd ...)
(checklambda "opt" () () (tt ...) (nt ...) (v ... (n #f)) () e bd ...))
((checklambda "key" () () (tt ...) (nt ...)
(v ...) (k ...) (((n key) d t ...) . e) bd ...)
(checklambda "key" () () (tt ...) (nt ...)
(v ...) (k ... ((n key) d t ...)) e bd ...))
((checklambda "key" () () (tt ...) (nt ...)
(v ...) (k ...) (((n key)) . e) bd ...)
(checklambda "key" () () (tt ...) (nt ...)
(v ...) (k ... ((n key) #f)) e bd ...))
((checklambda "key" () () (tt ...) (nt ...)
(v ...) (k ...) ((n d t ...) . e) bd ...)
(checklambda "key" () () (tt ...) (nt ...)
(v ...) (k ... ((n n) d t ...)) e bd ...))
((checklambda "key" () () (tt ...) (nt ...)
(v ...) (k ...) (n . e) bd ...)
(checklambda "key" () () (tt ...) (nt ...)
(v ...) (k ... ((n n) #f)) e bd ...))
((checklambda "cat" (o ...) (f ...) () ()
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda z
(floatopt z (o ...) (f ...) ()
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...)))
((checklambda chk (o ...) (f ...) () ()
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda z
(checkopt z (o ...) (f ...) ()
(v ...) (((nk kk) dk tk ...) ... ) e (kk ...) bd ...)))
((checklambda chk () () (tt ...) ((n) ...) () () e bd ...)
(lambda (n ... . e) bd ...))
((checklambda "cat" (o ...) (f ...) (tt ...) ((n) ...)
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda (tt ... . te)
(floatopt te (o ...) (f ...) ((n tt) ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...)))
((checklambda chk (o ...) (f ...) (tt ...) ((n) ...)
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda (tt ... . te)
(checkopt te (o ...) (f ...) ((n tt) ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...)))
((checklambda "cat" () () (tt ...) ((n t ...) ...) () () () bd ...)
(lambda (tt ...)
(let ((z (list tt ...)))
;; not for random order evaluation
;; but for sequential evaluation from right to left
;;(slet ((n (wowfloat! z n t ...)) ...) bd ...))))
(let ((n (wowfloat! z n t ...)) ...) bd ...))))
((checklambda chk () () (tt ...) ((n t ...) ...) () () () bd ...)
(lambda (tt ...)
(let ((n (wowcheck n tt t ...)) ...) bd ...)))
((checklambda "cat" () () (tt ...) ((n t ...) ...) () () e bd ...)
(lambda (tt ... . te)
(let ((z (list tt ...)))
;;(slet ((n (wowfloat! z n t ...)) ... (e te)) bd ...))))
(let ((n (wowfloat! z n t ...)) ... (e te)) bd ...))))
((checklambda chk () () (tt ...) ((n t ...) ...) () () e bd ...)
(lambda (tt ... . te)
(let ((n (wowcheck n tt t ...)) ... (e te)) bd ...)))
((checklambda "cat" (o ...) (f ...) (tt ...) ((n t ...) ...)
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda (tt ... . te)
(let ((z (list tt ...)))
;;(slet ((tt (wowfloat! z n t ...)) ...)
(let ((tt (wowfloat! z n t ...)) ...)
(floatopt te (o ...) (f ...) ((n tt) ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...)))))
((checklambda chk (o ...) (f ...) (tt ...) ((n t ...) ...)
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda (tt ... . te)
(let ((tt (wowcheck n tt t ...)) ...)
(checkopt te (o ...) (f ...) ((n tt) ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...))))
((checklambda e bd ...)
(lambda e bd ...))))
(definesyntax checklambda*
(syntaxrules ()
((checklambda* (a . e) bd ...)
(checklambda* "chk" () () () () () () (a . e) bd ...))
((checklambda* "key" () () (tt ...) (nt ...)
(v ...) (k kn ...) (#t . e) bd ...)
(checklambda* "key" (allowanything) (#t) (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda* "key" () () (tt ...) (nt ...)
(v ...) (k kn ...) (#f . e) bd ...)
(checklambda* "key" () (#f) (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda* "chk" () () (tt ...) (nt ...) () () ("opt" . e) bd ...)
(checklambda* "opt" () () (tt ...) (nt ...) () () e bd ...))
((checklambda* "chk" () () (tt ...) (nt ...) () () ("key" . e) bd ...)
(checklambda* "key" () () (tt ...) (nt ...) () () e bd ...))
((checklambda* "opt" () () (tt ...) (nt ...)
(v vv ...) () ("key" . e) bd ...)
(checklambda* "key" () () (tt ...) (nt ...) (v vv ...) () e bd ...))
((checklambda* "key" (o ...) () (tt ...) (nt ...)
(v ...) (k kn ...) ("allowotherkeys" . e) bd ...)
(checklambda* "key" (o ... allowotherkeys) () (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda* "key" (o ...) () (tt ...) (nt ...)
(v ...) (k kn ...) ("allowduplicatekeys" . e) bd ...)
(checklambda* "key" (o ... allowduplicatekeys) () (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda* "key" (o ...) () (tt ...) (nt ...)
(v ...) (k kn ...) ("allownonkeys" . e) bd ...)
(checklambda* "key" (o ... allownonkeys) () (tt ...) (nt ...)
(v ...) (k kn ...) e bd ...))
((checklambda* chk (o ...) (f ...) (tt ...) (nt ...)
(v ...) (k ...) ("cat" . e) bd ...)
(checklambda* "cat" (o ...) (f ...) (tt ...) (nt ...)
(v ...) (k ...) e bd ...))
((checklambda* "chk" () () (tt ...) (nt ...) () () ((n t ...) . e) bd ...)
(checklambda* "chk" () () (tt ... tn) (nt ... (n t ...)) () () e bd ...))
((checklambda* "chk" () () (tt ...) (nt ...) () () (n . e) bd ...)
(checklambda* "chk" () () (tt ... tn) (nt ... (n)) () () e bd ...))
((checklambda* "opt" () () (tt ...) (nt ...)
(v ...) () ((n d t ...) . e) bd ...)
(checklambda* "opt" () () (tt ...) (nt ...)
(v ... (n d t ...)) () e bd ...))
((checklambda* "opt" () () (tt ...) (nt ...) (v ...) () (n . e) bd ...)
(checklambda* "opt" () () (tt ...) (nt ...) (v ... (n #f)) () e bd ...))
((checklambda* "key" () () (tt ...) (nt ...)
(v ...) (k ...) (((n key) d t ...) . e) bd ...)
(checklambda* "key" () () (tt ...) (nt ...)
(v ...) (k ... ((n key) d t ...)) e bd ...))
((checklambda* "key" () () (tt ...) (nt ...)
(v ...) (k ...) ((n d t ...) . e) bd ...)
(checklambda* "key" () () (tt ...) (nt ...)
(v ...) (k ... ((n n) d t ...)) e bd ...))
((checklambda* "key" () () (tt ...) (nt ...)
(v ...) (k ...) (n . e) bd ...)
(checklambda* "key" () () (tt ...) (nt ...)
(v ...) (k ... ((n n) #f)) e bd ...))
((checklambda* "cat" (o ...) (f ...) () ()
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda z
(floatopt* z (o ...) (f ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...)))
((checklambda* chk (o ...) (f ...) () ()
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda z
(checkopt* z (o ...) (f ...)
(v ...) (((nk kk) dk tk ...) ... ) e (kk ...) bd ...)))
((checklambda* chk () () (tt ...) ((n) ...) () () () bd ...)
(lambda (tt ...) (let* ((n tt) ...) bd ...)))
((checklambda* chk () () (tt ...) ((n) ...) () () e bd ...)
(lambda (tt ... . te) (let* ((n tt) ... (e te)) bd ...)))
((checklambda* "cat" (o ...) (f ...) (tt ...) ((n) ...)
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda (tt ... . te)
(let* ((n tt) ...)
(floatopt* te (o ...) (f ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...))))
((checklambda* chk (o ...) (f ...) (tt ...) ((n) ...)
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda (tt ... . te)
(let* ((n tt) ...)
(checkopt* te (o ...) (f ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...))))
((checklambda* "cat" () () (tt ...) ((n t ...) ...) () () () bd ...)
(lambda (tt ...)
(let ((z (list tt ...)))
(let* ((n (wowfloat! z n t ...)) ...) bd ...))))
((checklambda* chk () () (tt ...) ((n t ...) ...) () () () bd ...)
(lambda (tt ...)
(let* ((n (wowcheck n tt t ...)) ...) bd ...)))
((checklambda* "cat" () () (tt ...) ((n t ...) ...) () () e bd ...)
(lambda (tt ... . te)
(let ((z (list tt ...)))
(let* ((n (wowfloat! z n t ...)) ... (e te)) bd ...))))
((checklambda* chk () () (tt ...) ((n t ...) ...) () () e bd ...)
(lambda (tt ... . te)
(let* ((n (wowcheck n tt t ...)) ... (e te)) bd ...)))
((checklambda* "cat" (o ...) (f ...) (tt ...) ((n t ...) ...)
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda (tt ... . te)
(let ((z (list tt ...)))
(let* ((n (wowfloat! z n t ...)) ...)
(floatopt* te (o ...) (f ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...)))))
((checklambda* chk (o ...) (f ...) (tt ...) ((n t ...) ...)
(v ...) (((nk kk) dk tk ...) ...) e bd ...)
(lambda (tt ... . te)
(let* ((n (wowcheck n tt t ...)) ...)
(checkopt* te (o ...) (f ...)
(v ...) (((nk kk) dk tk ...) ...) e (kk ...) bd ...))))
((checklambda* e bd ...)
(lambda e bd ...))))
(definesyntax condlambda
(syntaxrules ()
((condlambda (formals bd ...) cl ...)
(lambda z (let ((len (length z)))
(condlambda "*" z len (formals bd ...) cl ...))))
((condlambda "*" z len (() bd ...) cl ...)
(if (= len 0)
((lambda () bd ...))
(condlambda "*" z len cl ...)))
((condlambda "*" z len (((n t ...) . e) bd ...) cl ...)
(condlambda " " z len (tt) ((n t ...)) (e bd ...) cl ...))
((condlambda "*" z len ((n . e) bd ...) cl ...)
(condlambda " " z len (tt) ((n)) (e bd ...) cl ...))
((condlambda "*" z len (e bd ...) cl ...)
(let ((e z)) bd ...))
((condlambda "*" z len)
(error "the arguments are not matched to any clause of condlambda" z))
((condlambda " " z len (tt ...) (nt ...) (((n t ...) . e) bd ...) cl ...)
(condlambda " " z len (tt ... tn) (nt ... (n t ...)) (e bd ...) cl ...))
((condlambda " " z len (tt ...) (nt ...) ((n . e) bd ...) cl ...)
(condlambda " " z len (tt ... tn) (nt ... (n)) (e bd ...) cl ...))
((condlambda " " z len (tt ...) ((n) ...) (() bd ...) cl ...)
(if (= len (length '(tt ...)))
(apply (lambda (n ...) bd ...) z)
(condlambda "*" z len cl ...)))
((condlambda " " z len (tt ...) ((n t ...) ...) (() bd ...) cl ...)
(if (and (= len (length '(tt ...)))
(apply (lambda (tt ...) (and (let ((n tt)) (and t ...)) ...)) z))
(apply (lambda (n ...) bd ...) z)
(condlambda "*" z len cl ...)))
((condlambda " " z len (tt ...) ((n) ...) (e bd ...) cl ...)
(if (>= len (length '(tt ...)))
(apply (lambda (n ... . e) bd ...) z)
(condlambda "*" z len cl ...)))
((condlambda " " z len (tt ...) ((n t ...) ...) (e bd ...) cl ...)
(if (and (>= len (length '(tt ...)))
(apply (lambda (tt ...) (and (let ((n tt)) (and t ...)) ...)) z))
(apply (lambda (n ... . e) bd ...) z)
(condlambda "*" z len cl ...)))))
(definesyntax condlambda*
(syntaxrules ()
((condlambda* (formals bd ...) cl ...)
(lambda z (let ((len (length z)))
(condlambda* "*" z len (formals bd ...) cl ...))))
((condlambda* "*" z len (() bd ...) cl ...)
(if (= len 0)
((lambda () bd ...))
(condlambda* "*" z len cl ...)))
((condlambda* "*" z len (((n t ...) . e) bd ...) cl ...)
(condlambda* " " z len (tt) ((n t ...)) (e bd ...) cl ...))
((condlambda* "*" z len ((n . e) bd ...) cl ...)
(condlambda* " " z len (tt) ((n)) (e bd ...) cl ...))
((condlambda* "*" z len (e bd ...) cl ...)
(let ((e z)) bd ...))
((condlambda* "*" z len)
(error "the arguments are not matched to any clause of condlambda*" z))
((condlambda* " " z len (tt ...) (nt ...) (((n t ...) . e) bd ...) cl ...)
(condlambda* " " z len (tt ... tn) (nt ... (n t ...)) (e bd ...) cl ...))
((condlambda* " " z len (tt ...) (nt ...) ((n . e) bd ...) cl ...)
(condlambda* " " z len (tt ... tn) (nt ... (n)) (e bd ...) cl ...))
((condlambda* " " z len (tt ...) ((n) ...) (() bd ...) cl ...)
(if (= len (length '(tt ...)))
(apply (lambda (tt ...) (let* ((n tt) ...) bd ...)) z)
(condlambda* "*" z len cl ...)))
((condlambda* " " z len (tt ...) ((n t ...) ...) (() bd ...) cl ...)
(if (and (= len (length '(tt ...)))
(apply (lambda (tt ...) (condand* ((n tt t ...) ...))) z))
(apply (lambda (tt ...) (let* ((n tt) ...) bd ...)) z)
(condlambda* "*" z len cl ...)))
((condlambda* " " z len (tt ...) ((n) ...) (e bd ...) cl ...)
(if (>= len (length '(tt ...)))
(apply (lambda (tt ... . te) (let* ((n tt) ... (e te)) bd ...)) z)
(condlambda* "*" z len cl ...)))
((condlambda* " " z len (tt ...) ((n t ...) ...) (e bd ...) cl ...)
(if (and (>= len (length '(tt ...)))
(apply (lambda (tt ...) (condand* ((n tt t ...) ...))) z))
(apply (lambda (tt ... . te) (let* ((n tt) ... (e te)) bd ...)) z)
(condlambda* "*" z len cl ...)))))
(definesyntax checkopt
(syntaxrules ()
((checkopt z (o ...) (f ...) (nd ...) ((n d t ...) (nn dn tn ...) ...)
(nkdt ...) e (kk ...) bd ...)
(let ((y (if (null? z) z (cdr z)))
(x (if (null? z)
d
(wowcheck n (car z) t ...))))
(checkopt y (o ...) (f ...) (nd ... (n x)) ((nn dn tn ...) ...)
(nkdt ...) e (kk ...) bd ...)))
((checkopt z (o ...) (#t) (nd ...) ()
(((n k) d t ...) ((nn kn) dn dt ...) ...) e (kk ...) bd ...)
(let ((x (if (null? z)
d
(wowkey! z (o ...) () () (n k) d t ...))))
(checkopt z (o ...) (#t) (nd ... (n x)) ()
(((nn kn) dn dt ...) ...) e (kk ...) bd ...)))
((checkopt z (o ...) (f ...) (nd ...) ()
(((n k) d t ...) ((nn kn) dn dt ...) ...) e (kk ...) bd ...)
(let ((x (if (null? z)
d
(wowkey! z (o ...) (kk ...) (k kn ...) (n k) d t ...))))
(checkopt z (o ...) (f ...) (nd ... (n x)) ()
(((nn kn) dn dt ...) ...) e (kk ...) bd ...)))
((checkopt z () (f ...) (nd ...) () () () (kk ...) bd ...)
(if (null? z)
(let (nd ...) bd ...)
(error "checklambda: too many arguments" z)))
((checkopt z (o oo ...) (f ...) (nd ...) () () () (kk ...) bd ...)
(let (nd ...) bd ...))
((checkopt z (o ...) (f ...) (nd ...) () () e (kk ...) bd ...)
(let (nd ... (e z)) bd ...))))
(definesyntax checkopt*
(syntaxrules ()
((checkopt* z (o ...) (f ...) ((n d t ...) (nn dn tn ...) ...)
(nkdt ...) e (kk ...) bd ...)
(let ((y (if (null? z) z (cdr z)))
(n (if (null? z)
d
(wowcheck n (car z) t ...))))
(checkopt* y (o ...) (f ...) ((nn dn tn ...) ...)
(nkdt ...) e (kk ...) bd ...)))
((checkopt* z (o ...) (#t) ()
(((n k) d t ...) ((nn kn) dn dt ...) ...) e (kk ...) bd ...)
(let ((n (if (null? z)
d
(wowkey! z (o ...) () () (n k) d t ...))))
(checkopt* z (o ...) (#t) ()
(((nn kn) dn dt ...) ...) e (kk ...) bd ...)))
((checkopt* z (o ...) (f ...) ()
(((n k) d t ...) ((nn kn) dn dt ...) ...) e (kk ...) bd ...)
(let ((n (if (null? z)
d
(wowkey! z (o ...) (kk ...) (k kn ...) (n k) d t ...))))
(checkopt* z (o ...) (f ...) ()
(((nn kn) dn dt ...) ...) e (kk ...) bd ...)))
((checkopt* z () (f ...) () () () (kk ...) bd ...)
(if (null? z)
(let () bd ...)
(error "checklambda*: too many arguments" z)))
((checkopt* z (o oo ...) (f ...) () () () (kk ...) bd ...)
(let () bd ...))
((checkopt* z (o ...) (f ...) () () e (kk ...) bd ...)
(let ((e z)) bd ...))))
(definesyntax floatopt
(syntaxrules ()
((floatopt z (o ...) (f ...) (nd ...) ((n d t ...) (nn dn tn ...) ...)
(nkdt ...) e (kk ...) bd ...)
(let ((x (if (null? z)
d
(wowcat! z n d t ...))))
(floatopt z (o ...) (f ...) (nd ... (n x)) ((nn dn tn ...) ...)
(nkdt ...) e (kk ...) bd ...)))
((floatopt z (o ...) (#t) (nd ...) ()
(((n k) d t ...) ((nn kn) dn dt ...) ...) e (kk ...) bd ...)
(let ((x (if (null? z)
d
(momkey! z (o ...) () () (n k) d t ...))))
(floatopt z (o ...) (#t) (nd ... (n x)) ()
(((nn kn) dn dt ...) ...) e (kk ...) bd ...)))
((floatopt z (o ...) (f ...) (nd ...) ()
(((n k) d t ...) ((nn kn) dn dt ...) ...) e (kk ...) bd ...)
(let ((x (if (null? z)
d
(momkey! z (o ...) (kk ...) (k kn ...) (n k) d t ...))))
(floatopt z (o ...) (f ...) (nd ... (n x)) ()
(((nn kn) dn dt ...) ...) e (kk ...) bd ...)))
((floatopt z () (f ...) (nd ...) () () () (kk ...) bd ...)
(if (null? z)
(let (nd ...) bd ...)
(error "checklambda: too many arguments" z)))
((floatopt z (o oo ...) (f ...) (nd ...) () () () (kk ...) bd ...)
(let (nd ...) bd ...))
((floatopt z (o ...) (f ...) (nd ...) () () e (kk ...) bd ...)
(let (nd ... (e z)) bd ...))))
(definesyntax floatopt*
(syntaxrules ()
((floatopt* z (o ...) (f ...) ((n d t ...) (nn dn tn ...) ...)
(nkdt ...) e (kk ...) bd ...)
(let ((n (if (null? z)
d
(wowcat! z n d t ...))))
(floatopt* z (o ...) (f ...) ((nn dn tn ...) ...)
(nkdt ...) e (kk ...) bd ...)))
((floatopt* z (o ...) (#t) ()
(((n k) d t ...) ((nn kn) dn dt ...) ...) e (kk ...) bd ...)
(let ((n (if (null? z)
d
(momkey! z (o ...) () () (n k) d t ...))))
(floatopt* z (o ...) (#t) ()
(((nn kn) dn dt ...) ...) e (kk ...) bd ...)))
((floatopt* z (o ...) (f ...) ()
(((n k) d t ...) ((nn kn) dn dt ...) ...) e (kk ...) bd ...)
(let ((n (if (null? z)
d
(momkey! z (o ...) (kk ...) (k kn ...) (n k) d t ...))))
(floatopt* z (o ...) (f ...) ()
(((nn kn) dn dt ...) ...) e (kk ...) bd ...)))
((floatopt* z () (f ...) () () () (kk ...) bd ...)
(if (null? z)
(let () bd ...)
(error "checklambda*: too many arguments" z)))
((floatopt* z (o oo ...) (f ...) () () () (kk ...) bd ...)
(let () bd ...))
((floatopt* z (o ...) (f ...) () () e (kk ...) bd ...)
(let ((e z)) bd ...))))
(definesyntax condand*
(syntaxrules ()
((condand* ((n v t ...)))
(let ((n v))
(and t ...)))
((condand* ((n v t ...) nvt ...))
(let ((n v))
(and t ... (condand* (nvt ...)))))))
;; (definesyntax slet
;; (syntaxrules ()
;; ((slet ((n v) ...) bd ...)
;; (slet "sequential" () ((n v) ...) bd ...))
;; ((slet "sequential" (nt ...) ((n v) nv ...) bd ...)
;; ((lambda (t) (slet "sequential" (nt ... (n t)) (nv ...) bd ...)) v))
;; ((slet "sequential" ((n t) ...) () bd ...)
;; ((lambda (n ...) bd ...) t ...))))
(definesyntax wowcheck ; wow means withorwithout
(syntaxrules ()
((wowcheck n v) v)
((wowcheck n v t ...)
(let ((n v))
(if (and t ...)
n
(error "checklambda[*]: bad argument" n 'n 't ...))))))
(definesyntax wowkey!
(syntaxrules ()
((wowkey! z (o ...) () () (n key) d)
(let ((x (car z))
(y (cdr z)))
(if (null? y)
d
(if (eq? 'key x)
(begin (set! z (cdr y)) (car y))
(let lp ((head (list (car y) x)) (tail (cdr y)))
(if (null? tail)
d
(let ((x (car tail))
(y (cdr tail)))
(if (null? y)
d
(if (eq? 'key x)
(begin (set! z (append (reverse head) (cdr y)))
(car y))
(lp (cons (car y) (cons x head))
(cdr y)))))))))))
((wowkey! z (o ...) (kk ...) (k ...) (n key) d)
(let lp ((head '()) (tail z))
(if (null? tail)
d
(let ((x (car tail))
(y (cdr tail)))
(if (not (symbol? x))
(if (memq 'allownonkeys '(o ...))
d
(error "no keysymbol" x))
(if (null? y)
(error "odd keysymbol list" tail)
(if (memq x '(k ...))
(if (eq? 'key x)
(begin (set! z (append (reverse head) (cdr y)))
(car y))
(lp (cons (car y) (cons x head)) (cdr y)))
(if (memq x '(kk ...))
(if (memq 'allowduplicatekeys '(o ...))
(lp (cons (car y) (cons x head)) (cdr y))
(error "duplicate keysymbol" x))
(if (memq 'allowotherkeys '(o ...))
(lp (cons (car y) (cons x head)) (cdr y))
(error "unknown keysymbol" x))))))))))
((wowkey! z (o ...) () () (n key) d t ...)
(let ((x (car z))
(y (cdr z)))
(if (null? y)
d
(if (eq? 'key x)
(let ((n (car y)))
(if (and t ...)
(begin (set! z (cdr y)) n)
(error "bad argument" n 'n 't ...)))
(let lp ((head (list (car y) x)) (tail (cdr y)))
(if (null? tail)
d
(let ((x (car tail))
(y (cdr tail)))
(if (null? y)
d
(if (eq? 'key x)
(let ((n (car y)))
(if (and t ...)
(begin
(set! z (append (reverse head) (cdr y)))
n)
(error "bad argument" n 'n 't ...)))
(lp (cons (car y) (cons x head))
(cdr y)))))))))))
((wowkey! z (o ...) (kk ...) (k ...) (n key) d t ...)
(let lp ((head '()) (tail z))
(if (null? tail)
d
(let ((x (car tail))
(y (cdr tail)))
(if (not (symbol? x))
(if (memq 'allownonkeys '(o ...))
d
(error "no keysymbol" x))
(if (null? y)
(error "odd keysymbol list" tail)
(if (memq x '(k ...))
(if (eq? 'key x)
(let ((n (car y)))
(if (and t ...)
(begin (set! z (append (reverse head)
(cdr y)))
n)
(error "bad argument" n 'n 't ...)))
(lp (cons (car y) (cons x head)) (cdr y)))
(if (memq x '(kk ...))
(if (memq 'allowduplicatekeys '(o ...))
(lp (cons (car y) (cons x head)) (cdr y))
(error "duplicate keysymbol" x))
(if (memq 'allowotherkeys '(o ...))
(lp (cons (car y) (cons x head)) (cdr y))
(error "unknown keysymbol" x))))))))))))
(definesyntax wowfloat!
(syntaxrules ()
((wowfloat! z n)
(let ((n (car z)))
(set! z (cdr z)) n))
((wowfloat! z n t ...)
(let ((n (car z)))
(if (and t ...)
(begin (set! z (cdr z)) n)
(let lp ((head (list n)) (tail (cdr z)))
(if (null? tail)
(error "checklambda[*]: no more argument to check"
'n 't ... (reverse head))
(let ((n (car tail)))
(if (and t ...)
(begin (set! z (append (reverse head) (cdr tail))) n)
(lp (cons n head) (cdr tail)))))))))))
(definesyntax wowcat!
(syntaxrules ()
((wowcat! z n d)
(let ((n (car z)))
(set! z (cdr z)) n))
((wowcat! z n d t ...)
(let ((n (car z)))
(if (and t ...)
(begin (set! z (cdr z)) n)
(let lp ((head (list n)) (tail (cdr z)))
(if (null? tail)
d
(let ((n (car tail)))
(if (and t ...)
(begin (set! z (append (reverse head) (cdr tail))) n)
(lp (cons n head) (cdr tail)))))))))))
(definesyntax momkey!
(syntaxrules ()
((momkey! z (o ...) () () (n key) d)
(let ((x (car z))
(y (cdr z)))
(if (null? y)
d
(if (eq? 'key x)
(begin (set! z (cdr y)) (car y))
(let lp ((head (list (car y) x)) (tail (cdr y)))
(if (null? tail)
d
(let ((x (car tail))
(y (cdr tail)))
(if (null? y)
d
(if (eq? 'key x)
(begin (set! z (append (reverse head) (cdr y)))
(car y))
(lp (cons (car y) (cons x head))
(cdr y)))))))))))
((momkey! z (o ...) (kk ...) (k ...) (n key) d)
(let lp ((head '()) (tail z))
(if (null? tail)
d
(let ((x (car tail))
(y (cdr tail)))
(if (not (symbol? x))
(if (memq 'allownonkeys '(o ...))
d
(error "no keysymbol" x))
(if (null? y)
(error "odd keysymbol list" tail)
(if (memq x '(k ...))
(if (eq? 'key x)
(begin (set! z (append (reverse head) (cdr y)))
(car y))
(lp (cons (car y) (cons x head)) (cdr y)))
(if (memq x '(kk ...))
(if (memq 'allowduplicatekeys '(o ...))
(lp (cons (car y) (cons x head)) (cdr y))
(error "duplicate keysymbol" x))
(if (memq 'allowotherkeys '(o ...))
(lp (cons (car y) (cons x head)) (cdr y))
(error "unknown keysymbol" x))))))))))
((momkey! z (o ...) () () (n key) d t ...)
(let ((x (car z))
(y (cdr z)))
(if (null? y)
d
(if (and (eq? 'key x)
(let ((n (car y))) (and t ...)))
(begin (set! z (cdr y)) (car y))
(let lp ((head (list (car y) x)) (tail (cdr y)))
(if (null? tail)
d
(let ((x (car tail))
(y (cdr tail)))
(if (null? y)
d
(if (and (eq? 'key x)
(let ((n (car y))) (and t ...)))
(begin (set! z (append (reverse head) (cdr y)))
(car y))
(lp (cons (car y) (cons x head))
(cdr y)))))))))))
((momkey! z (o ...) (kk ...) (k ...) (n key) d t ...)
(let lp ((head '()) (tail z))
(if (null? tail)
d
(let ((x (car tail))
(y (cdr tail)))
(if (not (symbol? x))
(if (memq 'allownonkeys '(o ...))
d
(error "no keysymbol" x))
(if (null? y)
(error "odd keysymbol list" tail)
(if (memq x '(k ...))
(if (and (eq? 'key x)
(let ((n (car y))) (and t ...)))
(begin (set! z (append (reverse head) (cdr y)))
(car y))
(lp (cons (car y) (cons x head)) (cdr y)))
(if (memq x '(kk ...))
(if (memq 'allowduplicatekeys '(o ...))
(lp (cons (car y) (cons x head)) (cdr y))
(error "duplicate keysymbol" x))
(if (memq 'allowotherkeys '(o ...))
(lp (cons (car y) (cons x head)) (cdr y))
(error "unknown keysymbol" x))))))))))))
References
[R5RS] Richard Kelsey, William Clinger, and Jonathan Rees: Revised(5)
Report on the Algorithmic Language Scheme
http://www.schemers.org/Documents/Standards/R5Rs/
[SRFI 16] Lars T Hansen: Syntax for procedures of variable arity.
http://srfi.schemers.org/srfi16/
[SRFI 86] Joo ChurlSoo:MU and NU simulating VALUES & CALLWITHVALUES,
and their related LETsyntax.
http://srfi.schemers.org/srfi86/
[SRFI 89] Marc Feeley: Optional parameters.
http://srfi.schemers.org/srfi89/
PLT MzLib Dorai Sitaram, Bruce Hauman, Jens Axel S��gaard, Gann Bierner,
and Kurt Howard: PLT MzLib: Libraries Manual
http://download.pltscheme.org/doc/301/html/mzlib/
Copyright
Copyright (c) 2006 Joo ChurlSoo.
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the ``Software''), to
deal in the Software without restriction, including without limitation the
rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
sell copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.