Using `non-fixed' sequence argument processing concept of SRFI-51, we can
simulate named optional argument making use of keyword object.
The following is an example:
(define depth 15)
(define key-check
(check-lambda (a
b
#(c 11) ; positional optional variable
#((width d) 22) ; named optional variable
#((depth e) 33)) ; named optional variable
(list a b c `(width ,d) `(depth ,e))))
(key-check 1) => error
(key-check 1 2) => (1 2 11 (width 22) (depth 33))
(key-check 2 1) => (2 1 11 (width 22) (depth 33))
(key-check 1 2 3) => (1 2 3 (width 22) (depth 33))
(key-check 1 2 3 #(depth 10)) => (1 2 3 (width 22) (depth 10))
(key-check 1 2 3 #(depth 10) #(width 5)) => (1 2 3 (width 5) (depth 10))
(key-check 1 2 3 `#(depth ,depth) #(width 5)) => (1 2 3 (width 5) (depth 15))
(key-check 1 2 3 4 5) => error
The above can be expanded as follows:
(define test-check
(check-lambda* ((a (number? a))
(b (number? b) (< a b))
#(c 11 (number? c) (< b c))
#((width d) 22 (number? d) (< c d))
#((depth e) 33 (number? e) (< d e))
. f)
(list a b c `(width ,d) `(depth ,e) f)))
(test-check 1) => error
(test-check 1 2) => (1 2 11 (width 22) (depth 33) ())
(test-check 2 1) => error
(test-check 1 2 3) => (1 2 3 (width 22) (depth 33) ())
(test-check 1 2 3 #(depth 10)) => error
(test-check 1 2 3 #(depth 10) #(width 5))=> (1 2 3 (width 5) (depth 10) ())
(test-check 1 2 3 `#(depth ,depth) #(width 5))
=> (1 2 3 (width 5) (depth 15) ())
(test-check 1 2 3 4 5) => (1 2 3 (width 22) (depth 33) (4 5))
I've attached a rough draft.
--
Joo ChurlSoo
Title
LAMBDA extension
Author
Joo ChurlSoo
Abstract
This SRFI introduces COND-LAMBDA and COND-LAMBDA* that return different
procedures according to the states of actual arguments passed in as well as
the number of arguments, and another four macros, CHECK-LAMBDA and
CHECK-LAMBDA*, FLOAT-LAMBDA and FLOAT-LAMBDA*, each of which creates a
procedure that takes optional arguments and checks the states of ordinary
arguments as well as optional arguments passed in.
Rationale
The COND-LAMBDA can reduce the clutter of procedures more precisely than
CASE-LAMBDA of SRFI-16 by adding tests for the states of arguments passed in,
such as type checking. The CHECK-LAMBDA and FLOAT-LAMBDA reduce not only the
clutter of various error conditionals by checking actual arguments passed in
but also somewhat lengthy code by combining respectively `fixed' and
`non-fixed' sequence argument processing concept of SRFI-51 into a single
syntax. The optional parameters that they take include not only positional
fixed parameters but also named non-fixed parameters that are implemented
without introducing a new data type such as keyword object. The COND-LAMBDA*,
CHECK-LAMBDA*, and FLOAT-LAMBDA* are LET*-like forms corresponding to
COND-LAMBDA, CHECK-LAMBDA, and FLOAT-LAMBDA.
Specification
The syntax is defined in the extended BNF of R5RS.
(cond-lambda <clause>+)
(cond-lambda* <clause>+)
<clause> --> (<formals> <body>)
<formals> --> (<variable spec>*)
| <variable>
| (<variable spec>+ . <variable>)
<variable spec> --> <variable>
| (<variable> <test>+)
<test> --> <expression>
COND-LAMBDA is an extended form of CASE-LAMBDA of SRFI-16. Like CASE-LAMBDA,
it returns a procedure of the first <clause>, the <formals> of which is
matched with the number of actual arguments. But if there are <test>s and any
of the <test>s returns a false value, the subsequent <clause> is processed in
spite of the match. If no <clause> matches, an error is signaled. Each
<test> of COND-LAMBDA* sees the values of the previous <variable>s of
<formals> like LET*.
(check-lambda <formals> <body>)
(check-lambda* <formals> <body>)
<formals> -->
| (<variable spec>* <positional opt spec>* <named opt spec>*)
| <variable>
| (<variable spec>+ <positional opt spec>* <named opt spec>* . <variable>)
| (<positional opt spec>+ <named opt spec>* . <variable>)
| (<named opt spec>+ . <variable>)
<variable spec> --> <variable>
| (<variable> <test>+)
<positional opt spec> --> #(<variable> <default value> <test>*)
<named opt spec> --> #((<name> <variable>) <default value> <test>*)
<name> --> <symbol>
<default value> --> <expression>
<test> --> <expression>
The <formals> is the same as that of COND-LAMBDA except optional variable that
is a vector pattern. The optional variables should be placed at the end of
<formals> list, but before any dotted rest variable. And positional optional
variables should precede named optional variables. Unlike COND-LAMBDA, each
macro can create a procedure that takes optional arguments. Optional
variables are given <default value>s which are taken when optional arguments
are not present in a call. Even though there are <test>s, they are not
evaluated when the optional variable is bound to the <default value>. If any
<test> of optional or ordinary variable returns a false value, an error is
signaled. Unlike positional optional variables, named optional variables are
not bound sequetially to the optional arguments passed in. They seek a vector
whose elements are two and the first element is equal to <name>, sequentially
from left to right. Then they are bound to the second elements of the sought
vectors. If not sought, they are bound to the <default value>s. An error is
signaled when any optional arguments remain after binding process. But if
there is a dotted rest variable, it is bound to the remaining arguments. Each
<test> of CHECK-LAMBDA* sees the values of the previous <variable>s of
<formals> like LET*.
(float-lambda <formals> <body>)
(float-lambda* <formals> <body>)
<formals> -->
| (<variable spec>* <positional opt spec>* <named opt spec>*)
| <variable>
| (<variable spec>+ <positional opt spec>* <named opt spec>* . <variable>)
| (<positional opt spec>+ <named opt spec>* . <variable>)
| (<named opt spec>+ . <variable>)
<variable spec> --> <variable>
| (<variable> <test>+)
<positional opt spec> --> #(<variable> <default value> <test>*)
<named opt spec> --> #((<name> <variable>) <default value> <test>*)
<name> --> <symbol>
<default value> --> <expression>
<test> --> <expression>
This is the same as CHECK-LAMBDA except binding method. It temporarily binds
an ordinary variable to each of ordinary actual arguments sequentially, until
all <test>s return true values, then the ordinary variable is finally bound to
the passed argument. If there are no <test>s, the first one of the remained
ordinary actual arguments is regarded as passing. If any ordinary variable is
not bound to any one of the ordinary actual arguments, an error is signaled.
For positional optional variables, the process is the same as above except
that <default value>s are bound to the corresponding optional variables
instead of signaling an error if any optional argument does not pass the
<test>s. For named optional variables, the process is the same as that of
CHECK-LAMBDA. An error is signaled when any optional arguments remain after
binding process. But if there is a dotted rest variable, it is bound to the
remaining arguments. Each <test> of FLOAT-LAMBDA* sees the values of the
previous <variable>s of <formals> like LET*.
Examples
(define cond-test
(cond-lambda*
((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) (< (string-length a) (string-length b))))
(string-append a b))
(((a (string? a)) (b (string? b)))
(string-append b a))
((a b) (vector a b))
((a b . c) (apply list a b c))))
(cond-test 1 2) => 3
(cond-test 2 1) => 1
(cond-test "a" "bc") => "abc"
(cond-test "ab" "c") => "cab"
(cond-test "a" 1) => #2("a" 1)
(cond-test "a" 1 2) => ("a" 1 2)
(define check
(check-lambda* (a
(b (number? b))
(c (number? c) (< b c))
(d (number? d))
#(e "s" (string? e))
#(f (+ b c) (number? f))
. g)
(list a b c d e f g)))
(check "a" 1 2 3) => ("a" 1 2 3 "s" 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
(float-lambda* (a
(b (number? b))
(c (number? c) (< b c))
(d (number? d))
#(e "s" (string? e))
#(f (+ b c) (number? f))
. g)
(list a b c d e f g)))
(float "a" 1 2 3) => ("a" 1 2 3 "s" 3 ())
(float "a" 2 1 3) => ("a" 2 3 1 "s" 5 ())
(float "a" 1 2 3 "b") => ("a" 1 2 3 "b" 3 ())
(float "a" 1 2 3 4) => ("a" 1 2 3 "s" 4 ())
(float "a" 1 2 3 "b" 4 5) => ("a" 1 2 3 "b" 4 (5))
(define depth 15)
(define key-check
(check-lambda (a
b
#(c 11)
#((width d) 22)
#((depth e) 33))
(list a b c `(width ,d) `(depth ,e))))
(key-check 1) => error
(key-check 1 2) => (1 2 11 (width 22) (depth 33))
(key-check 2 1) => (2 1 11 (width 22) (depth 33))
(key-check 1 2 3) => (1 2 3 (width 22) (depth 33))
(key-check 1 2 3 #(depth 10)) => (1 2 3 (width 22) (depth 10))
(key-check 1 2 3 #(depth 10) #(width 5)) => (1 2 3 (width 5) (depth 10))
(key-check 1 2 3 `#(depth ,depth) #(width 5)) => (1 2 3 (width 5) (depth 15))
(key-check 1 2 3 4 5) => error
(define test-check
(check-lambda* ((a (number? a))
(b (number? b) (< a b))
#(c 11 (number? c) (< b c))
#((width d) 22 (number? d) (< c d))
#((depth e) 33 (number? e) (< d e))
. f)
(list a b c `(width ,d) `(depth ,e) f)))
(test-check 1) => error
(test-check 1 2) => (1 2 11 (width 22) (depth 33) ())
(test-check 2 1) => error
(test-check 1 2 3) => (1 2 3 (width 22) (depth 33) ())
(test-check 1 2 3 #(depth 10)) => error
(test-check 1 2 3 #(depth 10) #(width 5))=> (1 2 3 (width 5) (depth 10) ())
(test-check 1 2 3 `#(depth ,depth) #(width 5))
=> (1 2 3 (width 5) (depth 15) ())
(test-check 1 2 3 4 5) => (1 2 3 (width 22) (depth 33) (4 5))
Implementation
The following implementation is written in R5RS hygienic macros and requires
SRFI-23 (Error reporting mechanism).
(define-syntax wow-check ; wow means with-or-without
(syntax-rules ()
((wow-check (key n) v)
(if (and (vector? v) (= 2 (vector-length v)) (eq? 'key (vector-ref v 0)))
(vector-ref v 1)
(error "check{float]-lambda[*]: too many arguments" v)))
((wow-check (key n) v t ...)
(if (and (vector? v) (= 2 (vector-length v)) (eq? 'key (vector-ref v 0)))
(let ((n (vector-ref v 1)))
(if (and t ...)
n
(error "check{float]-lambda[*]: bad argument" n 'n 't ...)))
(error "check{float]-lambda[*]: too many arguments" v)))
((wow-check n v) v)
((wow-check n v t ...)
(let ((n v))
(if (and t ...)
n
(error "check{float]-lambda[*]: bad argument" n 'n 't ...))))))
(define-syntax wow-check-key!
(syntax-rules ()
((wow-check-key! z (key n) d)
(let ((v (car z)))
(if (and (vector? v)
(= 2 (vector-length v))
(eq? 'key (vector-ref v 0)))
(begin (set! z (cdr z)) (vector-ref v 1))
(let lp ((head (list v)) (tail (cdr z)))
(if (null? tail)
d
(let ((v (car tail)))
(if (and (vector? v)
(= 2 (vector-length v))
(eq? 'key (vector-ref v 0)))
(begin (set! z (append (reverse head) (cdr tail)))
(vector-ref v 1))
(lp (cons v head) (cdr tail)))))))))
((wow-check-key! z (key n) d t ...)
(let ((v (car z)))
(if (and (vector? v) (= 2 (vector-length v))
(eq? 'key (vector-ref v 0)))
(let ((n (vector-ref v 1)))
(if (and t ...)
(begin (set! z (cdr z)) (vector-ref v 1))
(error "check-lambda[*]: bad argument" n 'n 't ...)))
(let lp ((head (list v)) (tail (cdr z)))
(if (null? tail)
d
(let ((v (car tail)))
(if (and (vector? v) (= 2 (vector-length v))
(eq? 'key (vector-ref v 0)))
(let ((n (vector-ref v 1)))
(if (and t ...)
(begin (set! z (append (reverse head) (cdr tail)))
(vector-ref v 1))
(error "check-lambda[*]: bad argument"
n 'n 't ...)))
(lp (cons v head) (cdr tail)))))))))))
(define-syntax check-opt
(syntax-rules ()
((check-opt z (nd ...) (#((key n) d t ...)) bd ...)
(let (nd ... (n (if (null? z)
d
(if (null? (cdr z))
(wow-check (key n) (car z) t ...)
(error "check-lambda: too many arguments"
(cdr z))))))
bd ...))
((check-opt z (nd ...) (#(n d t ...)) bd ...)
(let (nd ... (n (if (null? z)
d
(if (null? (cdr z))
(wow-check n (car z) t ...)
(error "check-lambda: too many arguments"
(cdr z))))))
bd ...))
((check-opt z (nd ...) (#((key n) d t ...) . e) bd ...)
(let ((x (if (null? z)
d
(wow-check-key! z (key n) d t ...))))
(check-opt z (nd ... (n x)) e bd ...)))
((check-opt z (nd ...) (#(n d t ...) . e) bd ...)
(let ((y (if (null? z) z (cdr z)))
(x (if (null? z)
d
(wow-check n (car z) t ...))))
(check-opt y (nd ... (n x)) e bd ...)))
((check-opt z (nd ...) e bd ...)
(let (nd ... (e z)) bd ...))))
(define-syntax check-opt*
(syntax-rules ()
((check-opt* z (#((key n) d t ...)) bd ...)
(let ((n (if (null? z)
d
(if (null? (cdr z))
(wow-check (key n) (car z) t ...)
(error "check-lambda*: too many arguments" (cdr z))))))
bd ...))
((check-opt* z (#(n d t ...)) bd ...)
(let ((n (if (null? z)
d
(if (null? (cdr z))
(wow-check n (car z) t ...)
(error "check-lambda*: too many arguments" (cdr z))))))
bd ...))
((check-opt* z (#((key n) d t ...) . e) bd ...)
(let ((n (if (null? z)
d
(wow-check-key! z (key n) d t ...))))
(check-opt* z e bd ...)))
((check-opt* z (#(n d t ...) . e) bd ...)
(let ((y (if (null? z) z (cdr z)))
(n (if (null? z)
d
(wow-check n (car z) t ...))))
(check-opt* y e bd ...)))
((check-opt* z e bd ...)
(let ((e z)) bd ...))))
(define-syntax check-lambda
(syntax-rules ()
((check-lambda (#((key n) d t ...) . e) bd ...)
(check-lambda "chk" () () () (#((key n) d t ...)) e bd ...))
((check-lambda (#(n d t ...) . e) bd ...)
(check-lambda "chk" () () (#(n d t ...)) () e bd ...))
((check-lambda ((n t ...) . e) bd ...)
(check-lambda "chk" (tt) ((n t ...)) () () e bd ...))
((check-lambda (n . e) bd ...)
(check-lambda "chk" (tt) ((n)) () () e bd ...))
((check-lambda "chk" (tt ...) (nt ...) (v ...) (k ...) (#((key n) d t ...) . e) bd ...)
(check-lambda "chk" (tt ...) (nt ...) (v ...) (k ... #((key n) d t ...)) e bd ...))
((check-lambda "chk" (tt ...) (nt ...) (v ...) () (#(n d t ...) . e) bd ...)
(check-lambda "chk" (tt ...) (nt ...) (v ... #(n d t ...)) () e bd ...))
((check-lambda "chk" (tt ...) (nt ...) (v ...) (k ...) (#(n d t ...) . e) bd ...)
(error "check-lambda: positional argument should precede named argument"))
((check-lambda "chk" (tt ...) (nt ...) () () ((n t ...) . e) bd ...)
(check-lambda "chk" (tt ... tn) (nt ... (n t ...)) () () e bd ...))
((check-lambda "chk" (tt ...) (nt ...) () () (n . e) bd ...)
(check-lambda "chk" (tt ... tn) (nt ... (n)) () () e bd ...))
((check-lambda "chk" () () (v ...) (k ...) e bd ...)
(lambda z (check-opt z () (v ... k ... . e) bd ...)))
((check-lambda "chk" (tt ...) ((n) ...) () () e bd ...)
(lambda (n ... . e) bd ...))
((check-lambda "chk" (tt ...) ((n) ...) (v ...) (k ...) e bd ...)
(lambda (tt ... . te)
(check-opt te ((n tt) ...) (v ... k ... . e) bd ...)))
((check-lambda "chk" (tt ...) ((n t ...) ...) () () () bd ...)
(lambda (tt ...)
(let ((n (wow-check n tt t ...)) ...) bd ...)))
((check-lambda "chk" (tt ...) ((n t ...) ...) () () e bd ...)
(lambda (tt ... . te)
(let ((n (wow-check n tt t ...)) ... (e te)) bd ...)))
((check-lambda "chk" (tt ...) ((n t ...) ...) (v ...) (k ...) e bd ...)
(lambda (tt ... . te)
(let ((tt (wow-check n tt t ...)) ...)
(check-opt te ((n tt) ...) (v ... k ... . e) bd ...))))
((check-lambda e bd ...)
(lambda e bd ...))))
(define-syntax check-lambda*
(syntax-rules ()
((check-lambda* (#((key n) d t ...) . e) bd ...)
(check-lambda* "chk" () () () (#((key n) d t ...)) e bd ...))
((check-lambda* (#(n d t ...) . e) bd ...)
(check-lambda* "chk" () () (#(n d t ...)) () e bd ...))
((check-lambda* ((n t ...) . e) bd ...)
(check-lambda* "chk" (tt) ((n t ...)) () () e bd ...))
((check-lambda* (n . e) bd ...)
(check-lambda* "chk" (tt) ((n)) () () e bd ...))
((check-lambda* "chk" (tt ...) (nt ...) (v ...) (k ...) (#((key n) d t ...) . e) bd ...)
(check-lambda* "chk" (tt ...) (nt ...) (v ...) (k ... #((key n) d t ...)) e bd ...))
((check-lambda* "chk" (tt ...) (nt ...) (v ...) () (#(n d t ...) . e) bd ...)
(check-lambda* "chk" (tt ...) (nt ...) (v ... #(n d t ...)) () e bd ...))
((check-lambda* "chk" (tt ...) (nt ...) (v ...) (k ...) (#(n d t ...) . e) bd ...)
(error "check-lambda*: positional argument should precede named argument"))
((check-lambda* "chk" (tt ...) (nt ...) () () ((n t ...) . e) bd ...)
(check-lambda* "chk" (tt ... tn) (nt ... (n t ...)) () () e bd ...))
((check-lambda* "chk" (tt ...) (nt ...) () () (n . e) bd ...)
(check-lambda* "chk" (tt ... tn) (nt ... (n)) () () e bd ...))
((check-lambda* "chk" () () (v ...) (k ...) e bd ...)
(lambda z (check-opt* z (v ... k ... . e) bd ...)))
((check-lambda* "chk" (tt ...) ((n) ...) () () () bd ...)
(lambda (tt ...) (let* ((n tt) ...) bd ...)))
((check-lambda* "chk" (tt ...) ((n) ...) () () e bd ...)
(lambda (tt ... . te) (let* ((n tt) ... (e te)) bd ...)))
((check-lambda* "chk" (tt ...) ((n) ...) (v ...) (k ...) e bd ...)
(lambda (tt ... . te)
(let* ((n tt) ...)
(check-opt* te (v ... k ... . e) bd ...))))
((check-lambda* "chk" (tt ...) ((n t ...) ...) () () () bd ...)
(lambda (tt ...)
(let* ((n (wow-check n tt t ...)) ...) bd ...)))
((check-lambda* "chk" (tt ...) ((n t ...) ...) () () e bd ...)
(lambda (tt ... . te)
(let* ((n (wow-check n tt t ...)) ... (e te)) bd ...)))
((check-lambda* "chk" (tt ...) ((n t ...) ...) (v ...) (k ...) e bd ...)
(lambda (tt ... . te)
(let* ((n (wow-check n tt t ...)) ...)
(check-opt* te (v ... k ... . e) bd ...))))
((check-lambda* e bd ...)
(lambda e bd ...))))
(define-syntax wow-float-key!
(syntax-rules ()
((wow-float-key! z (key n) d)
(let ((v (car z)))
(if (and (vector? v)
(= 2 (vector-length v))
(eq? 'key (vector-ref v 0)))
(begin (set! z (cdr z)) (vector-ref v 1))
(let lp ((head (list v)) (tail (cdr z)))
(if (null? tail)
d
(let ((v (car tail)))
(if (and (vector? v)
(= 2 (vector-length v))
(eq? 'key (vector-ref v 0)))
(begin (set! z (append (reverse head) (cdr tail)))
(vector-ref v 1))
(lp (cons v head) (cdr tail)))))))))
((wow-float-key! z (key n) d t ...)
(let ((v (car z)))
(if (and (vector? v)
(= 2 (vector-length v))
(eq? 'key (vector-ref v 0))
(let ((n (vector-ref v 1))) (and t ...)))
(begin (set! z (cdr z)) (vector-ref v 1))
(let lp ((head (list v)) (tail (cdr z)))
(if (null? tail)
d
(let ((v (car tail)))
(if (and (vector? v)
(= 2 (vector-length v))
(eq? 'key (vector-ref v 0))
(let ((n (vector-ref v 1))) (and t ...)))
(begin (set! z (append (reverse head) (cdr tail)))
(vector-ref v 1))
(lp (cons v head) (cdr tail)))))))))
((wow-float-key! z n d)
(let ((n (car z)))
(set! z (cdr z))
n))
((wow-float-key! 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)))))))))))
(define-syntax float-opt
(syntax-rules ()
((float-opt z (nd ...) (#((key n) d t ...)) bd ...)
(let (nd ... (n (if (null? z)
d
(if (null? (cdr z))
(wow-check (key n) (car z) t ...)
(error "float-lambda: too many arguments"
(cdr z))))))
bd ...))
((float-opt z (nd ...) (#(n d t ...)) bd ...)
(let (nd ... (n (if (null? z)
d
(if (null? (cdr z))
(wow-check n (car z) t ...)
(error "float-lambda: too many arguments"
(cdr z))))))
bd ...))
((float-opt z (nd ...) (#((key n) d t ...) . e) bd ...)
(let ((x (if (null? z)
d
(wow-float-key! z (key n) d t ...))))
(float-opt z (nd ... (n x)) e bd ...)))
((float-opt z (nd ...) (#(n d t ...) . e) bd ...)
(let ((x (if (null? z)
d
(wow-float-key! z n d t ...))))
(float-opt z (nd ... (n x)) e bd ...)))
((float-opt z ((n d) ...) e bd ...)
(let ((n d) ... (e z)) bd ...))))
(define-syntax float-opt*
(syntax-rules ()
((float-opt* z (#((key n) d t ...)) bd ...)
(let ((n (if (null? z)
d
(if (null? (cdr z))
(wow-check (key n) (car z) t ...)
(error "float-lambda*: too many arguments" (cdr z))))))
bd ...))
((float-opt* z (#(n d t ...)) bd ...)
(let ((n (if (null? z)
d
(if (null? (cdr z))
(wow-check n (car z) t ...)
(error "float-lambda*: too many arguments" (cdr z))))))
bd ...))
((float-opt* z (#((key n) d t ...) . e) bd ...)
(let ((n (if (null? z)
d
(wow-float-key! z (key n) d t ...))))
(float-opt* z e bd ...)))
((float-opt* z (#(n d t ...) . e) bd ...)
(let ((n (if (null? z)
d
(wow-float-key! z n d t ...))))
(float-opt* z e bd ...)))
((float-opt* z e bd ...)
(let ((e z)) bd ...))))
(define-syntax wow-float!
(syntax-rules ()
((wow-float! z n)
(let ((n (car z)))
(set! z (cdr z)) n))
((wow-float! 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 "float-lambda[*]: 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)))))))))))
(define-syntax slet
(syntax-rules ()
((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 ...))))
(define-syntax float-lambda
(syntax-rules ()
((float-lambda (#((key n) d t ...) . e) bd ...)
(float-lambda "chk" () () () (#((key n) d t ...)) e bd ...))
((float-lambda (#(n d t ...) . e) bd ...)
(float-lambda "chk" () () (#(n d t ...)) () e bd ...))
((float-lambda ((n t ...) . e) bd ...)
(float-lambda "chk" (tt) ((n t ...)) () () e bd ...))
((float-lambda (n . e) bd ...)
(float-lambda "chk" (tt) ((n)) () () e bd ...))
((float-lambda "chk" (tt ...) (nt ...) (v ...) (k ...) (#((key n) d t ...) . e) bd ...)
(float-lambda "chk" (tt ...) (nt ...) (v ...) (k ... #((key n) d t ...)) e bd ...))
((float-lambda "chk" (tt ...) (nt ...) (v ...) () (#(n d t ...) . e) bd ...)
(float-lambda "chk" (tt ...) (nt ...) (v ... #(n d t ...)) () e bd ...))
((float-lambda "chk" (tt ...) (nt ...) (v ...) (k ...) (#(n d t ...) . e) bd ...)
(error "float-lambda: positional argument should precede named argument"))
((float-lambda "chk" (tt ...) (nt ...) () () ((n t ...) . e) bd ...)
(float-lambda "chk" (tt ... tn) (nt ... (n t ...)) () () e bd ...))
((float-lambda "chk" (tt ...) (nt ...) () () (n . e) bd ...)
(float-lambda "chk" (tt ... tn) (nt ... (n)) () () e bd ...))
((float-lambda "chk" () () (v ...) (k ...) e bd ...)
(lambda z (float-opt z () (v ... k ... . e) bd ...)))
((float-lambda "chk" (tt ...) ((n) ...) () () e bd ...)
(lambda (n ... . e) bd ...))
((float-lambda "chk" (tt ...) ((n) ...) (v ...) (k ...) e bd ...)
(lambda (tt ... . te)
(float-opt te ((n tt) ...) (v ... k ... . e) bd ...)))
((float-lambda "chk" (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 (wow-float! z n t ...)) ...) bd ...))))
(let ((n (wow-float! z n t ...)) ...) bd ...))))
((float-lambda "chk" (tt ...) ((n t ...) ...) () () e bd ...)
(lambda (tt ... . te)
(let ((z (list tt ...)))
;;(slet ((n (wow-float! z n t ...)) ... (e te)) bd ...))))
(let ((n (wow-float! z n t ...)) ... (e te)) bd ...))))
((float-lambda "chk" (tt ...) ((n t ...) ...) (v ...) (k ...) e bd ...)
(lambda (tt ... . te)
(let ((z (list tt ...)))
;;(slet ((tt (wow-float! z n t ...)) ...)
(let ((tt (wow-float! z n t ...)) ...)
(float-opt te ((n tt) ...) (v ... k ... . e) bd ...)))))
((float-lambda e bd ...)
(lambda e bd ...))))
(define-syntax float-lambda*
(syntax-rules ()
((float-lambda* (#((key n) d t ...) . e) bd ...)
(float-lambda* "chk" () () () (#((key n) d t ...)) e bd ...))
((float-lambda* (#(n d t ...) . e) bd ...)
(float-lambda* "chk" () () (#(n d t ...)) () e bd ...))
((float-lambda* ((n t ...) . e) bd ...)
(float-lambda* "chk" (tt) ((n t ...)) () () e bd ...))
((float-lambda* (n . e) bd ...)
(float-lambda* "chk" (tt) ((n)) () () e bd ...))
((float-lambda* "chk" (tt ...) (nt ...) (v ...) (k ...) (#((key n) d t ...) . e) bd ...)
(float-lambda* "chk" (tt ...) (nt ...) (v ...) (k ... #((key n) d t ...)) e bd ...))
((float-lambda* "chk" (tt ...) (nt ...) (v ...) () (#(n d t ...) . e) bd ...)
(float-lambda* "chk" (tt ...) (nt ...) (v ... #(n d t ...)) () e bd ...))
((float-lambda* "chk" (tt ...) (nt ...) (v ...) (k ...) (#(n d t ...) . e) bd ...)
(error "float-lambda*: positional argument should precede named argument"))
((float-lambda* "chk" (tt ...) (nt ...) () () ((n t ...) . e) bd ...)
(float-lambda* "chk" (tt ... tn) (nt ... (n t ...)) () () e bd ...))
((float-lambda* "chk" (tt ...) (nt ...) () () (n . e) bd ...)
(float-lambda* "chk" (tt ... tn) (nt ... (n)) () () e bd ...))
((float-lambda* "chk" () () (v ...) (k ...) e bd ...)
(lambda z (float-opt* z (v ... k ... . e) bd ...)))
((float-lambda* "chk" (tt ...) ((n) ...) () () () bd ...)
(lambda (tt ...) (let* ((n tt) ...) bd ...)))
((float-lambda* "chk" (tt ...) ((n) ...) () () e bd ...)
(lambda (tt ... . te) (let* ((n tt) ... (e te)) bd ...)))
((float-lambda* "chk" (tt ...) ((n) ...) (v ...) (k ...) e bd ...)
(lambda (tt ... . te)
(let* ((n tt) ...)
(float-opt* te (v ... k ... . e) bd ...))))
((float-lambda* "chk" (tt ...) ((n t ...) ...) () () () bd ...)
(lambda (tt ...)
(let ((z (list tt ...)))
(let* ((n (wow-float! z n t ...)) ...) bd ...))))
((float-lambda* "chk" (tt ...) ((n t ...) ...) () () e bd ...)
(lambda (tt ... . te)
(let ((z (list tt ...)))
(let* ((n (wow-float! z n t ...)) ... (e te)) bd ...))))
((float-lambda* "chk" (tt ...) ((n t ...) ...) (v ...) (k ...) e bd ...)
(lambda (tt ... . te)
(let ((z (list tt ...)))
(let* ((n (wow-float! z n t ...)) ...)
(float-opt* te (v ... k ... . e) bd ...)))))
((float-lambda* e bd ...)
(lambda e bd ...))))
(define-syntax cond-lambda
(syntax-rules ()
((cond-lambda (formals bd ...) cl ...)
(lambda z (let ((len (length z)))
(cond-lambda "*" z len (formals bd ...) cl ...))))
((cond-lambda "*" z len (() bd ...) cl ...)
(if (= len 0)
((lambda () bd ...))
(cond-lambda "*" z len cl ...)))
((cond-lambda "*" z len (((n t ...) . e) bd ...) cl ...)
(cond-lambda " " z len (tt) ((n t ...)) (e bd ...) cl ...))
((cond-lambda "*" z len ((n . e) bd ...) cl ...)
(cond-lambda " " z len (tt) ((n)) (e bd ...) cl ...))
((cond-lambda "*" z len (e bd ...) cl ...)
(let ((e z)) bd ...))
((cond-lambda "*" z len)
(error "the arguments are not matched to any clause of cond-lambda" z))
((cond-lambda " " z len (tt ...) (nt ...) (((n t ...) . e) bd ...) cl ...)
(cond-lambda " " z len (tt ... tn) (nt ... (n t ...)) (e bd ...) cl ...))
((cond-lambda " " z len (tt ...) (nt ...) ((n . e) bd ...) cl ...)
(cond-lambda " " z len (tt ... tn) (nt ... (n)) (e bd ...) cl ...))
((cond-lambda " " z len (tt ...) ((n) ...) (() bd ...) cl ...)
(if (= len (length '(tt ...)))
(apply (lambda (n ...) bd ...) z)
(cond-lambda "*" z len cl ...)))
((cond-lambda " " 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)
(cond-lambda "*" z len cl ...)))
((cond-lambda " " z len (tt ...) ((n) ...) (e bd ...) cl ...)
(if (>= len (length '(tt ...)))
(apply (lambda (n ... . e) bd ...) z)
(cond-lambda "*" z len cl ...)))
((cond-lambda " " 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)
(cond-lambda "*" z len cl ...)))))
(define-syntax cond-and*
(syntax-rules ()
((cond-and* ((n v t ...)))
(let ((n v))
(and t ...)))
((cond-and* ((n v t ...) nvt ...))
(let ((n v))
(and t ... (cond-and* (nvt ...)))))))
(define-syntax cond-lambda*
(syntax-rules ()
((cond-lambda* (formals bd ...) cl ...)
(lambda z (let ((len (length z)))
(cond-lambda* "*" z len (formals bd ...) cl ...))))
((cond-lambda* "*" z len (() bd ...) cl ...)
(if (= len 0)
((lambda () bd ...))
(cond-lambda* "*" z len cl ...)))
((cond-lambda* "*" z len (((n t ...) . e) bd ...) cl ...)
(cond-lambda* " " z len (tt) ((n t ...)) (e bd ...) cl ...))
((cond-lambda* "*" z len ((n . e) bd ...) cl ...)
(cond-lambda* " " z len (tt) ((n)) (e bd ...) cl ...))
((cond-lambda* "*" z len (e bd ...) cl ...)
(let ((e z)) bd ...))
((cond-lambda* "*" z len)
(error "the arguments are not matched to any clause of cond-lambda*" z))
((cond-lambda* " " z len (tt ...) (nt ...) (((n t ...) . e) bd ...) cl ...)
(cond-lambda* " " z len (tt ... tn) (nt ... (n t ...)) (e bd ...) cl ...))
((cond-lambda* " " z len (tt ...) (nt ...) ((n . e) bd ...) cl ...)
(cond-lambda* " " z len (tt ... tn) (nt ... (n)) (e bd ...) cl ...))
((cond-lambda* " " z len (tt ...) ((n) ...) (() bd ...) cl ...)
(if (= len (length '(tt ...)))
(apply (lambda (tt ...) (let* ((n tt) ...) bd ...)) z)
(cond-lambda* "*" z len cl ...)))
((cond-lambda* " " z len (tt ...) ((n t ...) ...) (() bd ...) cl ...)
(if (and (= len (length '(tt ...)))
(apply (lambda (tt ...) (cond-and* ((n tt t ...) ...))) z))
(apply (lambda (tt ...) (let* ((n tt) ...) bd ...)) z)
(cond-lambda* "*" z len cl ...)))
((cond-lambda* " " z len (tt ...) ((n) ...) (e bd ...) cl ...)
(if (>= len (length '(tt ...)))
(apply (lambda (tt ... . te) (let* ((n tt) ... (e te)) bd ...)) z)
(cond-lambda* "*" z len cl ...)))
((cond-lambda* " " z len (tt ...) ((n t ...) ...) (e bd ...) cl ...)
(if (and (>= len (length '(tt ...)))
(apply (lambda (tt ...) (cond-and* ((n tt t ...) ...))) z))
(apply (lambda (tt ... . te) (let* ((n tt) ... (e te)) bd ...)) z)
(cond-lambda* "*" z len cl ...)))))
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/srfi-16/
[SRFI 51] Joo ChurlSoo: Handling rest list.
http://srfi.schemers.org/srfi-51/
Scsh Olin Shivers, Brian Carlstrom, Martin Gasbichler, Mike Sperber
http://www.scsh.net
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.
