Title ALAMBDA and ALAMBDA* Author Joo ChurlSoo Abstract This SRFI introduces ALAMBDA and ALAMBDA*, each of which has two modes of operation: 1. it creates a procedure that checks actual arguments and takes optional arguments, 2. it returns a different procedure by checking each of actual arguments and the number of them. Rationale The first mode of operation 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 LET-OPTIONALS and LET-KEYWORDS into a single syntax. Optional variables include not only optional fixed variables but also optional non-fixed variables. The formers are the same as those of `opt' form of ALET and the latters are the same as those of `cat' and `key' forms of ALET (see SRFI-86). The following are examples to show the similarities. 1. optional fixed variables (`opt' form): ((lambda (str . rest) (alet* ((len (string-length str)) (opt rest (start 0 (and (integer? start) (<= 0 start len))) (end len (and (integer? end) (<= start end len))))) (substring str start end))) "abcdefg" 1 6) => "bcdef" ((alambda* (str "opt" (start 0 (and (integer? start) (<= 0 start (string-length str)))) (end (string-length str) (and (integer? end) (<= start end (string-length str))))) (substring str start end)) "abcdefg" 1 6) => "bcdef" 2. optional non-fixed non-named variables (`cat' form): ((lambda (str . rest) (alet ((cat rest (start 0 (and (list? start) (= 2 (length start)) (eq? 'start (car start))) (cadr start)) ; true (end (string-length str) (and (list? end) (= 2 (length end)) (eq? 'end (car end))) (cadr end)))) ; true (substring str start end))) "abcdefg" '(end 6) '(start 1)) => "bcdef" ((alambda* (str "cat" (start 0 (and (list? start) (= 2 (length start)) (eq? 'start (car start))) (cadr start)) ; true (end (string-length str) (and (list? end) (= 2 (length end)) (eq? 'end (car end))) (cadr end))) ; true (substring str start end)) "abcdefg" '(end 6) '(start 1)) => "bcdef" 3. optional non-fixed named variables (`key' form): ((lambda (str . rest) (alet* ((len (string-length str)) (key rest (start 0 (and (integer? start) (<= 0 start len))) (end len (and (integer? end) (<= start end len))))) (substring str start end))) "abcdefg" 'end 6 'start 1) => "bcdef" ((alambda* (str "key" (start 0 (and (integer? start) (<= 0 start (string-length str)))) (end (string-length str) (and (integer? end) (<= start end (string-length str))))) (substring str start end)) "abcdefg" 'end 6 'start 1) => "bcdef" Like optional variables, required variables can be divded into three groups, namely, conventional required fixed variables, required non-fixed non-named variables, and required non-fixed named variables. These are best explained by simple examples. 1. required fixed variables: (define vec-ref (alambda* ((vec (vector? vec)) (num (and (integer? num) (<= 0 num) (< num (vector-length vec))))) (vector-ref vec num))) (vec-ref '#(1 2 3) 1) => 2 (vec-ref 1 '#(1 2 3)) => bad argument 1 vec (vector? vec) (vec-ref '#(1 2 3)) => wrong number of arguments 2. required non-fixed non-named variables: (define str-ref (alambda* ("required cat" (str (string? str)) (n (and (integer? n) (<= 0 n) (< n (string-length str))))) (string-ref str n))) (str-ref "abc" 1) => #\b (str-ref 1 "abc") => #\b (str-ref 1 2) => bad arguments (1 2) str (string? str) (str-ref "abc") => wrong number of arguments 3. required non-fixed named variables: (define lis-ref (alambda* ("required key" (lis (list? lis)) (num (and (integer? num) (<= 0 num) (< num (length lis))))) (list-ref lis num))) (lis-ref 'num 1 'lis '(1 2 3)) => 2 (lis-ref 'lis '(1 2 3) 'num 1) => 2 (lis-ref 'lis '(1 2 3) 'nu 3) => no corresponding value to key num (nu 3) (lis-ref 'lis '(1 2 3) 'nu) => wrong number of arguments The second mode of operation reduces the clutter of procedures more precisely than CASE-LAMBDA of SRFI-16 by adding to its formal argument list to check each of actual arguments. The following are examples to show the differences. (define list-ref/set! (case-lambda ((a b) (list-ref a b)) ((a b c) (set-car! (list-tail a b) c)) (a (error "bad arguments" a)))) (define ref/set! (alambda (cond (((a (list? a)) b) (list-ref a b)) (((a (string? a)) b) (string-ref a b)) (((a (vector? a)) b) (vector-ref a b)) (((a (list? a)) b c) (set-car! (list-tail a b) c)) (((a (string? a)) b c) (string-set! a b c)) (((a (vector? a)) b c) (vector-set! a b c)) (a (error "bad arguments" a))))) Specification The syntax is defined in the extended BNF of R5RS. (alambda ) (alambda* ) syntax-rules identifier: cond --> | (cond +) --> | ( ) | ( ) | ( ) | ( . ) | ( . ) | ( . ) | | () --> + | * --> | ( ) --> | | --> | | | --> "required cat" + --> "required key" + --> | (( )) | (( ) ) --> | | | | | | | | --> "opt" + --> | ( ) | ( ) --> "cat" + --> "key" + --> | (( )) | (( ) ) | (( ) ) --> #f | #t | --> --> --> --> --> --> ( ) --> (*) | | (+ . ) --> | ( ) The ALAMBDA* is to the ALAMBDA what the LET* is to the LET. The s, s, s, and s of ALAMBDA* are evaluated in an environment that all the bindings of previous s are visible. 1. the first mode of operation: There are three kinds of required variables, namely, required fixed variable, required non-fixed non-named variable, and required non-fixed named variable. They determine the number of required actual arguments, that is, the minimum arity of the resulting procedure. The required fixed variables are placed before any string marker in . They are bound to successive actual arguments starting with the first actual argument. If there is a , it is evaluated. If it returns a false value and there is no , an error is signaled. If it returns a false value and there is a , the variable is rebound to the result of evaluating instead of signaling an error. If it returns a true value and there is a , the variable is rebound to the result of evaluating . The required non-fixed non-named variables follow a "required cat" marker in . The variable is temporarily bound to each of remaining required actual arguments sequentially, until returns a true value, then the variable is finally bound to the passed argument. If there is no , the first one of the remaining required actual arguments is regarded as passing. If any actual argument does not pass , an error is signaled. If there is a and returns a false value, the variable is finally bound to the result of evaluating instead of the above process. If there is a and returns a true value, the variable is rebound to the result of evaluating . The required non-fixed named variables follow a "required key" marker in . Unlike SRFI-89, the keywords are not self-evaluating symbols, but any scheme objects. The keyword used at a call site for the corresponding variable is a symbol of the same name as the variable. But the keyword can be any scheme object when the required parameter is specified as a double parenthesized variable and a keyword. The remaining required actual arguments must be an even number. They are sequentially interpreted as a series of pairs, where the first member of each pair is a keyword corresponding to the variable, and the second is the corresponding value. If there is no element for a particular keyword, an error is signaled. When there is a , it is evaluated. If it returns a false value and there is no , an error is signaled. If it returns a false value and there is a , the variable is rebound to the result of evaluating instead of signaling an error. If it returns a true value and there is a , the variable is rebound to the result of evaluating . The optional fixed variables follow an "opt" marker in . The binding method is the same as that of the required fixed variables except that the variable is bound to the result of evaluating instead of signaling an error if there are no remaining actual arguments. If is not specified, #f is the default. The optional non-fixed non-named variables follow a "cat" marker in . The binding method is the same as that of the required non-fixed non-named variables except that the variable is bound to the result of evaluating instead of signaling an error if any actual argument does not pass . If is not specified, #f is the default. The optional non-fixed named variables follow a "key" marker in . The binding method is the same as that of the required non-fixed named variables except that the variable is bound to the result of evaluating instead of signaling an error if there is no corresponding value to a particular keyword. If is not specified, #f is the default. The following key options can be used to control binding behavior in case that the keyword of keyword-value pair at the call site is different from any keywords specified in . 1. default -- The remaining actual arguments are continually interpreted as a series of pairs. 2. #f -- An error is signaled in case of required non-fixed named variables. In case of optional non-fixed named variables, the variable is bound to the corresponding . 3. #t -- The remaining actual arguments are continually interpreted as a single element until the element is a particular keyword. When there are remaining actual arguments, an error is signaled if dotted rest variable is not given. If dotted rest variable is given, it is bound to the remaining actual arguments. 2. the second mode of operation: This is an extended form of CASE-LAMBDA of SRFI-16. Like CASE-LAMBDA, it returns a procedure of the first , the of which is matched with the number of actual arguments. But if there is a and the result of evaluation returns a false value, the subsequent is processed in spite of the match. If no matches, an error is signaled. Examples ((alambda (a (b (number? b)) "opt" (c 10) "key" ((d 'dd) 30 (number? d)) e ((f "ff") 40) (g 50) . h) (list a b c d e f g h)) 0 1 2 'dd 3 44 55 'g 6 'dd 4 'f 66 77 "ff" 5) => (0 1 2 3 #f 40 6 (44 55 dd 4 f 66 77 "ff" 5)) ((alambda (a (b (number? b)) "opt" (c 10) "key" ((d 'dd) 30 (number? d)) e ((f "ff") 40) (g 50) #f . h) (list a b c d e f g h)) 0 1 2 'dd 3 44 55 'g 6 'dd 4 'f 66 77 "ff" 5) => (0 1 2 3 #f 40 50 (44 55 g 6 dd 4 f 66 77 "ff" 5)) ((alambda (a (b (number? b)) "opt" (c 10) "key" ((d 'dd) 30 (number? d)) e ((f "ff") 40) (g 50) #t . h) (list a b c d e f g h)) 0 1 2 'dd 3 44 55 'g 6 'dd 4 'f 66 77 "ff" 5) => (0 1 2 3 #f 5 6 (44 55 dd 4 f 66 77)) (define ref/set! (alambda* (cond (((a (list? a)) (b (and (integer? b) (<= 0 b) (< b (length a))))) (list-ref a b)) (((a (string? a)) (b (and (integer? b) (<= 0 b) (< b (string-length a))))) (string-ref a b)) (((a (vector? a)) (b (and (integer? b) (<= 0 b) (< b (vector-length a))))) (vector-ref a b)) (((a (list? a)) (b (and (integer? b) (<= 0 b) (< b (length a)))) c) (set-car! (list-tail a b) c)) (((a (string? a)) (b (and (integer? b) (<= 0 b) (< b (string-length a)))) (c (char? c))) (string-set! a b c)) (((a (vector? a)) (b (and (integer? b) (<= 0 b) (< b (vector-length a)))) c) (vector-set! a b c)) (a (error "bad arguments" a))))) (let ((str (string #\a #\b #\c)) (lis (list 1 2 3)) (vec (vector 4 5 6))) (display (ref/set! str 1)) (display " ") (display (ref/set! lis 1)) (display " ") (display (ref/set! vec 1)) (newline) (display str) (display " ") (display lis) (display " ") (display vec) (newline) (ref/set! str 1 #\z) (ref/set! lis 1 8) (ref/set! vec 1 9) (display str) (display " ") (display lis) (display " ") (display vec) (newline)) => b 2 5 abc (1 2 3) #(4 5 6) azc (1 8 3) #(4 9 6) Implementation The following implementation is written in R5RS hygienic macros and requires SRFI-23 (Error reporting mechanism). (define-syntax alambda (syntax-rules (cond) ((alambda (g . e) b d ...) (%alambda "chk" () (() () () ()) () () () (() ()) () (g . e) b d ...)) ((alambda (cond clause cl ...)) (lambda z (let ((len (length z))) (check-cond z len () () clause cl ...)))) ((alambda e b d ...) (lambda e b d ...)))) (define-syntax %alambda (syntax-rules () ;; "chk" ((%alambda "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("required cat" . e) bd ...) (%alambda "rat" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ((%alambda "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("required key" . e) bd ...) (%alambda "rey" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ((%alambda "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("opt" . e) bd ...) (%alambda "opt" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ((%alambda "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("cat" . e) bd ...) (%alambda "cat" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ((%alambda "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("key" . e) bd ...) (%alambda "key" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ;; "rat" ((%alambda "rat" () ((h ...) (i in ...) () ()) (r ...) (rk ...) () (() ()) () ("required key" . e) bd ...) (%alambda "rey" () ((h ...) (i in ...) () ()) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda "rat" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("opt" . e) bd ...) (%alambda "opt" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda "rat" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("cat" . e) bd ...) (%alambda "cat" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda "rat" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("key" . e) bd ...) (%alambda "key" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ;; "rey" ((%alambda "rey" () ((h ...) () (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("required cat" . e) bd ...) (%alambda "rat" () ((h ...) () (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda "rey" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("opt" . e) bd ...) (%alambda "opt" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda "rey" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("cat" . e) bd ...) (%alambda "cat" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda "rey" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("key" . e) bd ...) (%alambda "key" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ;; "opt" ((%alambda "opt" () hijk (r ...) (rk ...) (o on ...) (() ()) () ("cat" . e) bd ...) (%alambda "cat" () hijk (r ...) (rk ...) (o on ...) (() ()) () e bd ...)) ((%alambda "opt" () hijk (r ...) (rk ...) (o on ...) (() ()) () ("key" . e) bd ...) (%alambda "key" () hijk (r ...) (rk ...) (o on ...) (() ()) () e bd ...)) ;; "cat" ((%alambda "cat" () hijk (r ...) (rk ...) (o ...) ((c cn ...) ()) (ok ...) ("key" . e) bd ...) (%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c cn ...) ()) (ok ...) e bd ...)) ;; "key" ((%alambda "key" () hijk (r ...) (rk ...) (o ...) (() (k kn ...)) (ok ...) ("cat" . e) bd ...) (%alambda "cat" () hijk (r ...) (rk ...) (o ...) (() (k kn ...)) (ok ...) e bd ...)) ;; key option ((%alambda check () ((h ...) (i ...) (j ...) (jk jkn ...)) (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (#t . e) bd ...) (%alambda check (#t) ((h ...) (i ...) (j ...) (jk jkn ...)) (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) e bd ...)) ((%alambda check () ((h ...) (i ...) (j ...) (jk jkn ...)) (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (#f . e) bd ...) (%alambda check (#f) ((h ...) (i ...) (j ...) (jk jkn ...)) (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) e bd ...)) ((%alambda check () hijk (r ...) (rk ...) (o ...) ((c ...) (k kn ...)) (ok ...) (#t . e) bd ...) (%alambda check (#t) hijk (r ...) (rk ...) (o ...) ((c ...) (k kn ...)) (ok ...) e bd ...)) ((%alambda check () hijk (r ...) (rk ...) (o ...) ((c ...) (k kn ...)) (ok ...) (#f . e) bd ...) (%alambda check (#f) hijk (r ...) (rk ...) (o ...) ((c ...) (k kn ...)) (ok ...) e bd ...)) ;; required fix arguments ((%alambda "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ((n t s ...) . e) bd ...) (%alambda "chk" () ((h ... hn) () () ()) (r ... (n t s ...)) () () (() ()) () e bd ...)) ((%alambda "chk" () ((h ...) () () ()) (r ...) () () (() ()) () (n . e) bd ...) (%alambda "chk" () ((h ... hn) () () ()) (r ... (n)) () () (() ()) () e bd ...)) ;; required cat arguments ((%alambda "rat" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ((n t s ...) . e) bd ...) (%alambda "rat" () ((h ...) (i ... in) (j ...) (jk ...)) (r ...) (rk ... ((n) t s ...)) () (() ()) () e bd ...)) ((%alambda "rat" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () (n . e) bd ...) (%alambda "rat" () ((h ...) (i ... in) (j ...) (jk ...)) (r ...) (rk ... ((n))) () (() ()) () e bd ...)) ;; required key arguments ((%alambda "rey" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () (((n key) t ...) . e) bd ...) (%alambda "rey" () ((h ...) (i ...) (j ... jm jn) (jk ... key)) (r ...) (rk ... ((n key) t ...)) () (() ()) () e bd ...)) ((%alambda "rey" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ((n t s ...) . e) bd ...) (%alambda "rey" () ((h ...) (i ...) (j ... jm jn) (jk ... 'n)) (r ...) (rk ... ((n 'n) t s ...)) () (() ()) () e bd ...)) ((%alambda "rey" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () (n . e) bd ...) (%alambda "rey" () ((h ...) (i ...) (j ... jm jn) (jk ... 'n)) (r ...) (rk ... ((n 'n))) () (() ()) () e bd ...)) ;; optional fix arguments ((%alambda "opt" () hijk (r ...) (rk ...) (o ...) (() ()) () ((n d t ...) . e) bd ...) (%alambda "opt" () hijk (r ...) (rk ...) (o ... (n d t ...)) (() ()) () e bd ...)) ((%alambda "opt" () hijk (r ...) (rk ...) (o ...) (() ()) () (n . e) bd ...) (%alambda "opt" () hijk (r ...) (rk ...) (o ... (n #f)) (() ()) () e bd ...)) ;; optional cat arguments ((%alambda "cat" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) ((n d t ...) . e) bd ...) (%alambda "cat" () hijk (r ...) (rk ...) (o ...) ((c ... n) (k ...)) (ok ... ((n) d t ...)) e bd ...)) ((%alambda "cat" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (n . e) bd ...) (%alambda "cat" () hijk (r ...) (rk ...) (o ...) ((c ... n) (k ...)) (ok ... ((n) #f)) e bd ...)) ;; optional key arguments ((%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (((n key) d t ...) . e) bd ...) (%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ... key)) (ok ... ((n key) d t ...)) e bd ...)) ((%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (((n key)) . e) bd ...) (%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ... key)) (ok ... ((n key) #f)) e bd ...)) ((%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) ((n d t ...) . e) bd ...) (%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ... 'n)) (ok ... ((n 'n) d t ...)) e bd ...)) ((%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (n . e) bd ...) (%alambda "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ... 'n)) (ok ... ((n 'n) #f)) e bd ...)) ;; main ((%alambda check () hijk ((n) ...) () () (() ()) () e bd ...) (lambda (n ... . e) bd ...)) ((%alambda check dft ((h ...) (i ...) (j ...) jk) ((n t ...) ...) (((rn rk ...) rt ...) ...) () (() ()) () () bd ...) (lambda (h ... i ... j ...) (let ((zz (list i ... j ...))) (let ((n (wow-opt n h t ...)) ... (rn (wow-req! zz dft jk (rn rk ...) rt ...)) ...) bd ...)))) ((%alambda check dft ((h ...) (i ...) (j ...) jk) ((n t ...) ...) (((rn rk ...) rt ...) ...) () (() ()) () e bd ...) (lambda (h ... i ... j ... . te) (let ((zz (list i ... j ...))) (let ((n (wow-opt n h t ...)) ... (rn (wow-req! zz dft jk (rn rk ...) rt ...)) ... (e te)) bd ...)))) ((%alambda check dft ((h ...) () () ()) ((n) ...) () (o ...) ((c ...) (k ...)) (ondt ...) e bd ...) (lambda (h ... . te) (check-opt te dft ((n h) ...) (o ...) (ondt ...) e (k ...) bd ...))) ((%alambda check dft ((h ...) (i ...) (j ...) jk) ((n t ...) ...) (((rn rk ...) rt ...) ...) (o ...) ((c ...) (k ...)) (ondt ...) e bd ...) (lambda (h ... i ... j ... . te) (let ((zz (list i ... j ...))) (check-opt te dft ((n (wow-opt n h t ...)) ... (rn (wow-req! zz dft jk (rn rk ...) rt ...)) ...) (o ...) (ondt ...) e (k ...) bd ...)))))) (define-syntax alambda* (syntax-rules (cond) ((alambda* (g . e) b d ...) (%alambda* "chk" () (() () () ()) () () () (() ()) () (g . e) b d ...)) ((alambda* (cond clause cl ...)) (lambda z (let ((len (length z))) (check-cond* z len () () clause cl ...)))) ((alambda* e b d ...) (lambda e b d ...)))) (define-syntax %alambda* (syntax-rules () ;; "chk" ((%alambda* "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("required cat" . e) bd ...) (%alambda* "rat" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ((%alambda* "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("required key" . e) bd ...) (%alambda* "rey" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ((%alambda* "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("opt" . e) bd ...) (%alambda* "opt" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ((%alambda* "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("cat" . e) bd ...) (%alambda* "cat" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ((%alambda* "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ("key" . e) bd ...) (%alambda* "key" () ((h ...) () () ()) (r ...) () () (() ()) () e bd ...)) ;; "rat" ((%alambda* "rat" () ((h ...) (i in ...) () ()) (r ...) (rk ...) () (() ()) () ("required key" . e) bd ...) (%alambda* "rey" () ((h ...) (i in ...) () ()) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda* "rat" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("opt" . e) bd ...) (%alambda* "opt" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda* "rat" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("cat" . e) bd ...) (%alambda* "cat" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda* "rat" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("key" . e) bd ...) (%alambda* "key" () ((h ...) (i in ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ;; "rey" ((%alambda* "rey" () ((h ...) () (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("required cat" . e) bd ...) (%alambda* "rat" () ((h ...) () (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda* "rey" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("opt" . e) bd ...) (%alambda* "opt" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda* "rey" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("cat" . e) bd ...) (%alambda* "cat" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ((%alambda* "rey" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () ("key" . e) bd ...) (%alambda* "key" () ((h ...) (i ...) (j jn ...) (jk ...)) (r ...) (rk ...) () (() ()) () e bd ...)) ;; "opt" ((%alambda* "opt" () hijk (r ...) (rk ...) (o on ...) (() ()) () ("cat" . e) bd ...) (%alambda* "cat" () hijk (r ...) (rk ...) (o on ...) (() ()) () e bd ...)) ((%alambda* "opt" () hijk (r ...) (rk ...) (o on ...) (() ()) () ("key" . e) bd ...) (%alambda* "key" () hijk (r ...) (rk ...) (o on ...) (() ()) () e bd ...)) ;; "cat" ((%alambda* "cat" () hijk (r ...) (rk ...) (o ...) ((c cn ...) ()) (ok ...) ("key" . e) bd ...) (%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c cn ...) ()) (ok ...) e bd ...)) ;; "key" ((%alambda* "key" () hijk (r ...) (rk ...) (o ...) (() (k kn ...)) (ok ...) ("cat" . e) bd ...) (%alambda* "cat" () hijk (r ...) (rk ...) (o ...) (() (k kn ...)) (ok ...) e bd ...)) ;; key option ((%alambda* check () ((h ...) (i ...) (j ...) (jk jkn ...)) (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (#t . e) bd ...) (%alambda* check (#t) ((h ...) (i ...) (j ...) (jk jkn ...)) (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) e bd ...)) ((%alambda* check () ((h ...) (i ...) (j ...) (jk jkn ...)) (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (#f . e) bd ...) (%alambda* check (#f) ((h ...) (i ...) (j ...) (jk jkn ...)) (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) e bd ...)) ((%alambda* check () hijk (r ...) (rk ...) (o ...) ((c ...) (k kn ...)) (ok ...) (#t . e) bd ...) (%alambda* check (#t) hijk (r ...) (rk ...) (o ...) ((c ...) (k kn ...)) (ok ...) e bd ...)) ((%alambda* check () hijk (r ...) (rk ...) (o ...) ((c ...) (k kn ...)) (ok ...) (#f . e) bd ...) (%alambda* check (#f) hijk (r ...) (rk ...) (o ...) ((c ...) (k kn ...)) (ok ...) e bd ...)) ;; required fix arguments ((%alambda* "chk" () ((h ...) () () ()) (r ...) () () (() ()) () ((n t s ...) . e) bd ...) (%alambda* "chk" () ((h ... hn) () () ()) (r ... (n t s ...)) () () (() ()) () e bd ...)) ((%alambda* "chk" () ((h ...) () () ()) (r ...) () () (() ()) () (n . e) bd ...) (%alambda* "chk" () ((h ... hn) () () ()) (r ... (n)) () () (() ()) () e bd ...)) ;; required cat arguments ((%alambda* "rat" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ((n t s ...) . e) bd ...) (%alambda* "rat" () ((h ...) (i ... in) (j ...) (jk ...)) (r ...) (rk ... ((n) t s ...)) () (() ()) () e bd ...)) ((%alambda* "rat" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () (n . e) bd ...) (%alambda* "rat" () ((h ...) (i ... in) (j ...) (jk ...)) (r ...) (rk ... ((n))) () (() ()) () e bd ...)) ;; required key arguments ((%alambda* "rey" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () (((n key) t ...) . e) bd ...) (%alambda* "rey" () ((h ...) (i ...) (j ... jm jn) (jk ... key)) (r ...) (rk ... ((n key) t ...)) () (() ()) () e bd ...)) ((%alambda* "rey" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () ((n t s ...) . e) bd ...) (%alambda* "rey" () ((h ...) (i ...) (j ... jm jn) (jk ... 'n)) (r ...) (rk ... ((n 'n) t s ...)) () (() ()) () e bd ...)) ((%alambda* "rey" () ((h ...) (i ...) (j ...) (jk ...)) (r ...) (rk ...) () (() ()) () (n . e) bd ...) (%alambda* "rey" () ((h ...) (i ...) (j ... jm jn) (jk ... 'n)) (r ...) (rk ... ((n 'n))) () (() ()) () e bd ...)) ;; optional fix arguments ((%alambda* "opt" () hijk (r ...) (rk ...) (o ...) (() ()) () ((n d t ...) . e) bd ...) (%alambda* "opt" () hijk (r ...) (rk ...) (o ... (n d t ...)) (() ()) () e bd ...)) ((%alambda* "opt" () hijk (r ...) (rk ...) (o ...) (() ()) () (n . e) bd ...) (%alambda* "opt" () hijk (r ...) (rk ...) (o ... (n #f)) (() ()) () e bd ...)) ;; optional cat arguments ((%alambda* "cat" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) ((n d t ...) . e) bd ...) (%alambda* "cat" () hijk (r ...) (rk ...) (o ...) ((c ... n) (k ...)) (ok ... ((n) d t ...)) e bd ...)) ((%alambda* "cat" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (n . e) bd ...) (%alambda* "cat" () hijk (r ...) (rk ...) (o ...) ((c ... n) (k ...)) (ok ... ((n) #f)) e bd ...)) ;; optional key arguments ((%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (((n key) d t ...) . e) bd ...) (%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ... key)) (ok ... ((n key) d t ...)) e bd ...)) ((%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (((n key)) . e) bd ...) (%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ... key)) (ok ... ((n key) #f)) e bd ...)) ((%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) ((n d t ...) . e) bd ...) (%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ... 'n)) (ok ... ((n 'n) d t ...)) e bd ...)) ((%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ...)) (ok ...) (n . e) bd ...) (%alambda* "key" () hijk (r ...) (rk ...) (o ...) ((c ...) (k ... 'n)) (ok ... ((n 'n) #f)) e bd ...)) ;; main ((%alambda* check () ((h ...) () () ()) ((n) ...) () () (()()) () () bd ...) (lambda (h ...) (let* ((n h) ...) bd ...))) ((%alambda* check () ((h ...) () () ()) ((n) ...) () () (()()) () e bd ...) (lambda (h ... . te) (let* ((n h) ... (e te)) bd ...))) ((%alambda* check dft ((h ...) (i ...) (j ...) jk) ((n t ...) ...) (((rn rk ...) rt ...) ...) () (() ()) () () bd ...) (lambda (h ... i ... j ...) (let ((zz (list i ... j ...))) (let* ((n (wow-opt n h t ...)) ... (rn (wow-req! zz dft jk (rn rk ...) rt ...)) ...) bd ...)))) ((%alambda* check dft ((h ...) (i ...) (j ...) jk) ((n t ...) ...) (((rn rk ...) rt ...) ...) () (() ()) () e bd ...) (lambda (h ... i ... j ... . te) (let ((zz (list i ... j ...))) (let* ((n (wow-opt n h t ...)) ... (rn (wow-req! zz dft jk (rn rk ...) rt ...)) ... (e te)) bd ...)))) ((%alambda* check dft ((h ...) () () ()) ((n) ...) () (o ...) ((c ...) (k ...)) (ondt ...) e bd ...) (lambda (h ... . te) (let* ((n h) ...) (check-opt* te dft (o ...) (ondt ...) e (k ...) bd ...)))) ((%alambda* check dft ((h ...) (i ...) (j ...) jk) ((n t ...) ...) (((rn rk ...) rt ...) ...) (o ...) ((c ...) (k ...)) (ondt ...) e bd ...) (lambda (h ... i ... j ... . te) (let ((zz (list i ... j ...))) (let* ((n (wow-opt n h t ...)) ... (rn (wow-req! zz dft jk (rn rk ...) rt ...)) ...) (check-opt* te dft (o ...) (ondt ...) e (k ...) bd ...))))))) (define-syntax check-cond (syntax-rules () ((check-cond z len (tt ...) (nt ...) (((n t) . e) bd ...) cl ...) (check-cond z len (tt ... tn) (nt ... (n t)) (e bd ...) cl ...)) ((check-cond z len (tt ...) (nt ...) ((n . e) bd ...) cl ...) (check-cond z len (tt ... tn) (nt ... (n)) (e bd ...) cl ...)) ((check-cond z len () () (() bd ...) cl ...) (if (= len 0) ((lambda () bd ...)) (check-cond z len () () cl ...))) ((check-cond z len () () (e bd ...) cl ...) (let ((e z)) bd ...)) ((check-cond z len (tt ...) ((n) ...) (() bd ...) cl ...) (if (= len (length '(tt ...))) (apply (lambda (n ...) bd ...) z) (check-cond z len () () cl ...))) ((check-cond z len (tt ...) ((n t ...) ...) (() bd ...) cl ...) (if (and (= len (length '(tt ...))) (apply (lambda (tt ...) (cond-and ((n tt t ...) ...))) z)) (apply (lambda (n ...) bd ...) z) (check-cond z len () () cl ...))) ((check-cond z len (tt ...) ((n) ...) (e bd ...) cl ...) (if (>= len (length '(tt ...))) (apply (lambda (n ... . e) bd ...) z) (check-cond z len () () cl ...))) ((check-cond z len (tt ...) ((n t ...) ...) (e bd ...) cl ...) (if (and (>= len (length '(tt ...))) (apply (lambda (tt ...) (cond-and ((n tt t ...) ...))) z)) (apply (lambda (n ... . e) bd ...) z) (check-cond z len () () cl ...))) ((check-cond z len (tt ...) (nt ...)) (error "actual arguments are not matched to any clause of alambda" z)))) (define-syntax check-cond* (syntax-rules () ((check-cond* z len (tt ...) (nt ...) (((n t) . e) bd ...) cl ...) (check-cond* z len (tt ... tn) (nt ... (n t)) (e bd ...) cl ...)) ((check-cond* z len (tt ...) (nt ...) ((n . e) bd ...) cl ...) (check-cond* z len (tt ... tn) (nt ... (n)) (e bd ...) cl ...)) ((check-cond* z len () () (() bd ...) cl ...) (if (= len 0) ((lambda () bd ...)) (check-cond* z len () () cl ...))) ((check-cond* z len () () (e bd ...) cl ...) (let ((e z)) bd ...)) ((check-cond* z len (tt ...) ((n) ...) (() bd ...) cl ...) (if (= len (length '(tt ...))) (apply (lambda (tt ...) (let* ((n tt) ...) bd ...)) z) (check-cond* z len () () cl ...))) ((check-cond* 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) (check-cond* z len () () cl ...))) ((check-cond* z len (tt ...) ((n) ...) (e bd ...) cl ...) (if (>= len (length '(tt ...))) (apply (lambda (tt ... . te) (let* ((n tt) ... (e te)) bd ...)) z) (check-cond* z len () () cl ...))) ((check-cond* 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) (check-cond* z len () () cl ...))) ((check-cond* z len (tt ...) (nt ...)) (error "actual arguments are not matched to any clause of alambda*" z)))) (define-syntax cond-and (syntax-rules () ((cond-and ((n v) nvt ...)) (cond-and (nvt ...))) ((cond-and ((n v t) nvt ...)) (and (let ((n v)) t) (cond-and (nvt ...)))) ((cond-and ()) #t))) (define-syntax cond-and* (syntax-rules () ((cond-and* ((n v) nvt ...)) (let ((n v)) (cond-and* (nvt ...)))) ((cond-and* ((n v t) nvt ...)) (let ((n v)) (and t (cond-and* (nvt ...))))) ((cond-and* ()) #t))) (define-syntax check-opt (syntax-rules () ((check-opt z dft (nd ...) ((n d t ...) ndt ...) (nodt ...) e (kk ...) bd ...) (let ((y (if (null? z) z (cdr z))) (x (if (null? z) d (wow-opt n (car z) t ...)))) (check-opt y dft (nd ... (n x)) (ndt ...) (nodt ...) e (kk ...) bd ...))) ((check-opt z dft (nd ...) () (((n k) d t ...) nodt ...) e (kk ...) bd ...) (let ((x (if (null? z) d (wow-key! z dft (kk ...) (n k) d t ...)))) (check-opt z dft (nd ... (n x)) () (nodt ...) e (kk ...) bd ...))) ((check-opt z dft (nd ...) () (((n) d t ...) nodt ...) e (kk ...) bd ...) (let ((x (if (null? z) d (wow-cat! z n d t ...)))) (check-opt z dft (nd ... (n x)) () (nodt ...) e (kk ...) bd ...))) ((check-opt z dft (nd ...) () () () (kk ...) bd ...) (if (null? z) (let (nd ...) bd ...) (error "alambda: too many arguments" z))) ((check-opt z dft (nd ...) () () e (kk ...) bd ...) (let (nd ... (e z)) bd ...)))) (define-syntax check-opt* (syntax-rules () ((check-opt* z dft ((n d t ...) ndt ...) (nodt ...) e (kk ...) bd ...) (let ((y (if (null? z) z (cdr z))) (n (if (null? z) d (wow-opt n (car z) t ...)))) (check-opt* y dft (ndt ...) (nodt ...) e (kk ...) bd ...))) ((check-opt* z dft () (((n k) d t ...) nodt ...) e (kk ...) bd ...) (let ((n (if (null? z) d (wow-key! z dft (kk ...) (n k) d t ...)))) (check-opt* z dft () (nodt ...) e (kk ...) bd ...))) ((check-opt* z dft () (((n) d t ...) nodt ...) e (kk ...) bd ...) (let ((n (if (null? z) d (wow-cat! z n d t ...)))) (check-opt* z dft () (nodt ...) e (kk ...) bd ...))) ((check-opt* z dft () () () (kk ...) bd ...) (if (null? z) (let () bd ...) (error "alambda*: too many arguments" z))) ((check-opt* z dft () () e (kk ...) bd ...) (let ((e z)) bd ...)))) (define-syntax wow-opt (syntax-rules () ((wow-opt n v) v) ((wow-opt n v t) (let ((n v)) (if t n (error "alambda[*]: bad argument" n 'n 't)))) ((wow-opt n v t ts) (let ((n v)) (if t ts (error "alambda[*]: bad argument" n 'n 't)))) ((wow-opt n v t ts fs) (let ((n v)) (if t ts fs))))) (define-syntax wow-cat! (syntax-rules () ((wow-cat! z n d) (let ((n (car z))) (set! z (cdr z)) n)) ((wow-cat! z n d t) (let ((n (car z))) (if t (begin (set! z (cdr z)) n) (let lp ((head (list n)) (tail (cdr z))) (if (null? tail) d (let ((n (car tail))) (if t (begin (set! z (append (reverse head) (cdr tail))) n) (lp (cons n head) (cdr tail))))))))) ((wow-cat! z n d t ts) (let ((n (car z))) (if t (begin (set! z (cdr z)) ts) (let lp ((head (list n)) (tail (cdr z))) (if (null? tail) d (let ((n (car tail))) (if t (begin (set! z (append (reverse head) (cdr tail))) ts) (lp (cons n head) (cdr tail))))))))) ((wow-cat! z n d t ts fs) (let ((n (car z))) (if t (begin (set! z (cdr z)) ts) (begin (set! z (cdr z)) fs)))))) (define-syntax wow-key! (syntax-rules () ((wow-key! z () (kk ...) (n key) d) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? 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 (equal? key x) (begin (set! z (append (reverse head) (cdr y))) (car y)) (lp (cons (car y) (cons x head)) (cdr y))))))))))) ((wow-key! z (#f) (kk ...) (n key) d) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (begin (set! z (cdr y)) (car y)) (let ((lk (list kk ...))) (if (not (member x lk)) d (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 (equal? key x) (begin (set! z (append (reverse head) (cdr y))) (car y)) (if (not (member x lk)) d (lp (cons (car y) (cons x head)) (cdr y)))))))))))))) ((wow-key! z (#t) (kk ...) (n key) d) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (begin (set! z (cdr y)) (car y)) (let* ((lk (list kk ...)) (m (member x lk))) (let lp ((head (if m (list (car y) x) (list x))) (tail (if m (cdr y) y))) (if (null? tail) d (let ((x (car tail)) (y (cdr tail))) (if (null? y) d (if (equal? key x) (begin (set! z (append (reverse head) (cdr y))) (car y)) (let ((m (member x lk))) (lp (if m (cons (car y) (cons x head)) (cons x head)) (if m (cdr y) y))))))))))))) ((wow-key! z () (kk ...) (n key) d t) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) n) (error "alambda[*]: 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 (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) n) (error "alambda[*]: bad argument" n 'n 't))) (lp (cons (car y) (cons x head)) (cdr y))))))))))) ((wow-key! z (#f) (kk ...) (n key) d t) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) n) (error "alambda[*]: bad argument" n 'n 't))) (let ((lk (list kk ...))) (if (not (member x lk)) d (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 (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) n) (error "alambda[*]: bad argument" n 'n 't))) (if (not (member x lk)) d (lp (cons (car y) (cons x head)) (cdr y)))))))))))))) ((wow-key! z (#t) (kk ...) (n key) d t) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) n) (error "alambda[*]: bad argument" n 'n 't))) (let* ((lk (list kk ...)) (m (member x lk))) (let lp ((head (if m (list (car y) x) (list x))) (tail (if m (cdr y) y))) (if (null? tail) d (let ((x (car tail)) (y (cdr tail))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) n) (error "alambda[*]: bad argument" n 'n 't))) (let ((m (member x lk))) (lp (if m (cons (car y) (cons x head)) (cons x head)) (if m (cdr y) y))))))))))))) ((wow-key! z () (kk ...) (n key) d t ts) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (error "alambda[*]: 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 (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (error "alambda[*]: bad argument" n 'n 't))) (lp (cons (car y) (cons x head)) (cdr y))))))))))) ((wow-key! z (#f) (kk ...) (n key) d t ts) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (error "alambda[*]: bad argument" n 'n 't))) (let ((lk (list kk ...))) (if (not (member x lk)) d (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 (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (error "alambda[*]: bad argument" n 'n 't))) (if (not (member x lk)) d (lp (cons (car y) (cons x head)) (cdr y)))))))))))))) ((wow-key! z (#t) (kk ...) (n key) d t ts) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (error "alambda[*]: bad argument" n 'n 't))) (let* ((lk (list kk ...)) (m (member x lk))) (let lp ((head (if m (list (car y) x) (list x))) (tail (if m (cdr y) y))) (if (null? tail) d (let ((x (car tail)) (y (cdr tail))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (error "alambda[*]: bad argument" n 'n 't))) (let ((m (member x lk))) (lp (if m (cons (car y) (cons x head)) (cons x head)) (if m (cdr y) y))))))))))))) ((wow-key! z () (kk ...) (n key) d t ts fs) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (begin (set! z (cdr y)) fs))) (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 (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (begin (set! z (append (reverse head) (cdr y))) fs))) (lp (cons (car y) (cons x head)) (cdr y))))))))))) ((wow-key! z (#f) (kk ...) (n key) d t ts fs) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (begin (set! z (cdr y)) fs))) (let ((lk (list kk ...))) (if (not (member x lk)) d (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 (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (begin (set! z (append (reverse head) (cdr y))) fs))) (if (not (member x lk)) d (lp (cons (car y) (cons x head)) (cdr y)))))))))))))) ((wow-key! z (#t) (kk ...) (n key) d t ts fs) (let ((x (car z)) (y (cdr z))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (begin (set! z (cdr y)) fs))) (let* ((lk (list kk ...)) (m (member x lk))) (let lp ((head (if m (list (car y) x) (list x))) (tail (if m (cdr y) y))) (if (null? tail) d (let ((x (car tail)) (y (cdr tail))) (if (null? y) d (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (begin (set! z (append (reverse head) (cdr y))) fs))) (let ((m (member x lk))) (lp (if m (cons (car y) (cons x head)) (cons x head)) (if m (cdr y) y))))))))))))))) (define-syntax wow-req! (syntax-rules () ((wow-req! z (ft ...) (kk ...) (n)) (let ((n (car z))) (set! z (cdr z)) n)) ((wow-req! z () (kk ...) (n key)) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (begin (set! z (cdr y)) (car y)) (let lp ((head (list (car y) x)) (tail (cdr y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (begin (set! z (append (reverse head) (cdr y))) (car y)) (lp (cons (car y) (cons x head)) (cdr y)))))))))) ((wow-req! z (#f) (kk ...) (n key)) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (begin (set! z (cdr y)) (car y)) (let ((lk (list kk ...))) (if (not (member x lk)) (error "alambda[*]: no keyword" x lk) (let lp ((head (list (car y) x)) (tail (cdr y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (begin (set! z (append (reverse head) (cdr y))) (car y)) (if (not (member x lk)) (error "alambda[*]: no keyword" x lk) (lp (cons (car y) (cons x head)) (cdr y))))))))))))) ((wow-req! z (#t) (kk ...) (n key)) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (begin (set! z (cdr y)) (car y)) (let* ((lk (list kk ...)) (m (member x lk))) (let lp ((head (if m (list (car y) x) (list x))) (tail (if m (cdr y) y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (begin (set! z (append (reverse head) (cdr y))) (car y)) (let ((m (member x lk))) (lp (if m (cons (car y) (cons x head)) (cons x head)) (if m (cdr y) y)))))))))))) ((wow-req! z (ft ...) (kk ...) (n) t) (let ((n (car z))) (if t (begin (set! z (cdr z)) n) (let lp ((head (list n)) (tail (cdr z))) (if (null? tail) (error "alambda[*]: bad arguments" (reverse head) 'n 't) (let ((n (car tail))) (if t (begin (set! z (append (reverse head) (cdr tail))) n) (lp (cons n head) (cdr tail))))))))) ((wow-req! z () (kk ...) (n key) t) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) n) (error "alambda[*]: bad argument" n 'n 't))) (let lp ((head (list (car y) x)) (tail (cdr y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) n) (error "alambda[*]: bad argument" n 'n 't))) (lp (cons (car y) (cons x head)) (cdr y)))))))))) ((wow-req! z (#f) (kk ...) (n key) t) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) n) (error "alambda[*]: bad argument" n 'n 't))) (let ((lk (list kk ...))) (if (not (member x lk)) (error "alambda[*]: no keyword" x lk) (let lp ((head (list (car y) x)) (tail (cdr y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) n) (error "alambda[*]: bad argument" n 'n 't))) (if (not (member x lk)) (error "alambda[*]: no keyword" x lk) (lp (cons (car y) (cons x head)) (cdr y))))))))))))) ((wow-req! z (#t) (kk ...) (n key) t) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) n) (error "alambda[*]: bad argument" n 'n 't))) (let* ((lk (list kk ...)) (m (member x lk))) (let lp ((head (if m (list (car y) x) (list x))) (tail (if m (cdr y) y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) n) (error "alambda[*]: bad argument" n 'n 't))) (let ((m (member x lk))) (lp (if m (cons (car y) (cons x head)) (cons x head)) (if m (cdr y) y)))))))))))) ((wow-req! z (ft ...) (kk ...) (n) t ts) (let ((n (car z))) (if t (begin (set! z (cdr z)) ts) (let lp ((head (list n)) (tail (cdr z))) (if (null? tail) (error "alambda[*]: bad arguments" (reverse head) 'n 't) (let ((n (car tail))) (if t (begin (set! z (append (reverse head) (cdr tail))) ts) (lp (cons n head) (cdr tail))))))))) ((wow-req! z () (kk ...) (n key) t ts) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (error "alambda[*]: bad argument" n 'n 't))) (let lp ((head (list (car y) x)) (tail (cdr y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (error "alambda[*]: bad argument" n 'n 't))) (lp (cons (car y) (cons x head)) (cdr y)))))))))) ((wow-req! z (#f) (kk ...) (n key) t ts) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (error "alambda[*]: bad argument" n 'n 't))) (let ((lk (list kk ...))) (if (not (member x lk)) (error "alambda[*]: no keyword" x lk) (let lp ((head (list (car y) x)) (tail (cdr y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (error "alambda[*]: bad argument" n 'n 't))) (if (not (member x lk)) (error "alambda[*]: no keyword" x lk) (lp (cons (car y) (cons x head)) (cdr y))))))))))))) ((wow-req! z (#t) (kk ...) (n key) t ts) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (error "alambda[*]: bad argument" n 'n 't))) (let* ((lk (list kk ...)) (m (member x lk))) (let lp ((head (if m (list (car y) x) (list x))) (tail (if m (cdr y) y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (error "alambda[*]: bad argument" n 'n 't))) (let ((m (member x lk))) (lp (if m (cons (car y) (cons x head)) (cons x head)) (if m (cdr y) y)))))))))))) ((wow-req! z (ft ...) (kk ...) (n) t ts fs) (let ((n (car z))) (if t (begin (set! z (cdr z)) ts) (begin (set! z (cdr z)) fs)))) ((wow-req! z () (kk ...) (n key) t ts fs) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (begin (set! z (cdr y)) fs))) (let lp ((head (list (car y) x)) (tail (cdr y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (begin (set! z (append (reverse head) (cdr y))) fs))) (lp (cons (car y) (cons x head)) (cdr y)))))))))) ((wow-req! z (#f) (kk ...) (n key) t ts fs) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (begin (set! z (cdr y)) fs))) (let ((lk (list kk ...))) (if (not (member x lk)) (error "alambda[*]: no keyword" x lk) (let lp ((head (list (car y) x)) (tail (cdr y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (begin (set! z (append (reverse head) (cdr y))) fs))) (if (not (member x lk)) (error "alambda[*]: no keyword" x lk) (lp (cons (car y) (cons x head)) (cdr y))))))))))))) ((wow-req! z (#t) (kk ...) (n key) t ts fs) (let ((x (car z)) (y (cdr z))) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (cdr y)) ts) (begin (set! z (cdr y)) fs))) (let* ((lk (list kk ...)) (m (member x lk))) (let lp ((head (if m (list (car y) x) (list x))) (tail (if m (cdr y) y))) (if (null? tail) (error "alambda[*]: no corresponding value to key" key (reverse head)) (let ((x (car tail)) (y (cdr tail))) (if (null? y) (error "alambda[*]: no corresponding value to key" key (append (reverse head) tail)) (if (equal? key x) (let ((n (car y))) (if t (begin (set! z (append (reverse head) (cdr y))) ts) (begin (set! z (append (reverse head) (cdr y))) fs))) (let ((m (member x lk))) (lp (if m (cons (car y) (cons x head)) (cons x head)) (if m (cdr y) y)))))))))))))) 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 86] Joo ChurlSoo: MU and NU simulating VALUES & CALL-WITH-VALUES, and their related LET-syntax. http://srfi.schemers.org/srfi-86/ [SRFI 89] Marc Feeley: Optional and named parameters. http://srfi.schemers.org/srfi-89/ 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.