From 7e7bac4ec081c0d8a21ce06fda9b3329a853c7a2 Mon Sep 17 00:00:00 2001 From: Chongkai Zhu Date: Sat, 10 Mar 2007 06:08:14 +0000 Subject: [PATCH] new SRFI svn: r5766 --- collects/srfi/86.ss | 4 + collects/srfi/86/86.ss | 1136 ++++++++++++++++++++++++++++++++++++++++ collects/srfi/doc.txt | 1 + 3 files changed, 1141 insertions(+) create mode 100644 collects/srfi/86.ss create mode 100644 collects/srfi/86/86.ss diff --git a/collects/srfi/86.ss b/collects/srfi/86.ss new file mode 100644 index 0000000000..e8a015dbb6 --- /dev/null +++ b/collects/srfi/86.ss @@ -0,0 +1,4 @@ +(module |86| mzscheme + (require (lib "86.ss" "srfi" "86")) + (provide (all-from (lib "86.ss" "srfi" "86"))) + ) \ No newline at end of file diff --git a/collects/srfi/86/86.ss b/collects/srfi/86/86.ss new file mode 100644 index 0000000000..90f0f499ef --- /dev/null +++ b/collects/srfi/86/86.ss @@ -0,0 +1,1136 @@ +(module |86| 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 ') ...) + (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 ') ...) + (let ((t v) ...) + (set! n t) ... + ;;(let () + ;; bd ...)))))) + bd ...))))) + + (define-syntax alet-rec* + (syntax-rules () + ((alet-rec* ((n v) ...) bd ...) + (let* ((n ') ...) + (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 ...)))) + ) \ No newline at end of file diff --git a/collects/srfi/doc.txt b/collects/srfi/doc.txt index 38e968dafc..6e460648c4 100644 --- a/collects/srfi/doc.txt +++ b/collects/srfi/doc.txt @@ -121,6 +121,7 @@ sub-collection number of the already ported SRFIs: SRFI-71 letvalues.ss 71 SRFI-74 74.ss 74 SRFI-78 check.ss 78 + SRFI-86 86.ss 86 SRFI-87 case.ss 87