1139 lines
44 KiB
Racket
1139 lines
44 KiB
Racket
#lang mzscheme
|
|
|
|
(provide mu nu alet alet*)
|
|
|
|
;;; mu & nu
|
|
(define-syntax mu
|
|
(syntax-rules ()
|
|
((mu argument ...)
|
|
(lambda (f) (f argument ...)))))
|
|
|
|
(define-syntax nu
|
|
(syntax-rules ()
|
|
((nu argument ...)
|
|
(lambda (f) (apply f argument ...)))))
|
|
|
|
;;; alet
|
|
(define-syntax alet
|
|
(syntax-rules ()
|
|
((alet (bn ...) bd ...)
|
|
(%alet () () (bn ...) bd ...))
|
|
((alet var (bn ...) bd ...)
|
|
(%alet (var) () (bn ...) bd ...))))
|
|
|
|
(define-syntax %alet
|
|
(syntax-rules (opt cat key rec and values)
|
|
((%alet () ((n v) ...) () bd ...)
|
|
((lambda (n ...) bd ...) v ...))
|
|
((%alet (var) ((n v) ...) () bd ...)
|
|
((letrec ((var (lambda (n ...) bd ...)))
|
|
var) v ...))
|
|
((%alet (var (p ...) (nv ...) (bn ...)) ((n v) ...) () bd ...)
|
|
((letrec ((t (lambda (v ...)
|
|
(%alet (p ...) (nv ... (n v) ... (var t))
|
|
(bn ...) bd ...))))
|
|
t) v ...))
|
|
((%alet (p ...) (nv ...) ((() a b ...) bn ...) bd ...)
|
|
((lambda () a b ... (%alet (p ...) (nv ...) (bn ...) bd ...))))
|
|
((%alet (p ...) (nv ...) (((a) c) bn ...) bd ...)
|
|
((lambda (t) (%alet (p ...) (nv ... (a t)) (bn ...) bd ...)) c))
|
|
|
|
((%alet (p ...) (nv ...) (((values a) c) bn ...) bd ...)
|
|
((lambda (t) (%alet (p ...) (nv ... (a t)) (bn ...) bd ...)) c))
|
|
((%alet (p ...) (nv ...) (((values . b) c d ...) bn ...) bd ...)
|
|
(%alet "dot" (p ...) (nv ...) (values) (b c d ...) (bn ...) bd ...))
|
|
((%alet "dot" (p ...) (nv ...) (values t ...) ((a . b) c ...)
|
|
(bn ...) bd ...)
|
|
(%alet "dot" (p ...) (nv ... (a tn)) (values t ... tn) (b c ...)
|
|
(bn ...) bd ...))
|
|
((%alet "dot" (p ...) (nv ...) (values t ...) (() c) (bn ...) bd ...)
|
|
(call-with-values (lambda () c)
|
|
(lambda (t ...)
|
|
(%alet (p ...) (nv ...) (bn ...) bd ...))))
|
|
((%alet "dot" (p ...) (nv ...) (values t ...) (() c ...) (bn ...) bd ...)
|
|
((lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...)) c ...))
|
|
((%alet "dot" (p ...) (nv ...) (values t ...) (b c) (bn ...) bd ...)
|
|
(call-with-values (lambda () c)
|
|
(lambda (t ... . tn)
|
|
(%alet (p ...) (nv ... (b tn)) (bn ...) bd ...))))
|
|
((%alet "dot" (p ...) (nv ...) (values t ...) (b c ...) (bn ...) bd ...)
|
|
((lambda (t ... . tn)
|
|
(%alet (p ...) (nv ... (b tn)) (bn ...) bd ...)) c ...))
|
|
|
|
((%alet (p ...) (nv ...) (((a . b) c d ...) bn ...) bd ...)
|
|
(%alet "dot" (p ...) (nv ... (a t)) (t) (b c d ...) (bn ...) bd ...))
|
|
((%alet "dot" (p ...) (nv ...) (t ...) ((a . b) c ...) (bn ...) bd ...)
|
|
(%alet "dot" (p ...) (nv ... (a tn)) (t ... tn) (b c ...) (bn ...)
|
|
bd ...))
|
|
((%alet "dot" (p ...) (nv ...) (t ...) (() c) (bn ...) bd ...)
|
|
(c (lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...))))
|
|
((%alet "dot" (p ...) (nv ...) (t ...) (() c ...) (bn ...) bd ...)
|
|
((lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...)) c ...))
|
|
((%alet "dot" (p ...) (nv ...) (t ...) (b c) (bn ...) bd ...)
|
|
(c (lambda (t ... . tn) (%alet (p ...) (nv ... (b tn)) (bn ...) bd ...))))
|
|
((%alet "dot" (p ...) (nv ...) (t ...) (b c ...) (bn ...) bd ...)
|
|
((lambda (t ... . tn)
|
|
(%alet (p ...) (nv ... (b tn)) (bn ...) bd ...)) c ...))
|
|
|
|
((%alet (p ...) (nv ...) ((and (n1 v1 t1 ...) (n2 v2 t2 ...) ...) bn ...)
|
|
bd ...)
|
|
(%alet "and" (p ...) (nv ...) ((n1 v1 t1 ...) (n2 v2 t2 ...) ...) (bn ...)
|
|
bd ...))
|
|
((%alet "and" (p ...) (nv ...) ((n v) nvt ...) (bn ...) bd ...)
|
|
(let ((t v))
|
|
(and t (%alet "and" (p ...) (nv ... (n t)) (nvt ...) (bn ...) bd ...))))
|
|
((%alet "and" (p ...) (nv ...) ((n v t) nvt ...) (bn ...) bd ...)
|
|
(let ((tt v))
|
|
(and (let ((n tt)) t)
|
|
(%alet "and" (p ...) (nv ... (n tt)) (nvt ...) (bn ...) bd ...))))
|
|
((%alet "and" (p ...) (nv ...) () (bn ...) bd ...)
|
|
(%alet (p ...) (nv ...) (bn ...) bd ...))
|
|
((%alet (p ...) (nv ...) ((opt z a . e) bn ...) bd ...)
|
|
(%alet "opt" (p ...) (nv ...) z (a . e) (bn ...) bd ...))
|
|
((%alet "opt" (p ...) (nv ...) z ((n d t ...)) (bn ...) bd ...)
|
|
(let ((x (if (null? z)
|
|
d
|
|
(if (null? (cdr z))
|
|
(wow-opt n (car z) t ...)
|
|
(error "alet: too many arguments" (cdr z))))))
|
|
(%alet (p ...) (nv ... (n x)) (bn ...) bd ...)))
|
|
((%alet "opt" (p ...) (nv ...) z ((n d t ...) . e) (bn ...) bd ...)
|
|
(let ((y (if (null? z) z (cdr z)))
|
|
(x (if (null? z)
|
|
d
|
|
(wow-opt n (car z) t ...))))
|
|
(%alet "opt" (p ...) (nv ... (n x)) y e (bn ...) bd ...)))
|
|
((%alet "opt" (p ...) (nv ...) z e (bn ...) bd ...)
|
|
(let ((te z))
|
|
(%alet (p ...) (nv ... (e te)) (bn ...) bd ...)))
|
|
((%alet (p ...) (nv ...) ((cat z a . e) bn ...) bd ...)
|
|
(let ((y z))
|
|
(%alet "cat" (p ...) (nv ...) y (a . e) (bn ...) bd ...)))
|
|
((%alet "cat" (p ...) (nv ...) z ((n d t ...)) (bn ...) bd ...)
|
|
(let ((x (if (null? z)
|
|
d
|
|
(if (null? (cdr z))
|
|
(wow-cat-end z n t ...)
|
|
(error "alet: too many arguments" (cdr z))))))
|
|
(%alet (p ...) (nv ... (n x)) (bn ...) bd ...)))
|
|
((%alet "cat" (p ...) (nv ...) z ((n d t ...) . e) (bn ...) bd ...)
|
|
(let ((x (if (null? z)
|
|
d
|
|
(wow-cat! z n d t ...))))
|
|
(%alet "cat" (p ...) (nv ... (n x)) z e (bn ...) bd ...)))
|
|
((%alet "cat" (p ...) (nv ...) z e (bn ...) bd ...)
|
|
(let ((te z))
|
|
(%alet (p ...) (nv ... (e te)) (bn ...) bd ...)))
|
|
((%alet (p ...) (nv ...) ((key z a . e) bn ...) bd ...)
|
|
(let ((y z))
|
|
(%alet "key" (p ...) (nv ...) y () () (a . e) () (bn ...) bd ...)))
|
|
((%alet "key" (p ...) (nv ...) z ()
|
|
(ndt ...) (((n k) d t ...) . e) (kk ...) (bn ...) bd ...)
|
|
(%alet "key" (p ...) (nv ...) z ()
|
|
(ndt ... ((n k) d t ...)) e (kk ... k) (bn ...) bd ...))
|
|
((%alet "key" (p ...) (nv ...) z ()
|
|
(ndt ...) ((n d t ...) . e) (kk ...) (bn ...) bd ...)
|
|
(%alet "key" (p ...) (nv ...) z ()
|
|
(ndt ... ((n 'n) d t ...)) e (kk ... 'n) (bn ...) bd ...))
|
|
((%alet "key" (p ...) (nv ...) z ()
|
|
(ndt nd ...) (#t . e) (kk k ...) (bn ...) bd ...)
|
|
(%alet "key" (p ...) (nv ...) z (#t)
|
|
(ndt nd ...) e (kk k ...) (bn ...) bd ...))
|
|
((%alet "key" (p ...) (nv ...) z ()
|
|
(ndt nd ...) (#f . e) (kk k ...) (bn ...) bd ...)
|
|
(%alet "key" (p ...) (nv ...) z (#f)
|
|
(ndt nd ...) e (kk k ...) (bn ...) bd ...))
|
|
((%alet "key" (p ...) (nv ...) z (o ...)
|
|
(((n k) d t ...) ndt ...) e (kk ...) (bn ...) bd ...)
|
|
(let ((x (if (null? z)
|
|
d
|
|
(wow-key! z (o ...) (kk ...) (n k) d t ...))))
|
|
(%alet "key" (p ...) (nv ... (n x)) z (o ...)
|
|
(ndt ...) e (kk ...) (bn ...) bd ...)))
|
|
((%alet "key" (p ...) (nv ...) z (o ...) () () (kk ...) (bn ...) bd ...)
|
|
(if (null? z)
|
|
(%alet (p ...) (nv ...) (bn ...) bd ...)
|
|
(error "alet: too many arguments" z)))
|
|
((%alet "key" (p ...) (nv ...) z (o ...) () e (kk ...) (bn ...) bd ...)
|
|
(let ((te z)) (%alet (p ...) (nv ... (e te)) (bn ...) bd ...)))
|
|
((%alet (p ...) (nv ...) ((rec (n v) (nn vv) ...) bn ...) bd ...)
|
|
(%alet "rec" (p ...) (nv ... (n t)) ((n v t))
|
|
((nn vv) ...) (bn ...) bd ...))
|
|
((%alet "rec" (p ...) (nv ...) (nvt ...) ((n v) (nn vv) ...)
|
|
(bn ...) bd ...)
|
|
(%alet "rec" (p ...) (nv ... (n t)) (nvt ... (n v t)) ((nn vv) ...)
|
|
(bn ...) bd ...))
|
|
((%alet "rec" (p ...) (nv ...) ((n v t) ...) () (bn ...) bd ...)
|
|
((let ((n '<undefined>) ...)
|
|
(let ((t v) ...)
|
|
(set! n t) ...
|
|
(mu n ...)))
|
|
(lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...))))
|
|
|
|
((%alet (p ...) (nv ...) ((a b) bn ...) bd ...)
|
|
((lambda (t) (%alet (p ...) (nv ... (a t)) (bn ...) bd ...)) b))
|
|
|
|
((%alet (p ...) (nv ...) ((values a c) bn ...) bd ...)
|
|
((lambda (t) (%alet (p ...) (nv ... (a t)) (bn ...) bd ...)) c))
|
|
((%alet (p ...) (nv ...) ((values a b c ...) bn ...) bd ...)
|
|
(%alet "not" (p ...) (nv ... (a t)) (values t) (b c ...) (bn ...) bd ...))
|
|
((%alet "not" (p ...) (nv ...) (values t ...) (a b c ...) (bn ...) bd ...)
|
|
(%alet "not" (p ...) (nv ... (a tn)) (values t ... tn) (b c ...)
|
|
(bn ...) bd ...))
|
|
((%alet "not" (p ...) (nv ...) (values t ...) (z) (bn ...) bd ...)
|
|
(call-with-values (lambda () z)
|
|
(lambda (t ...)
|
|
(%alet (p ...) (nv ...) (bn ...) bd ...))))
|
|
|
|
((%alet (p ...) (nv ...) ((a b c ...) bn ...) bd ...)
|
|
(%alet "not" (p ...) (nv ... (a t)) (t) (b c ...) (bn ...) bd ...))
|
|
((%alet "not" (p ...) (nv ...) (t ...) (a b c ...) (bn ...) bd ...)
|
|
(%alet "not" (p ...) (nv ... (a tn)) (t ... tn) (b c ...) (bn ...)
|
|
bd ...))
|
|
((%alet "not" (p ...) (nv ...) (t ...) (z) (bn ...) bd ...)
|
|
(z (lambda (t ...) (%alet (p ...) (nv ...) (bn ...) bd ...))))
|
|
((%alet (p ...) (nv ...) ((a) bn ...) bd ...)
|
|
(call-with-current-continuation
|
|
(lambda (t) (%alet (p ...) (nv ... (a t)) (bn ...) bd ...))))
|
|
((%alet (p ...) (nv ...) ((a . b) bn ...) bd ...)
|
|
(%alet "rot" (p ...) (nv ...) (a) b (bn ...) bd ...))
|
|
((%alet "rot" (p ...) (nv ...) (new-bn ...) (a . b) (bn ...) bd ...)
|
|
(%alet "rot" (p ...) (nv ...) (new-bn ... a) b (bn ...) bd ...))
|
|
((%alet "rot" (p ...) (nv ...) (()) b (bn ...) bd ...)
|
|
(%alet (b (p ...) (nv ...) (bn ...)) () () bd ...))
|
|
((%alet "rot" (p ...) (nv ...) (new-bn ...) b (bn ...) bd ...)
|
|
(%alet (b (p ...) (nv ...) (bn ...)) () (new-bn ...) bd ...))
|
|
((%alet (p ...) (nv ...) (a b bn ...) bd ...)
|
|
(b (lambda t (%alet (p ...) (nv ... (a t)) (bn ...) bd ...))))))
|
|
|
|
;;; alet*
|
|
(define-syntax alet*
|
|
(syntax-rules (opt cat key rec and values)
|
|
((alet* () bd ...)
|
|
((lambda () bd ...)))
|
|
((alet* ((() a b ...) bn ...) bd ...)
|
|
((lambda () a b ... (alet* (bn ...) bd ...))))
|
|
((alet* (((a) c) bn ...) bd ...)
|
|
((lambda (a) (alet* (bn ...) bd ...)) c))
|
|
|
|
((alet* (((values a) c) bn ...) bd ...)
|
|
((lambda (a) (alet* (bn ...) bd ...)) c))
|
|
|
|
((alet* (((values . b) c) bn ...) bd ...)
|
|
(call-with-values (lambda () c)
|
|
(lambda* b (alet* (bn ...) bd ...))))
|
|
((alet* (((values . b) c d ...) bn ...) bd ...)
|
|
(alet* "dot" (b c d ...) (bn ...) bd ...))
|
|
((alet* "dot" ((a . b) c d ...) (bn ...) bd ...)
|
|
((lambda (a) (alet* "dot" (b d ...) (bn ...) bd ...)) c))
|
|
((alet* "dot" (()) (bn ...) bd ...)
|
|
(alet* (bn ...) bd ...))
|
|
((alet* "dot" (b c ...) (bn ...) bd ...)
|
|
((lambda b (alet* (bn ...) bd ...)) c ...))
|
|
|
|
((alet* (((a . b) c) bn ...) bd ...)
|
|
(c (lambda* (a . b) (alet* (bn ...) bd ...))))
|
|
((alet* (((a . b) c d ...) bn ...) bd ...)
|
|
((lambda (a) (alet* "dot" (b d ...) (bn ...) bd ...)) c))
|
|
|
|
((alet* ((and (n1 v1 t1 ...) (n2 v2 t2 ...) ...) bn ...) bd ...)
|
|
(alet-and* ((n1 v1 t1 ...) (n2 v2 t2 ...) ...) (alet* (bn ...) bd ...)))
|
|
((alet* ((opt z a . e) bn ...) bd ...)
|
|
(%alet-opt* z (a . e) (alet* (bn ...) bd ...)))
|
|
((alet* ((cat z a . e) bn ...) bd ...)
|
|
(let ((y z))
|
|
(%alet-cat* y (a . e) (alet* (bn ...) bd ...))))
|
|
((alet* ((key z a . e) bn ...) bd ...)
|
|
(let ((y z))
|
|
(%alet-key* y () () (a . e) () (alet* (bn ...) bd ...))))
|
|
((alet* ((rec (n1 v1) (n2 v2) ...) bn ...) bd ...)
|
|
(alet-rec* ((n1 v1) (n2 v2) ...) (alet* (bn ...) bd ...)))
|
|
|
|
((alet* ((a b) bn ...) bd ...)
|
|
((lambda (a) (alet* (bn ...) bd ...)) b))
|
|
|
|
((alet* ((values a c) bn ...) bd ...)
|
|
((lambda (a) (alet* (bn ...) bd ...)) c))
|
|
((alet* ((values a b c ...) bn ...) bd ...)
|
|
(alet* "not" (values a) (b c ...) (bn ...) bd ...))
|
|
((alet* "not" (values r ...) (a b c ...) (bn ...) bd ...)
|
|
(alet* "not" (values r ... a) (b c ...) (bn ...) bd ...))
|
|
((alet* "not" (values r ...) (z) (bn ...) bd ...)
|
|
(call-with-values (lambda () z)
|
|
(lambda* (r ...) (alet* (bn ...) bd ...))))
|
|
|
|
((alet* ((a b c ...) bn ...) bd ...)
|
|
(alet* "not" (a) (b c ...) (bn ...) bd ...))
|
|
((alet* "not" (r ...) (a b c ...) (bn ...) bd ...)
|
|
(alet* "not" (r ... a) (b c ...) (bn ...) bd ...))
|
|
((alet* "not" (r ...) (z) (bn ...) bd ...)
|
|
(z (lambda* (r ...) (alet* (bn ...) bd ...))))
|
|
((alet* ((a) bn ...) bd ...)
|
|
(call-with-current-continuation (lambda (a) (alet* (bn ...) bd ...))))
|
|
((alet* ((a . b) bn ...) bd ...)
|
|
(%alet* () () ((a . b) bn ...) bd ...))
|
|
((alet* (a b bn ...) bd ...)
|
|
(b (lambda a (alet* (bn ...) bd ...))))
|
|
((alet* var (bn ...) bd ...)
|
|
(%alet* (var) () (bn ...) bd ...))))
|
|
|
|
(define-syntax %alet*
|
|
(syntax-rules (opt cat key rec and values)
|
|
((%alet* (var) (n ...) () bd ...)
|
|
((letrec ((var (lambda* (n ...) bd ...)))
|
|
var) n ...))
|
|
((%alet* (var (bn ...)) (n ...) () bd ...)
|
|
((letrec ((var (lambda* (n ...) (alet* (bn ...) bd ...))))
|
|
var) n ...))
|
|
((%alet* (var (p ...) (nn ...) (bn ...)) (n ...) () bd ...)
|
|
((letrec ((var (lambda* (n ...)
|
|
(%alet* (p ...) (nn ... n ... var) (bn ...)
|
|
bd ...))))
|
|
var) n ...))
|
|
((%alet* (p ...) (n ...) ((() a b ...) bn ...) bd ...)
|
|
((lambda () a b ... (%alet* (p ...) (n ...) (bn ...) bd ...))))
|
|
((%alet* (p ...) (n ...) (((a) c) bn ...) bd ...)
|
|
((lambda (a) (%alet* (p ...) (n ... a) (bn ...) bd ...)) c))
|
|
|
|
((%alet* (p ...) (n ...) (((values a) c) bn ...) bd ...)
|
|
((lambda (a) (%alet* (p ...) (n ... a) (bn ...) bd ...)) c))
|
|
|
|
((%alet* (p ...) (n ...) (((values . b) c) bn ...) bd ...)
|
|
(%alet* "one" (p ...) (n ...) (values) (b c) (bn ...) bd ...))
|
|
((%alet* "one" (p ...) (n ...) (values r ...) ((a . b) c) (bn ...) bd ...)
|
|
(%alet* "one" (p ...) (n ... a) (values r ... a) (b c) (bn ...) bd ...))
|
|
((%alet* "one" (p ...) (n ...) (values r ...) (() c) (bn ...) bd ...)
|
|
(call-with-values (lambda () c)
|
|
(lambda* (r ...)
|
|
(%alet* (p ...) (n ...) (bn ...) bd ...))))
|
|
((%alet* "one" (p ...) (n ...) (values r ...) (b c) (bn ...) bd ...)
|
|
(call-with-values (lambda () c)
|
|
(lambda* (r ... . b)
|
|
(%alet* (p ...) (n ... b) (bn ...) bd ...))))
|
|
|
|
((%alet* (p ...) (n ...) (((values . b) c d ...) bn ...) bd ...)
|
|
(%alet* "dot" (p ...) (n ...) (b c d ...) (bn ...) bd ...))
|
|
|
|
((%alet* (p ...) (n ...) (((a . b) c) bn ...) bd ...)
|
|
(%alet* "one" (p ...) (n ... a) (a) (b c) (bn ...) bd ...))
|
|
((%alet* "one" (p ...) (n ...) (r ...) ((a . b) c) (bn ...) bd ...)
|
|
(%alet* "one" (p ...) (n ... a) (r ... a) (b c) (bn ...) bd ...))
|
|
((%alet* "one" (p ...) (n ...) (r ...) (() c) (bn ...) bd ...)
|
|
(c (lambda* (r ...) (%alet* (p ...) (n ...) (bn ...) bd ...))))
|
|
((%alet* "one" (p ...) (n ...) (r ...) (b c) (bn ...) bd ...)
|
|
(c (lambda* (r ... . b) (%alet* (p ...) (n ... b) (bn ...) bd ...))))
|
|
|
|
((%alet* (p ...) (n ...) (((a . b) c d ...) bn ...) bd ...)
|
|
((lambda (a)
|
|
(%alet* "dot" (p ...) (n ... a) (b d ...) (bn ...) bd ...)) c))
|
|
((%alet* "dot" (p ...) (n ...) ((a . b) c d ...) (bn ...) bd ...)
|
|
((lambda (a)
|
|
(%alet* "dot" (p ...) (n ... a) (b d ...) (bn ...) bd ...)) c))
|
|
((%alet* "dot" (p ...) (n ...) (()) (bn ...) bd ...)
|
|
(%alet* (p ...) (n ...) (bn ...) bd ...))
|
|
((%alet* "dot" (p ...) (n ...) (b c ...) (bn ...) bd ...)
|
|
((lambda b (%alet* (p ...) (n ... b) (bn ...) bd ...)) c ...))
|
|
|
|
((%alet* (p ...) (n ...) ((and (n1 v1 t1 ...) (n2 v2 t2 ...) ...) bn ...)
|
|
bd ...)
|
|
(alet-and* ((n1 v1 t1 ...) (n2 v2 t2 ...) ...)
|
|
(%alet* (p ...) (n ... n1 n2 ...) (bn ...) bd ...)))
|
|
((%alet* (p ...) (n ...) ((opt z a . e) bn ...) bd ...)
|
|
(%alet* "opt" (p ...) (n ...) z (a . e) (bn ...) bd ...))
|
|
((%alet* "opt" (p ...) (nn ...) z ((n d t ...)) (bn ...) bd ...)
|
|
(let ((n (if (null? z)
|
|
d
|
|
(if (null? (cdr z))
|
|
(wow-opt n (car z) t ...)
|
|
(error "alet*: too many arguments" (cdr z))))))
|
|
(%alet* (p ...) (nn ... n) (bn ...) bd ...)))
|
|
((%alet* "opt" (p ...) (nn ...) z ((n d t ...) . e) (bn ...) bd ...)
|
|
(let ((y (if (null? z) z (cdr z)))
|
|
(n (if (null? z)
|
|
d
|
|
(wow-opt n (car z) t ...))))
|
|
(%alet* "opt" (p ...) (nn ... n) y e (bn ...) bd ...)))
|
|
((%alet* "opt" (p ...) (nn ...) z e (bn ...) bd ...)
|
|
(let ((e z))
|
|
(%alet* (p ...) (nn ... e) (bn ...) bd ...)))
|
|
((%alet* (p ...) (nn ...) ((cat z a . e) bn ...) bd ...)
|
|
(let ((y z))
|
|
(%alet* "cat" (p ...) (nn ...) y (a . e) (bn ...) bd ...)))
|
|
((%alet* "cat" (p ...) (nn ...) z ((n d t ...)) (bn ...) bd ...)
|
|
(let ((n (if (null? z)
|
|
d
|
|
(if (null? (cdr z))
|
|
(wow-cat-end z n t ...)
|
|
(error "alet*: too many arguments" (cdr z))))))
|
|
(%alet* (p ...) (nn ... n) (bn ...) bd ...)))
|
|
((%alet* "cat" (p ...) (nn ...) z ((n d t ...) . e) (bn ...) bd ...)
|
|
(let ((n (if (null? z)
|
|
d
|
|
(wow-cat! z n d t ...))))
|
|
(%alet* "cat" (p ...) (nn ... n) z e (bn ...) bd ...)))
|
|
((%alet* "cat" (p ...) (nn ...) z e (bn ...) bd ...)
|
|
(let ((e z))
|
|
(%alet* (p ...) (nn ... e) (bn ...) bd ...)))
|
|
((%alet* (p ...) (m ...) ((key z a . e) bn ...) bd ...)
|
|
(let ((y z))
|
|
(%alet* "key" (p ...) (m ...) y () () (a . e) () (bn ...) bd ...)))
|
|
((%alet* "key" (p ...) (m ...) z ()
|
|
(ndt ...) (((n k) d t ...) . e) (kk ...) (bn ...) bd ...)
|
|
(%alet* "key" (p ...) (m ...) z ()
|
|
(ndt ... ((n k) d t ...)) e (kk ... k) (bn ...) bd ...))
|
|
((%alet* "key" (p ...) (m ...) z ()
|
|
(ndt ...) ((n d t ...) . e) (kk ...) (bn ...) bd ...)
|
|
(%alet* "key" (p ...) (m ...) z ()
|
|
(ndt ... ((n 'n) d t ...)) e (kk ... 'n) (bn ...) bd ...))
|
|
((%alet* "key" (p ...) (m ...) z ()
|
|
(ndt nd ...) (#t . e) (kk k ...) (bn ...) bd ...)
|
|
(%alet* "key" (p ...) (m ...) z (#t)
|
|
(ndt nd ...) e (kk k ...) (bn ...) bd ...))
|
|
((%alet* "key" (p ...) (m ...) z ()
|
|
(ndt nd ...) (#f . e) (kk k ...) (bn ...) bd ...)
|
|
(%alet* "key" (p ...) (m ...) z (#f)
|
|
(ndt nd ...) e (kk k ...) (bn ...) bd ...))
|
|
((%alet* "key" (p ...) (m ...) z (o ...)
|
|
(((n k) d t ...) ndt ...) e (kk ...) (bn ...) bd ...)
|
|
(let ((n (if (null? z)
|
|
d
|
|
(wow-key! z (o ...) (kk ...) (n k) d t ...))))
|
|
(%alet* "key" (p ...) (m ... n) z (o ...)
|
|
(ndt ...) e (kk ...) (bn ...) bd ...)))
|
|
((%alet* "key" (p ...) (m ...) z (o ...) () () (kk ...) (bn ...) bd ...)
|
|
(if (null? z)
|
|
(%alet* (p ...) (m ...) (bn ...) bd ...)
|
|
(error "alet*: too many arguments" z)))
|
|
((%alet* "key" (p ...) (m ...) z (o ...) () e (kk ...) (bn ...) bd ...)
|
|
(let ((e z)) (%alet* (p ...) (m ... e) (bn ...) bd ...)))
|
|
((%alet* (p ...) (n ...) ((rec (n1 v1) (n2 v2) ...) bn ...) bd ...)
|
|
(alet-rec* ((n1 v1) (n2 v2) ...)
|
|
(%alet* (p ...) (n ... n1 n2 ...) (bn ...) bd ...)))
|
|
|
|
((%alet* (p ...) (n ...) ((a b) bn ...) bd ...)
|
|
((lambda (a) (%alet* (p ...) (n ... a) (bn ...) bd ...)) b))
|
|
|
|
((%alet* (p ...) (n ...) ((values a c) bn ...) bd ...)
|
|
((lambda (a) (%alet* (p ...) (n ... a) (bn ...) bd ...)) c))
|
|
((%alet* (p ...) (n ...) ((values a b c ...) bn ...) bd ...)
|
|
(%alet* "not" (p ...) (n ... a) (values a) (b c ...) (bn ...) bd ...))
|
|
((%alet* "not" (p ...) (n ...) (values r ...) (a b c ...) (bn ...) bd ...)
|
|
(%alet* "not" (p ...) (n ... a) (values r ... a) (b c ...) (bn ...)
|
|
bd ...))
|
|
((%alet* "not" (p ...) (n ...) (values r ...) (z) (bn ...) bd ...)
|
|
(call-with-values (lambda () z)
|
|
(lambda* (r ...) (%alet* (p ...) (n ...) (bn ...) bd ...))))
|
|
|
|
((%alet* (p ...) (n ...) ((a b c ...) bn ...) bd ...)
|
|
(%alet* "not" (p ...) (n ... a) (a) (b c ...) (bn ...) bd ...))
|
|
((%alet* "not" (p ...) (n ...) (r ...) (a b c ...) (bn ...) bd ...)
|
|
(%alet* "not" (p ...) (n ... a) (r ... a) (b c ...) (bn ...) bd ...))
|
|
((%alet* "not" (p ...) (n ...) (r ...) (z) (bn ...) bd ...)
|
|
(z (lambda* (r ...) (%alet* (p ...) (n ...) (bn ...) bd ...))))
|
|
((%alet* (p ...) (n ...) ((a) bn ...) bd ...)
|
|
(call-with-current-continuation
|
|
(lambda (a) (%alet* (p ...) (n ... a) (bn ...) bd ...))))
|
|
((%alet* (p ...) (n ...) ((a . b) bn ...) bd ...)
|
|
(%alet* "rot" (p ...) (n ...) (a) b (bn ...) bd ...))
|
|
((%alet* "rot" (p ...) (n ...) (new-bn ...) (a . b) (bn ...) bd ...)
|
|
(%alet* "rot" (p ...) (n ...) (new-bn ... a) b (bn ...) bd ...))
|
|
((%alet* "rot" () () (()) b (bn ...) bd ...)
|
|
(%alet* (b (bn ...)) () () bd ...))
|
|
((%alet* "rot" (p ...) (n ...) (()) b (bn ...) bd ...)
|
|
(%alet* (b (p ...) (n ...) (bn ...)) () () bd ...))
|
|
((%alet* "rot" () () (new-bn ...) b (bn ...) bd ...)
|
|
(%alet* (b (bn ...)) () (new-bn ...) bd ...))
|
|
((%alet* "rot" (p ...) (n ...) (new-bn ...) b (bn ...) bd ...)
|
|
(%alet* (b (p ...) (n ...) (bn ...)) () (new-bn ...) bd ...))
|
|
((%alet* (p ...) (n ...) (a b bn ...) bd ...)
|
|
(b (lambda a (%alet* (p ...) (n ... a) (bn ...) bd ...))))))
|
|
|
|
;;; auxiliaries
|
|
(define-syntax lambda*
|
|
(syntax-rules ()
|
|
((lambda* (a . e) bd ...)
|
|
(lambda* "star" (ta) (a) e bd ...))
|
|
((lambda* "star" (t ...) (n ...) (a . e) bd ...)
|
|
(lambda* "star" (t ... ta) (n ... a) e bd ...))
|
|
((lambda* "star" (t ...) (n ...) () bd ...)
|
|
(lambda (t ...)
|
|
(let* ((n t) ...) bd ...)))
|
|
((lambda* "star" (t ...) (n ...) e bd ...)
|
|
(lambda (t ... . te)
|
|
(let* ((n t) ... (e te)) bd ...)))
|
|
((lambda* e bd ...)
|
|
(lambda e bd ...))))
|
|
|
|
(define-syntax alet-and
|
|
(syntax-rules ()
|
|
((alet-and ((n v t ...) ...) bd ...)
|
|
(alet-and "and" () ((n v t ...) ...) bd ...))
|
|
((alet-and "and" (nt ...) ((n v) nvt ...) bd ...)
|
|
(let ((t v))
|
|
(and t (alet-and "and" (nt ... (n t)) (nvt ...) bd ...))))
|
|
((alet-and "and" (nt ...) ((n v t) nvt ...) bd ...)
|
|
(let ((tt v))
|
|
(and (let ((n tt)) t)
|
|
(alet-and "and" (nt ... (n tt)) (nvt ...) bd ...))))
|
|
((alet-and "and" ((n t) ...) () bd ...)
|
|
((lambda (n ...) bd ...) t ...))))
|
|
|
|
(define-syntax alet-and*
|
|
(syntax-rules ()
|
|
((alet-and* () bd ...)
|
|
((lambda () bd ...)))
|
|
((alet-and* ((n v) nvt ...) bd ...)
|
|
(let ((n v))
|
|
(and n (alet-and* (nvt ...) bd ...))))
|
|
((alet-and* ((n v t) nvt ...) bd ...)
|
|
(let ((n v))
|
|
(and t (alet-and* (nvt ...) bd ...))))))
|
|
|
|
(define-syntax alet-rec
|
|
(syntax-rules ()
|
|
((alet-rec ((n v) ...) bd ...)
|
|
(alet-rec "rec" () ((n v) ...) bd ...))
|
|
((alet-rec "rec" (nvt ...) ((n v) nv ...) bd ...)
|
|
(alet-rec "rec" (nvt ... (n v t)) (nv ...) bd ...))
|
|
((alet-rec "rec" ((n v t) ...) () bd ...)
|
|
(let ((n '<undefined>) ...)
|
|
(let ((t v) ...)
|
|
(set! n t) ...
|
|
;;(let ()
|
|
;; bd ...))))))
|
|
bd ...)))))
|
|
|
|
(define-syntax alet-rec*
|
|
(syntax-rules ()
|
|
((alet-rec* ((n v) ...) bd ...)
|
|
(let* ((n '<undefined>) ...)
|
|
(set! n v) ...
|
|
;;(let ()
|
|
;; bd ...)))))
|
|
bd ...))))
|
|
|
|
(define-syntax wow-opt
|
|
(syntax-rules ()
|
|
((wow-opt n v)
|
|
v)
|
|
((wow-opt n v t)
|
|
(let ((n v))
|
|
(if t n (error "alet[*]: bad argument" n 'n 't))))
|
|
((wow-opt n v t ts)
|
|
(let ((n v))
|
|
(if t ts (error "alet[*]: bad argument" n 'n 't))))
|
|
((wow-opt n v t ts fs)
|
|
(let ((n v))
|
|
(if t ts fs)))))
|
|
|
|
(define-syntax wow-opt!
|
|
(syntax-rules ()
|
|
((wow-opt! z n)
|
|
(let ((n (car z)))
|
|
(set! z (cdr z))
|
|
n))
|
|
((wow-opt! z n t)
|
|
(let ((n (car z)))
|
|
(if t
|
|
(begin (set! z (cdr z)) n)
|
|
(error "alet[*]: bad argument" n 'n 't))))
|
|
((wow-opt! z n t ts)
|
|
(let ((n (car z)))
|
|
(if t
|
|
(begin (set! z (cdr z)) ts)
|
|
(error "alet[*]: bad argument" n 'n 't))))
|
|
((wow-opt! z n t ts fs)
|
|
(let ((n (car z)))
|
|
(if t
|
|
(begin (set! z (cdr z)) ts)
|
|
(begin (set! z (cdr z)) fs))))))
|
|
|
|
(define-syntax wow-cat-end
|
|
(syntax-rules ()
|
|
((wow-cat-end z n)
|
|
(car z))
|
|
((wow-cat-end z n t)
|
|
(let ((n (car z)))
|
|
(if t n (error "alet[*]: too many argument" z))))
|
|
((wow-cat-end z n t ts)
|
|
(let ((n (car z)))
|
|
(if t ts (error "alet[*]: too many argument" z))))
|
|
((wow-cat-end z n t ts fs)
|
|
(let ((n (car z)))
|
|
(if t ts fs)))))
|
|
|
|
(define-syntax wow-cat
|
|
(syntax-rules ()
|
|
((wow-cat z n d)
|
|
z)
|
|
((wow-cat z n d t)
|
|
(let ((n (car z)))
|
|
(if t
|
|
z
|
|
(let lp ((head (list n)) (tail (cdr z)))
|
|
(if (null? tail)
|
|
(cons d z)
|
|
(let ((n (car tail)))
|
|
(if t
|
|
(cons n (append (reverse head) (cdr tail)))
|
|
(lp (cons n head) (cdr tail)))))))))
|
|
((wow-cat z n d t ts)
|
|
(let ((n (car z)))
|
|
(if t
|
|
(cons ts (cdr z))
|
|
(let lp ((head (list n)) (tail (cdr z)))
|
|
(if (null? tail)
|
|
(cons d z)
|
|
(let ((n (car tail)))
|
|
(if t
|
|
(cons ts (append (reverse head) (cdr tail)))
|
|
(lp (cons n head) (cdr tail)))))))))
|
|
((wow-cat z n d t ts fs)
|
|
(let ((n (car z)))
|
|
(if t
|
|
(cons ts (cdr z))
|
|
(cons fs (cdr z)))))))
|
|
|
|
(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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 "alet[*]: 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 alet-opt*
|
|
(syntax-rules ()
|
|
((alet-opt* z (a . e) bd ...)
|
|
(let ((y z))
|
|
(%alet-opt* y (a . e) bd ...)))))
|
|
(define-syntax %alet-opt*
|
|
(syntax-rules ()
|
|
((%alet-opt* z ((n d t ...)) bd ...)
|
|
(let ((n (if (null? z)
|
|
d
|
|
(if (null? (cdr z))
|
|
(wow-opt n (car z) t ...)
|
|
(error "alet*: too many arguments" (cdr z))))))
|
|
bd ...))
|
|
((%alet-opt* z ((n d t ...) . e) bd ...)
|
|
(let ((y (if (null? z) z (cdr z)))
|
|
(n (if (null? z)
|
|
d
|
|
(wow-opt n (car z) t ...))))
|
|
(%alet-opt* y e bd ...)))
|
|
((%alet-opt* z e bd ...)
|
|
(let ((e z)) bd ...))))
|
|
;; (define-syntax %alet-opt*
|
|
;; (syntax-rules ()
|
|
;; ((%alet-opt* z ((n d t ...)) bd ...)
|
|
;; (let ((n (if (null? z)
|
|
;; d
|
|
;; (if (null? (cdr z))
|
|
;; (wow-opt n (car z) t ...)
|
|
;; (error "alet*: too many arguments" (cdr z))))))
|
|
;; bd ...))
|
|
;; ((%alet-opt* z ((n d t ...) . e) bd ...)
|
|
;; (let ((n (if (null? z)
|
|
;; d
|
|
;; (wow-opt! z n t ...))))
|
|
;; (%alet-opt* z e bd ...)))
|
|
;; ((%alet-opt* z e bd ...)
|
|
;; (let ((e z)) bd ...))))
|
|
;; (define-syntax %alet-opt*
|
|
;; (syntax-rules ()
|
|
;; ((%alet-opt* z (ndt ...) (a . e) bd ...)
|
|
;; (%alet-opt* z (ndt ... a) e bd ...))
|
|
;; ((%alet-opt* z ((n d t ...) (nn dd tt ...) ...) () bd ...)
|
|
;; (if (null? z)
|
|
;; (let* ((n d) (nn dd) ...) bd ...)
|
|
;; (let ((y (cdr z))
|
|
;; (n (wow-opt n (car z) t ...)))
|
|
;; (%alet-opt* y ((nn dd tt ...) ...) () bd ...))))
|
|
;; ((%alet-opt* z () () bd ...)
|
|
;; (if (null? z)
|
|
;; (let () bd ...)
|
|
;; (error "alet*: too many arguments" z)))
|
|
;; ((%alet-opt* z ((n d t ...) (nn dd tt ...) ...) e bd ...)
|
|
;; (if (null? z)
|
|
;; (let* ((n d) (nn dd) ... (e z)) bd ...)
|
|
;; (let ((y (cdr z))
|
|
;; (n (wow-opt n (car z) t ...)))
|
|
;; (%alet-opt* y ((nn dd tt ...) ...) e bd ...))))
|
|
;; ((%alet-opt* z () e bd ...)
|
|
;; (let ((e z)) bd ...))))
|
|
|
|
(define-syntax alet-cat*
|
|
(syntax-rules ()
|
|
((alet-cat* z (a . e) bd ...)
|
|
(let ((y z))
|
|
(%alet-cat* y (a . e) bd ...)))))
|
|
;; (define-syntax %alet-cat*
|
|
;; (syntax-rules ()
|
|
;; ((%alet-cat* z ((n d t ...)) bd ...)
|
|
;; (let ((n (if (null? z)
|
|
;; d
|
|
;; (if (null? (cdr z))
|
|
;; (wow-cat-end z n t ...)
|
|
;; (error "alet*: too many arguments" (cdr z))))))
|
|
;; bd ...))
|
|
;; ((%alet-cat* z ((n d t ...) . e) bd ...)
|
|
;; (let* ((w (if (null? z)
|
|
;; (cons d z)
|
|
;; (wow-cat z n d t ...)))
|
|
;; (n (car w))
|
|
;; (y (cdr w)))
|
|
;; (%alet-cat* y e bd ...)))
|
|
;; ((%alet-cat* z e bd ...)
|
|
;; (let ((e z)) bd ...))))
|
|
(define-syntax %alet-cat*
|
|
(syntax-rules ()
|
|
((%alet-cat* z ((n d t ...)) bd ...)
|
|
(let ((n (if (null? z)
|
|
d
|
|
(if (null? (cdr z))
|
|
(wow-cat-end z n t ...)
|
|
(error "alet*: too many arguments" (cdr z))))))
|
|
bd ...))
|
|
((%alet-cat* z ((n d t ...) . e) bd ...)
|
|
(let ((n (if (null? z)
|
|
d
|
|
(wow-cat! z n d t ...))))
|
|
(%alet-cat* z e bd ...)))
|
|
((%alet-cat* z e bd ...)
|
|
(let ((e z)) bd ...))))
|
|
;; (define-syntax %alet-cat*
|
|
;; (syntax-rules ()
|
|
;; ((%alet-cat* z (ndt ...) (a . e) bd ...)
|
|
;; (%alet-cat* z (ndt ... a) e bd ...))
|
|
;; ((%alet-cat* z ((n d t ...) (nn dd tt ...) ...) () bd ...)
|
|
;; (if (null? z)
|
|
;; (let* ((n d) (nn dd) ...) bd ...)
|
|
;; (let* ((w (wow-cat z n d t ...))
|
|
;; (n (car w))
|
|
;; (y (cdr w)))
|
|
;; (%alet-cat* y ((nn dd tt ...) ...) () bd ...))))
|
|
;; ((%alet-cat* z () () bd ...)
|
|
;; (if (null? z)
|
|
;; (let () bd ...)
|
|
;; (error "alet*: too many arguments" z)))
|
|
;; ((%alet-cat* z ((n d t ...) (nn dd tt ...) ...) e bd ...)
|
|
;; (if (null? z)
|
|
;; (let* ((n d) (nn dd) ... (e z)) bd ...)
|
|
;; (let* ((w (wow-cat z n d t ...))
|
|
;; (n (car w))
|
|
;; (y (cdr w)))
|
|
;; (%alet-cat* y ((nn dd tt ...) ...) e bd ...))))
|
|
;; ((%alet-cat* z () e bd ...)
|
|
;; (let ((e z)) bd ...))))
|
|
|
|
(define-syntax alet-key*
|
|
(syntax-rules ()
|
|
((alet-key* z (a . e) bd ...)
|
|
(let ((y z))
|
|
(%alet-key* y () () (a . e) () bd ...)))))
|
|
(define-syntax %alet-key*
|
|
(syntax-rules ()
|
|
((%alet-key* z () (ndt ...) (((n k) d t ...) . e) (kk ...) bd ...)
|
|
(%alet-key* z () (ndt ... ((n k) d t ...)) e (kk ... k) bd ...))
|
|
((%alet-key* z () (ndt ...) ((n d t ...) . e) (kk ...) bd ...)
|
|
(%alet-key* z () (ndt ... ((n 'n) d t ...)) e (kk ... 'n) bd ...))
|
|
((%alet-key* z () (ndt nd ...) (#f . e) (kk k ...) bd ...)
|
|
(%alet-key* z (#f) (ndt nd ...) e (kk k ...) bd ...))
|
|
((%alet-key* z () (ndt nd ...) (#t . e) (kk k ...) bd ...)
|
|
(%alet-key* z (#t) (ndt nd ...) e (kk k ...) bd ...))
|
|
|
|
((%alet-key* z (o ...) (((n k) d t ...) ndt ...) e (kk ...) bd ...)
|
|
(let ((n (if (null? z)
|
|
d
|
|
(wow-key! z (o ...) (kk ...) (n k) d t ...))))
|
|
(%alet-key* z (o ...) (ndt ...) e (kk ...) bd ...)))
|
|
((%alet-key* z (o ...) () () (kk ...) bd ...)
|
|
(if (null? z)
|
|
(let () bd ...)
|
|
(error "alet*: too many arguments" z)))
|
|
((%alet-key* z (o ...) () e (kk ...) bd ...)
|
|
(let ((e z)) bd ...))))
|