[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
guile/guile-core/ice-9 psyntax.ss psyntax.pp ma...
|
From: |
Marius Vollmer |
|
Subject: |
guile/guile-core/ice-9 psyntax.ss psyntax.pp ma... |
|
Date: |
Fri, 18 May 2001 18:31:33 -0700 |
CVSROOT: /cvs
Module name: guile
Changes by: Marius Vollmer <address@hidden> 01/05/18 18:31:33
Modified files:
guile-core/ice-9: psyntax.ss psyntax.pp match.scm expect.scm
Log message:
* psyntax.ss (build-lexical-var): Use gensym instead of gentemp.
* match.scm: Likewise.
* expect.scm: Likewise.
* psyntax.pp: Regenerated.
CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/psyntax.ss.diff?cvsroot=OldCVS&tr1=1.11&tr2=1.12&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/psyntax.pp.diff?cvsroot=OldCVS&tr1=1.12&tr2=1.13&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/match.scm.diff?cvsroot=OldCVS&tr1=1.4&tr2=1.5&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/expect.scm.diff?cvsroot=OldCVS&tr1=1.15&tr2=1.16&r1=text&r2=text
Patches:
Index: guile/guile-core/ice-9/expect.scm
diff -u guile/guile-core/ice-9/expect.scm:1.15
guile/guile-core/ice-9/expect.scm:1.16
--- guile/guile-core/ice-9/expect.scm:1.15 Sun May 6 02:26:16 2001
+++ guile/guile-core/ice-9/expect.scm Fri May 18 18:31:33 2001
@@ -45,10 +45,10 @@
;;; expect: each test is a procedure which is applied to the accumulating
;;; string.
(defmacro-public expect clauses
- (let ((s (gentemp))
- (c (gentemp))
- (port (gentemp))
- (timeout (gentemp)))
+ (let ((s (gensym))
+ (c (gensym))
+ (port (gensym))
+ (timeout (gensym)))
`(let ((,s "")
(,port (or expect-port (current-input-port)))
;; when timeout occurs, in floating point seconds.
@@ -123,7 +123,7 @@
(cond ((null? tests)
(list (reverse defs) `(expect ,@(reverse body))))
(else
- (let ((rxname (gentemp)))
+ (let ((rxname (gensym)))
(next-test (cdr tests)
(cdr exprs)
(cons `(,rxname (make-regexp
Index: guile/guile-core/ice-9/match.scm
diff -u guile/guile-core/ice-9/match.scm:1.4
guile/guile-core/ice-9/match.scm:1.5
--- guile/guile-core/ice-9/match.scm:1.4 Fri Mar 9 18:16:12 2001
+++ guile/guile-core/ice-9/match.scm Fri May 18 18:31:33 2001
@@ -177,7 +177,7 @@
(define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l))
(match:andmap f (cdr l))))))
(define match:syntax-err (lambda (obj msg) (slib:error msg obj)))
(define match:disjoint-structure-tags (quote ()))
-(define match:make-structure-tag (lambda (name) (if (or (eq?
match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag
(gentemp))) (set! match:disjoint-structure-tags (cons tag
match:disjoint-structure-tags)) tag) (string->symbol (string-append "<"
(symbol->string name) ">")))))
+(define match:make-structure-tag (lambda (name) (if (or (eq?
match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag
(gensym))) (set! match:disjoint-structure-tags (cons tag
match:disjoint-structure-tags)) tag) (string->symbol (string-append "<"
(symbol->string name) ">")))))
(define match:structure? (lambda (tag) (memq tag
match:disjoint-structure-tags)))
(define match:structure-control (quote vector))
(define match:set-structure-control (lambda (v) (set! match:structure-control
v)))
@@ -186,17 +186,17 @@
(define match:set-error-control (lambda (v) (set! match:error-control v)))
(define match:disjoint-predicates (cons (quote null) (quote (pair? symbol?
boolean? number? string? char? procedure? vector?))))
(define match:vector-structures (quote ()))
-(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr)
(let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (blist (car
eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c))))
(p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (fail (and
(pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr
c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if
fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons
(quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body))))
(append bindings blist))) (list p code bv (and fail (gentemp)) #f))) clauses))
(code (gen x (quote ()) plist (cdr eb-errf) length>= (gentemp)))) (unreachable
plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n)
(lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code)))))))
(genletrec (lambda (pat exp body match-expr) (let* ((length>= (gentemp))
(eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car
x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p
code bv #f #f))) (x (gentemp)) (m (gen x (quote ()) plist (cdr eb-errf)
length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist
match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l)
(>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote
v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs)
(unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote
g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings)
(unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp
match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x
(bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x))
(code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x
(quote ()) plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_)
(gentemp)) bv))) (unreachable plist match-expr) (quasiquote (begin
(unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv))
(unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda
(l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda
(unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v)
(unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings)
(unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda
(x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote
unquote unquote-splicing ? _ $ = and or not set! get! ... ___)))))))
(dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let*
((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref
s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap
char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2
n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control
(quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f
#f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ())
(lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control
(quote match)) (let ((errf (gentemp)) (arg (gentemp))) (cons (quasiquote
(((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote
(unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote
x))))))) (else (match:syntax-err (quote (unspecified error fail match))
"invalid value for match:error-control, legal values are"))))) (unreachable
(lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x)))
(begin (display "Warning: unreachable pattern ") (display (car x)) (display "
in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda
(pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x)
(number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons
(ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p
(quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if
(pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p))
(null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if
(equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p)))
((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if
(and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (?
(unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157
(car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p))
(pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote
sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if
(equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda
(ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157
(car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p))
(pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary
ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if
(and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not
(unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if
(equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list?
(cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map
ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p)
(quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr
p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote
get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p)))
((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote))
(g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car
p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p)))
((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p)
(cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p)
(let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not
(null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary
(cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern
"syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x
y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if
(symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if
(equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p)))
((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair?
(car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null?
(cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda
(p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr
p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote
((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr
p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse
pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map
quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err
pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null?
p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else
(match:syntax-err pattern "invalid use of unquote-splicing in pattern"))))))
(ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote
())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if
(memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p
(cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair?
p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote
(and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not
(symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies
(cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k
(quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote
=) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g
(gentemp))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr
p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a
k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr
p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound*
(cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and
(pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a)
(let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote
first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist)
(bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a
first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or*
(cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p)
(eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote
(not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda
(p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed
in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr
p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars
(find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote
bvars) (unquote (gentemp)) (unquote (gentemp)) (unquote (map (lambda (_)
(gentemp)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound*
(cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p))
(unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if
(memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote
get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair?
p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k
(cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl
a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k)
(let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr
plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound
plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p
a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr
plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda
(plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p
a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a))))))))
(find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix
(cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2))
(match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ())
(lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda
(let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+
(loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e
old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr
e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp)
(boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and
(pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr
sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and
(pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda
match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp)
(eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const?
(caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b
(quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e
(quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car
b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e))
((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car
b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b)
(cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if
(null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x
v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success
(lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car
plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym
(let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map
val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote
fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote
(fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing
(map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks
success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p
e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks))
((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf
ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf
ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf
ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks))
((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks))
((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote
e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst
(quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and
(pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr
p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let
loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda
(sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let
((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v
or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair?
p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq?
(quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length
fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote
e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf)
(next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -)
n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote
set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and
(pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e
p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit
(quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr
p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote
_)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f)
(lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr
ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote
(lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap
(unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal?
(list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref
p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote
(car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr
(unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote
(val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound
(map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote
(let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda
(x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge))
(unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit
(quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote
length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit
(quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf
kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>=
(vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let*
((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1))))
(minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote
(vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length
(unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond
((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e)
(unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks
sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen
4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen)
(quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf)
(quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda
(b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh))))))))
(set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop)
(((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map
(lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote
minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf))))))
((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector?
(unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length
(unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n
vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e)
(unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN
PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit
(lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not
(unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq?
(car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote
((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e)))))
((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote
((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p)))
(quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst)
(quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst)
(quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car
tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s
(ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote
tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s)
(cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst)
(quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car
f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s)
(eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote
and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s))))
(unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote
(cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s)
(quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s))
(equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null?
(cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar
(cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s)))
(pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr
(caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda))
(pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair?
(cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair?
(cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr
s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr
s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar
(cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr
(caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr
s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation
(lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote
f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f
(pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair?
(caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr
s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair?
(cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null?
(cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f))
(let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail)
(lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail)))
s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f)))))))
(guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop
((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond
match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code)
(quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr
code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote
let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr
code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote
list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member
(quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not))
(let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class
(let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x)
(cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x
(quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal?
(cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x))))
(mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x
(car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal?
(car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let
mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr
srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem
(cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x
(car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x)
(vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x)
(car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch))))))
(mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car
tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?))
((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote
number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote)
(car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda
(tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda
(tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new
(and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a))
(quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a)
(assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr
(unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar
caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr)
(caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr
caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar
. cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter
(lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e))
(match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref))
(quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote
(caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote
(cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car))
(quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq?
(car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y)
(set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote
(let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote
(mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr
e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda
(e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern"))
((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e))))
(lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox))
(quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car
e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car
x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e))))
(lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote
(let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr
a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda ()
((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr .
car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car)
(cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr)
(cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car)
(caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr .
car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr
caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr)
(cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr))))
(symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x)
(cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else
x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc
(lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l)))))))
(list genmatch genletrec gendefine pattern-var?)))
-(defmacro match args (cond ((and (list? args) (<= 1 (length args))
(match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let*
((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gentemp))))
(if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match
(unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp)))
(unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing
args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing
args))) "syntax error in"))))
-(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195)
(if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args))
((lambda () (let ((e (gentemp))) (quasiquote (lambda ((unquote e)) (match
(unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err
(quasiquote (match-lambda (unquote-splicing args))) "syntax error in")))))
-(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda
(g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args))
((lambda () (let ((e (gentemp))) (quasiquote (lambda (unquote e) (match
(unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err
(quasiquote (match-lambda* (unquote-splicing args))) "syntax error in")))))
-(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match
(unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat
exp body) (let ((g (map (lambda (x) (gentemp)) pat)) (vpattern (list->vector
pat))) (quasiquote (let (unquote (map list g exp)) (match (vector
(unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215
(lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args)))
"syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gentemp)) (g2
(gentemp))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2)
(unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote
p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair?
args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args)))
(let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null?
g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp
body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let
(unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda*
((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing
exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if
(and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr
g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if
(list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205
(car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and
(list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let
(unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ()))
(g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair?
(cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217)
(cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar
args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if
(and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args)
(cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ())))
(if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null?
(cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219)
g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair?
(cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and
(list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar
args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote
())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219))
(pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219)
g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217
(quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args))
(pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if
(and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr
g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218
((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if
(and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217)
(cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null?
(cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219)
g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair?
(cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list?
(cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args))
(let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null?
g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar
g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216))
(g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar
args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr
args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car
(cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216
(quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar
g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons
(caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ()))
(g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr
args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair?
(car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons
(cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car
args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list?
(cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args))
(g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219)))
(g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))
(g215)))) (g215))))
+(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr)
(let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist (car
eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c))))
(p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fail (and
(pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr
c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if
fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons
(quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body))))
(append bindings blist))) (list p code bv (and fail (gensym)) #f))) clauses))
(code (gen x (quote ()) plist (cdr eb-errf) length>= (gensym)))) (unreachable
plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n)
(lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code)))))))
(genletrec (lambda (pat exp body match-expr) (let* ((length>= (gensym))
(eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car
x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p
code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>=
(gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr)
(quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l)
n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv))
((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs)
(unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote
g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings)
(unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp
match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x
(bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x))
(code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x
(quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_)
(gensym)) bv))) (unreachable plist match-expr) (quasiquote (begin
(unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv))
(unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda
(l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda
(unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v)
(unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings)
(unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda
(x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote
unquote unquote-splicing ? _ $ = and or not set! get! ... ___)))))))
(dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let*
((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref
s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap
char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2
n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control
(quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f
#f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ())
(lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control
(quote match)) (let ((errf (gensym)) (arg (gensym))) (cons (quasiquote
(((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote
(unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote
x))))))) (else (match:syntax-err (quote (unspecified error fail match))
"invalid value for match:error-control, legal values are"))))) (unreachable
(lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x)))
(begin (display "Warning: unreachable pattern ") (display (car x)) (display "
in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda
(pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x)
(number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons
(ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p
(quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if
(pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p))
(null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if
(equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p)))
((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if
(and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (?
(unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157
(car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p))
(pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote
sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if
(equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda
(ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157
(car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p))
(pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary
ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if
(and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not
(unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if
(equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list?
(cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map
ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p)
(quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr
p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote
get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p)))
((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote))
(g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car
p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p)))
((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p)
(cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p)
(let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not
(null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary
(cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern
"syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x
y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if
(symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if
(equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p)))
((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair?
(car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null?
(cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda
(p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr
p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote
((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr
p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse
pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map
quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err
pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null?
p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else
(match:syntax-err pattern "invalid use of unquote-splicing in pattern"))))))
(ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote
())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if
(memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p
(cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair?
p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote
(and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not
(symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies
(cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k
(quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote
=) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g
(gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr
p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a
k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr
p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound*
(cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and
(pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a)
(let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote
first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist)
(bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a
first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or*
(cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p)
(eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote
(not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda
(p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed
in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr
p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars
(find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote
bvars) (unquote (gensym)) (unquote (gensym)) (unquote (map (lambda (_)
(gensym)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound*
(cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p))
(unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if
(memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote
get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair?
p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k
(cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl
a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k)
(let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr
plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound
plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p
a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr
plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda
(plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p
a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a))))))))
(find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix
(cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2))
(match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ())
(lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda
(let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+
(loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e
old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr
e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp)
(boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and
(pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr
sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and
(pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda
match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp)
(eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const?
(caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b
(quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e
(quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car
b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e))
((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car
b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b)
(cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if
(null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x
v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success
(lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car
plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym
(let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map
val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote
fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote
(fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing
(map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks
success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p
e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks))
((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf
ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf
ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf
ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks))
((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks))
((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote
e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst
(quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and
(pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr
p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let
loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda
(sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let
((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v
or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair?
p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq?
(quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length
fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote
e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf)
(next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -)
n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote
set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and
(pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e
p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit
(quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr
p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote
_)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f)
(lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr
ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote
(lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap
(unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal?
(list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref
p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote
(car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr
(unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote
(val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound
(map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote
(let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda
(x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge))
(unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit
(quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote
length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit
(quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf
kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>=
(vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let*
((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1))))
(minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote
(vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length
(unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond
((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e)
(unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks
sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen
4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen)
(quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf)
(quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda
(b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh))))))))
(set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop)
(((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map
(lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote
minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf))))))
((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector?
(unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length
(unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n
vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e)
(unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN
PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit
(lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not
(unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq?
(car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote
((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e)))))
((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote
((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p)))
(quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst)
(quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst)
(quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car
tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s
(ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote
tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s)
(cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst)
(quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car
f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s)
(eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote
and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s))))
(unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote
(cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s)
(quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s))
(equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null?
(cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar
(cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s)))
(pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr
(caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda))
(pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair?
(cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair?
(cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr
s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr
s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar
(cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr
(caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr
s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation
(lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote
f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f
(pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair?
(caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr
s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair?
(cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null?
(cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f))
(let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail)
(lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail)))
s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f)))))))
(guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop
((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond
match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code)
(quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr
code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote
let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr
code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote
list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member
(quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not))
(let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class
(let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x)
(cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x
(quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal?
(cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x))))
(mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x
(car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal?
(car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let
mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr
srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem
(cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x
(car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x)
(vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x)
(car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch))))))
(mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car
tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?))
((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote
number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote)
(car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda
(tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda
(tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new
(and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a))
(quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a)
(assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr
(unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar
caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr)
(caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr
caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar
. cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter
(lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e))
(match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref))
(quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote
(caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote
(cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car))
(quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq?
(car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y)
(set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote
(let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote
(mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr
e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda
(e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern"))
((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e))))
(lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox))
(quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car
e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car
x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e))))
(lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote
(let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr
a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda ()
((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr .
car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car)
(cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr)
(cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car)
(caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr .
car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr
caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr)
(cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr))))
(symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x)
(cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else
x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc
(lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l)))))))
(list genmatch genletrec gendefine pattern-var?)))
+(defmacro match args (cond ((and (list? args) (<= 1 (length args))
(match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let*
((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gensym)))) (if
(symbol? exp) ((car match:expanders) e clauses (quasiquote (match
(unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp)))
(unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing
args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing
args))) "syntax error in"))))
+(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195)
(if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args))
((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (match
(unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err
(quasiquote (match-lambda (unquote-splicing args))) "syntax error in")))))
+(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda
(g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args))
((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match (unquote
e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote
(match-lambda* (unquote-splicing args))) "syntax error in")))))
+(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match
(unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat
exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list->vector
pat))) (quasiquote (let (unquote (map list g exp)) (match (vector
(unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215
(lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args)))
"syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gensym)) (g2
(gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote
e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2)
(unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair?
args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args)))
(let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null?
g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp
body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let
(unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda*
((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing
exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if
(and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr
g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if
(list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205
(car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and
(list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let
(unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ()))
(g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair?
(cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217)
(cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar
args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if
(and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args)
(cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ())))
(if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null?
(cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219)
g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair?
(cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and
(list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar
args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote
())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219))
(pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219)
g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217
(quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args))
(pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if
(and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr
g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218
((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if
(and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217)
(cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null?
(cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219)
g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair?
(cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list?
(cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args))
(let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null?
g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar
g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216))
(g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar
args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr
args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car
(cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216
(quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar
g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons
(caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ()))
(g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr
args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair?
(car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons
(cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car
args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list?
(cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args))
(g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219)))
(g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))
(g215)))) (g215))))
(defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote
(match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args)
(if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda
(body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if
(and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar
args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat
exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote
pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body))))
(quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest)
(unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr
args)) (g245))) (g245))))
(defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268
(lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote
p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264
(lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing
args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote
(match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp))))
(unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr
match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat)
(unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car
args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275))
(pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr
args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing
args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if
(null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null?
(cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259)
g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar
args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr
args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let
g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259)
(g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259)))
(g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))
(if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null?
(cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair?
(cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args))
(cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ())))
(if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null?
(cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259)
g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote
()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263
(reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259))
(pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259)
g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257
(quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args))
(pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if
(and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr
g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair?
(car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar
args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args)))
(g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257
(quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car
g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar
g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args))
(pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null?
(cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar
args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258
((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264)
(if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258
(cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let
g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259)
(if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse
g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259))
(null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar
g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256
(quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args)))
(g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car
g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar
g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264))))
(defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278
(lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing
args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and
(pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define
(unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr
args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote
(match-define (unquote-splicing args))))) (car args) (cadr args)) (g278)))
(g278))))
(define match:runtime-structures #f)
(define match:set-runtime-structures (lambda (v) (set!
match:runtime-structures v)))
(define match:primitive-vector? vector?)
-(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda ()
#t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x))
(null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda
(x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair?
(cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x)))))
(mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x)
(pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x))
(match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda
(l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi
(cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let
((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct)
(unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol?
(car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args))
(symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args))
(g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate
fields) (let* ((selectors (map selector-name fields)) (mutators (map
mutator-name fields)) (tag (if match:runtime-structures (gentemp) (quasiquote
(quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq?
match:structure-control (quote disjoint)) (quote match:primitive-vector?))
((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq?
match:structure-control (quote disjoint)) (if (eq? vector?
match:primitive-vector?) (set! vector? (lambda (v) (and
(match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol?
(vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not
(memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates
(cons predicate match:disjoint-predicates)))) ((eq? match:structure-control
(quote vector)) (if (not (memq predicate match:vector-structures)) (set!
match:vector-structures (cons predicate match:vector-structures)))) (else
(match:syntax-err (quote (vector disjoint)) "invalid value for
match:structure-control, legal values are"))) (quasiquote (begin
(unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote
tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define
(unquote constructor) (lambda (unquote selectors) (vector (unquote tag)
(unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and
((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length
selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing
(filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda
(obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing
(filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n)
(lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators))))))
(car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299))
(g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
+(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda ()
#t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x))
(null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda
(x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair?
(cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x)))))
(mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x)
(pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x))
(match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda
(l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi
(cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let
((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct)
(unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol?
(car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args))
(symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args))
(g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate
fields) (let* ((selectors (map selector-name fields)) (mutators (map
mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote
(quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq?
match:structure-control (quote disjoint)) (quote match:primitive-vector?))
((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq?
match:structure-control (quote disjoint)) (if (eq? vector?
match:primitive-vector?) (set! vector? (lambda (v) (and
(match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol?
(vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not
(memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates
(cons predicate match:disjoint-predicates)))) ((eq? match:structure-control
(quote vector)) (if (not (memq predicate match:vector-structures)) (set!
match:vector-structures (cons predicate match:vector-structures)))) (else
(match:syntax-err (quote (vector disjoint)) "invalid value for
match:structure-control, legal values are"))) (quasiquote (begin
(unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote
tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define
(unquote constructor) (lambda (unquote selectors) (vector (unquote tag)
(unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and
((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length
selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing
(filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda
(obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing
(filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n)
(lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators))))))
(car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299))
(g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err
(quasiquote (define-structure (unquote-splicing args))) "syntax error in"))))
(if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr
args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ()))
(g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1
id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote
@)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x)
(cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote
(define-const-structure ((unquote name) (unquote-splicing (map mk-id id1)))
(unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v))))
id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311))
(if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308
(cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311)))
(g311))))
-(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol?
id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair?
(cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda ()
#f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator?
(lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec
((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x)
(cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l
1)))) (symbol-append (lambda l (string->symbol (apply string-append (map
(lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string
x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote
(define-const-structure (unquote-splicing args))) "syntax error in")))) (if
(and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar
args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if
(and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args))
(g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args))
((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor
(symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote
make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin
((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote
predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if
(has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i))
(unquote (symbol-append (quote set-) name (quote -) i (quote !)))))
(symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2)
(quasiquote (define (unquote constructor) (unquote raw-constructor))) (let*
((make-fresh (lambda (x) (if (eq? (quote _) x) (gentemp) x))) (names1 (map
make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name
id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1)
(let* (unquote (map list names2 val)) ((unquote raw-constructor)
(unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing
(filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _))
#f (quasiquote (define (unquote (symbol-append name (quote -) (field-name
field))) (unquote (symbol-append name (quote -) i)))))) id1id2))
(unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq?
(field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote
(define (unquote (symbol-append (quote set-) name (quote -) (field-name field)
(quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote
!))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331))
(g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333))
(null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar
g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons
(car g329) g327)) (g335)))) (g335))) (g335)))))
+(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol?
id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair?
(cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda ()
#f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator?
(lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec
((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x)
(cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l
1)))) (symbol-append (lambda l (string->symbol (apply string-append (map
(lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string
x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote
(define-const-structure (unquote-splicing args))) "syntax error in")))) (if
(and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar
args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if
(and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args))
(g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args))
((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor
(symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote
make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin
((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote
predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if
(has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i))
(unquote (symbol-append (quote set-) name (quote -) i (quote !)))))
(symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2)
(quasiquote (define (unquote constructor) (unquote raw-constructor))) (let*
((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map
make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name
id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1)
(let* (unquote (map list names2 val)) ((unquote raw-constructor)
(unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing
(filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _))
#f (quasiquote (define (unquote (symbol-append name (quote -) (field-name
field))) (unquote (symbol-append name (quote -) i)))))) id1id2))
(unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq?
(field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote
(define (unquote (symbol-append (quote set-) name (quote -) (field-name field)
(quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote
!))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331))
(g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333))
(null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar
g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons
(car g329) g327)) (g335)))) (g335))) (g335)))))
Index: guile/guile-core/ice-9/psyntax.pp
diff -u guile/guile-core/ice-9/psyntax.pp:1.12
guile/guile-core/ice-9/psyntax.pp:1.13
--- guile/guile-core/ice-9/psyntax.pp:1.12 Mon Sep 11 23:04:06 2000
+++ guile/guile-core/ice-9/psyntax.pp Fri May 18 18:31:32 2001
@@ -1,4 +1,4 @@
-(letrec ((lambda-var-list116 (lambda (vars323) (let lvl324 ((vars325 vars323)
(ls326 (quote ())) (w327 (quote (())))) (cond ((pair? vars325) (lvl324 (cdr
vars325) (cons (wrap95 (car vars325) w327) ls326) w327)) ((id?67 vars325) (cons
(wrap95 vars325 w327) ls326)) ((null? vars325) ls326) ((syntax-object?53
vars325) (lvl324 (syntax-object-expression54 vars325) ls326 (join-wraps86 w327
(syntax-object-wrap55 vars325)))) ((annotation?42 vars325) (lvl324
(annotation-expression vars325) ls326 w327)) (else (cons vars325 ls326))))))
(gen-var115 (lambda (id328) (let ((id329 (if (syntax-object?53 id328)
(syntax-object-expression54 id328) id328))) (if (annotation?42 id329) (gentemp
(symbol->string (annotation-expression id329)) generated-symbols) (gentemp
(symbol->string id329) generated-symbols))))) (strip114 (lambda (x330 w331) (if
(memq (quote top) (wrap-marks70 w331)) (if (or (annotation?42 x330) (and (pair?
x330) (annotation?42 (car x330)))) (strip-annotation113 x330 (quote #f)) x330)
(let f332 ((x333 x330)) (cond ((syntax-object?53 x333) (strip114
(syntax-object-expression54 x333) (syntax-object-wrap55 x333))) ((pair? x333)
(let ((a334 (f332 (car x333))) (d335 (f332 (cdr x333)))) (if (and (eq? a334
(car x333)) (eq? d335 (cdr x333))) x333 (cons a334 d335)))) ((vector? x333)
(let ((old336 (vector->list x333))) (let ((new337 (map f332 old336))) (if
(andmap eq? old336 new337) x333 (list->vector new337))))) (else x333))))))
(strip-annotation113 (lambda (x338 parent339) (cond ((pair? x338) (let ((new340
(cons (quote #f) (quote #f)))) (begin (when parent339 (set-annotation-stripped!
parent339 new340)) (set-car! new340 (strip-annotation113 (car x338) (quote
#f))) (set-cdr! new340 (strip-annotation113 (cdr x338) (quote #f))) new340)))
((annotation?42 x338) (or (annotation-stripped x338) (strip-annotation113
(annotation-expression x338) x338))) ((vector? x338) (let ((new341 (make-vector
(vector-length x338)))) (begin (when parent339 (set-annotation-stripped!
parent339 new341)) (let loop342 ((i343 (- (vector-length x338) (quote 1))))
(unless (fx<41 i343 (quote 0)) (vector-set! new341 i343 (strip-annotation113
(vector-ref x338 i343) (quote #f))) (loop342 (fx-39 i343 (quote 1)))))
new341))) (else x338)))) (ellipsis?112 (lambda (x344) (and (nonsymbol-id?66
x344) (free-id=?90 x344 (quote #(syntax-object ... ((top) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip
strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source unannotate
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap
syntax-object-expression syntax-object? make-syntax-object self-evaluating?
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand)
((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void111 (lambda
() (list (quote void)))) (eval-local-transformer110 (lambda (expanded345) (let
((p346 (local-eval-hook44 expanded345))) (if (procedure? p346) p346
(syntax-error p346 (quote "nonprocedure transfomer")))))) (chi-local-syntax109
(lambda (rec?347 e348 r349 w350 s351 k352) ((lambda (tmp353) ((lambda (tmp354)
(if tmp354 (apply (lambda (_355 id356 val357 e1358 e2359) (let ((ids360 id356))
(if (not (valid-bound-ids?92 ids360)) (syntax-error e348 (quote "duplicate
bound keyword in")) (let ((labels362 (gen-labels73 ids360))) (let ((new-w363
(make-binding-wrap84 ids360 labels362 w350))) (k352 (cons e1358 e2359)
(extend-env61 labels362 (let ((w365 (if rec?347 new-w363 w350)) (trans-r366
(macros-only-env63 r349))) (map (lambda (x367) (cons (quote macro)
(eval-local-transformer110 (chi103 x367 trans-r366 w365)))) val357)) r349)
new-w363 s351)))))) tmp354) ((lambda (_369) (syntax-error (source-wrap96 e348
w350 s351))) tmp353))) (syntax-dispatch tmp353 (quote (any #(each (any any))
any . each-any))))) e348))) (chi-lambda-clause108 (lambda (e370 c371 r372 w373
k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (id377
e1378 e2379) (let ((ids380 id377)) (if (not (valid-bound-ids?92 ids380))
(syntax-error e370 (quote "invalid parameter list in")) (let ((labels382
(gen-labels73 ids380)) (new-vars383 (map gen-var115 ids380))) (k374 new-vars383
(chi-body107 (cons e1378 e2379) e370 (extend-var-env62 labels382 new-vars383
r372) (make-binding-wrap84 ids380 labels382 w373))))))) tmp376) ((lambda
(tmp385) (if tmp385 (apply (lambda (ids386 e1387 e2388) (let ((old-ids389
(lambda-var-list116 ids386))) (if (not (valid-bound-ids?92 old-ids389))
(syntax-error e370 (quote "invalid parameter list in")) (let ((labels390
(gen-labels73 old-ids389)) (new-vars391 (map gen-var115 old-ids389))) (k374
(let f392 ((ls1393 (cdr new-vars391)) (ls2394 (car new-vars391))) (if (null?
ls1393) ls2394 (f392 (cdr ls1393) (cons (car ls1393) ls2394)))) (chi-body107
(cons e1387 e2388) e370 (extend-var-env62 labels390 new-vars391 r372)
(make-binding-wrap84 old-ids389 labels390 w373))))))) tmp385) ((lambda (_396)
(syntax-error e370)) tmp375))) (syntax-dispatch tmp375 (quote (any any .
each-any)))))) (syntax-dispatch tmp375 (quote (each-any any . each-any)))))
c371))) (chi-body107 (lambda (body397 outer-form398 r399 w400) (let ((r401
(cons (quote ("placeholder" placeholder)) r399))) (let ((ribcage402
(make-ribcage74 (quote ()) (quote ()) (quote ())))) (let ((w403 (make-wrap69
(wrap-marks70 w400) (cons ribcage402 (wrap-subst71 w400))))) (let parse404
((body405 (map (lambda (x411) (cons r401 (wrap95 x411 w403))) body397)) (ids406
(quote ())) (labels407 (quote ())) (vars408 (quote ())) (vals409 (quote ()))
(bindings410 (quote ()))) (if (null? body405) (syntax-error outer-form398
(quote "no expressions in body")) (let ((e412 (cdar body405)) (er413 (caar
body405))) (call-with-values (lambda () (syntax-type101 e412 er413 (quote (()))
(quote #f) ribcage402)) (lambda (type414 value415 e416 w417 s418) (let ((t419
type414)) (if (memv t419 (quote (define-form))) (let ((id420 (wrap95 value415
w417)) (label421 (gen-label72))) (let ((var422 (gen-var115 id420))) (begin
(extend-ribcage!83 ribcage402 id420 label421) (parse404 (cdr body405) (cons
id420 ids406) (cons label421 labels407) (cons var422 vars408) (cons (cons er413
(wrap95 e416 w417)) vals409) (cons (cons (quote lexical) var422)
bindings410))))) (if (memv t419 (quote (define-syntax-form))) (let ((id423
(wrap95 value415 w417)) (label424 (gen-label72))) (begin (extend-ribcage!83
ribcage402 id423 label424) (parse404 (cdr body405) (cons id423 ids406) (cons
label424 labels407) vars408 vals409 (cons (cons (quote macro) (cons er413
(wrap95 e416 w417))) bindings410)))) (if (memv t419 (quote (begin-form)))
((lambda (tmp425) ((lambda (tmp426) (if tmp426 (apply (lambda (_427 e1428)
(parse404 (let f429 ((forms430 e1428)) (if (null? forms430) (cdr body405) (cons
(cons er413 (wrap95 (car forms430) w417)) (f429 (cdr forms430))))) ids406
labels407 vars408 vals409 bindings410)) tmp426) (syntax-error tmp425)))
(syntax-dispatch tmp425 (quote (any . each-any))))) e416) (if (memv t419 (quote
(local-syntax-form))) (chi-local-syntax109 value415 e416 er413 w417 s418
(lambda (forms432 er433 w434 s435) (parse404 (let f436 ((forms437 forms432))
(if (null? forms437) (cdr body405) (cons (cons er433 (wrap95 (car forms437)
w434)) (f436 (cdr forms437))))) ids406 labels407 vars408 vals409 bindings410)))
(if (null? ids406) (build-sequence48 (quote #f) (map (lambda (x438) (chi103
(cdr x438) (car x438) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417
s418)) (cdr body405)))) (begin (if (not (valid-bound-ids?92 ids406))
(syntax-error outer-form398 (quote "invalid or duplicate identifier in
definition"))) (let loop439 ((bs440 bindings410) (er-cache441 (quote #f))
(r-cache442 (quote #f))) (if (not (null? bs440)) (let ((b443 (car bs440))) (if
(eq? (car b443) (quote macro)) (let ((er444 (cadr b443))) (let ((r-cache445 (if
(eq? er444 er-cache441) r-cache442 (macros-only-env63 er444)))) (begin
(set-cdr! b443 (eval-local-transformer110 (chi103 (cddr b443) r-cache445 (quote
(()))))) (loop439 (cdr bs440) er444 r-cache445)))) (loop439 (cdr bs440)
er-cache441 r-cache442))))) (set-cdr! r401 (extend-env61 labels407 bindings410
(cdr r401))) (build-letrec51 (quote #f) vars408 (map (lambda (x446) (chi103
(cdr x446) (car x446) (quote (())))) vals409) (build-sequence48 (quote #f) (map
(lambda (x447) (chi103 (cdr x447) (car x447) (quote (())))) (cons (cons er413
(source-wrap96 e416 w417 s418)) (cdr body405))))))))))))))))))))))
(chi-macro106 (lambda (p448 e449 r450 w451 rib452) (letrec
((rebuild-macro-output453 (lambda (x454 m455) (cond ((pair? x454) (cons
(rebuild-macro-output453 (car x454) m455) (rebuild-macro-output453 (cdr x454)
m455))) ((syntax-object?53 x454) (let ((w456 (syntax-object-wrap55 x454))) (let
((ms457 (wrap-marks70 w456)) (s458 (wrap-subst71 w456))) (make-syntax-object52
(syntax-object-expression54 x454) (if (and (pair? ms457) (eq? (car ms457)
(quote #f))) (make-wrap69 (cdr ms457) (if rib452 (cons rib452 (cdr s458)) (cdr
s458))) (make-wrap69 (cons m455 ms457) (if rib452 (cons rib452 (cons (quote
shift) s458)) (cons (quote shift) s458)))))))) ((vector? x454) (let ((n459
(vector-length x454))) (let ((v460 (make-vector n459))) (let doloop461 ((i462
(quote 0))) (if (fx=40 i462 n459) v460 (begin (vector-set! v460 i462
(rebuild-macro-output453 (vector-ref x454 i462) m455)) (doloop461 (fx+38 i462
(quote 1))))))))) ((symbol? x454) (syntax-error x454 (quote "encountered raw
symbol in macro output"))) (else x454))))) (rebuild-macro-output453 (p448
(wrap95 e449 (anti-mark82 w451))) (string (quote #\m)))))) (chi-application105
(lambda (x463 e464 r465 w466 s467) ((lambda (tmp468) ((lambda (tmp469) (if
tmp469 (apply (lambda (e0470 e1471) (cons x463 (map (lambda (e472) (chi103 e472
r465 w466)) e1471))) tmp469) (syntax-error tmp468))) (syntax-dispatch tmp468
(quote (any . each-any))))) e464))) (chi-expr104 (lambda (type474 value475 e476
r477 w478 s479) (let ((t480 type474)) (if (memv t480 (quote (lexical)))
value475 (if (memv t480 (quote (core))) (value475 e476 r477 w478 s479) (if
(memv t480 (quote (lexical-call))) (chi-application105 value475 e476 r477 w478
s479) (if (memv t480 (quote (global-call))) (chi-application105 value475 e476
r477 w478 s479) (if (memv t480 (quote (constant))) (list (quote quote)
(strip114 (source-wrap96 e476 w478 s479) (quote (())))) (if (memv t480 (quote
(global))) value475 (if (memv t480 (quote (call))) (chi-application105 (chi103
(car e476) r477 w478) e476 r477 w478 s479) (if (memv t480 (quote (begin-form)))
((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 e1484
e2485) (chi-sequence97 (cons e1484 e2485) r477 w478 s479)) tmp482)
(syntax-error tmp481))) (syntax-dispatch tmp481 (quote (any any . each-any)))))
e476) (if (memv t480 (quote (local-syntax-form))) (chi-local-syntax109 value475
e476 r477 w478 s479 chi-sequence97) (if (memv t480 (quote (eval-when-form)))
((lambda (tmp487) ((lambda (tmp488) (if tmp488 (apply (lambda (_489 x490 e1491
e2492) (let ((when-list493 (chi-when-list100 e476 x490 w478))) (if (memq (quote
eval) when-list493) (chi-sequence97 (cons e1491 e2492) r477 w478 s479)
(chi-void111)))) tmp488) (syntax-error tmp487))) (syntax-dispatch tmp487 (quote
(any each-any any . each-any))))) e476) (if (memv t480 (quote (define-form
define-syntax-form))) (syntax-error (wrap95 value475 w478) (quote "invalid
context for definition of")) (if (memv t480 (quote (syntax))) (syntax-error
(source-wrap96 e476 w478 s479) (quote "reference to pattern variable outside
syntax form")) (if (memv t480 (quote (displaced-lexical))) (syntax-error
(source-wrap96 e476 w478 s479) (quote "reference to identifier outside its
scope")) (syntax-error (source-wrap96 e476 w478 s479)))))))))))))))))) (chi103
(lambda (e496 r497 w498) (call-with-values (lambda () (syntax-type101 e496 r497
w498 (quote #f) (quote #f))) (lambda (type499 value500 e501 w502 s503)
(chi-expr104 type499 value500 e501 r497 w502 s503))))) (chi-top102 (lambda
(e504 r505 w506 m507 esew508) (call-with-values (lambda () (syntax-type101 e504
r505 w506 (quote #f) (quote #f))) (lambda (type515 value516 e517 w518 s519)
(let ((t520 type515)) (if (memv t520 (quote (begin-form))) ((lambda (tmp521)
((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void111)) tmp522)
((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527)
(chi-top-sequence98 (cons e1526 e2527) r505 w518 s519 m507 esew508)) tmp524)
(syntax-error tmp521))) (syntax-dispatch tmp521 (quote (any any .
each-any)))))) (syntax-dispatch tmp521 (quote (any))))) e517) (if (memv t520
(quote (local-syntax-form))) (chi-local-syntax109 value516 e517 r505 w518 s519
(lambda (body529 r530 w531 s532) (chi-top-sequence98 body529 r530 w531 s532
m507 esew508))) (if (memv t520 (quote (eval-when-form))) ((lambda (tmp533)
((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let
((when-list539 (chi-when-list100 e517 x536 w518)) (body540 (cons e1537 e2538)))
(cond ((eq? m507 (quote e)) (if (memq (quote eval) when-list539)
(chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval)))
(chi-void111))) ((memq (quote load) when-list539) (if (or (memq (quote compile)
when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539)))
(chi-top-sequence98 body540 r505 w518 s519 (quote c&e) (quote (compile load)))
(if (memq m507 (quote (c c&e))) (chi-top-sequence98 body540 r505 w518 s519
(quote c) (quote (load))) (chi-void111)))) ((or (memq (quote compile)
when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539)))
(top-level-eval-hook43 (chi-top-sequence98 body540 r505 w518 s519 (quote e)
(quote (eval)))) (chi-void111)) (else (chi-void111))))) tmp534) (syntax-error
tmp533))) (syntax-dispatch tmp533 (quote (any each-any any . each-any)))))
e517) (if (memv t520 (quote (define-syntax-form))) (let ((n543 (id-var-name89
value516 w518)) (r544 (macros-only-env63 r505))) (let ((t545 m507)) (if (memv
t545 (quote (c))) (if (memq (quote compile) esew508) (let ((e546
(chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin
(top-level-eval-hook43 e546) (if (memq (quote load) esew508) e546
(chi-void111)))) (if (memq (quote load) esew508) (chi-install-global99 n543
(chi103 e517 r544 w518)) (chi-void111))) (if (memv t545 (quote (c&e))) (let
((e547 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin
(top-level-eval-hook43 e547) e547)) (begin (if (memq (quote eval) esew508)
(top-level-eval-hook43 (chi-install-global99 n543 (chi103 e517 r544 w518))))
(chi-void111)))))) (if (memv t520 (quote (define-form))) (let ((n548
(id-var-name89 value516 w518))) (let ((t549 (binding-type59 (lookup64 n548
r505)))) (if (memv t549 (quote (global))) (let ((x550 (list (quote define) n548
(chi103 e517 r505 w518)))) (begin (if (eq? m507 (quote c&e))
(top-level-eval-hook43 x550)) x550)) (if (memv t549 (quote
(displaced-lexical))) (syntax-error (wrap95 value516 w518) (quote "identifier
out of context")) (syntax-error (wrap95 value516 w518) (quote "cannot define
keyword at top level")))))) (let ((x551 (chi-expr104 type515 value516 e517 r505
w518 s519))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x551))
x551)))))))))))) (syntax-type101 (lambda (e552 r553 w554 s555 rib556) (cond
((symbol? e552) (let ((n557 (id-var-name89 e552 w554))) (let ((b558 (lookup64
n557 r553))) (let ((type559 (binding-type59 b558))) (let ((t560 type559)) (if
(memv t560 (quote (lexical))) (values type559 (binding-value60 b558) e552 w554
s555) (if (memv t560 (quote (global))) (values type559 n557 e552 w554 s555) (if
(memv t560 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60
b558) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (values type559
(binding-value60 b558) e552 w554 s555))))))))) ((pair? e552) (let ((first561
(car e552))) (if (id?67 first561) (let ((n562 (id-var-name89 first561 w554)))
(let ((b563 (lookup64 n562 r553))) (let ((type564 (binding-type59 b563))) (let
((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call)
(binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (global))) (values
(quote global-call) n562 e552 w554 s555) (if (memv t565 (quote (macro)))
(syntax-type101 (chi-macro106 (binding-value60 b563) e552 r553 w554 rib556)
r553 (quote (())) s555 rib556) (if (memv t565 (quote (core))) (values type564
(binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (local-syntax)))
(values (quote local-syntax-form) (binding-value60 b563) e552 w554 s555) (if
(memv t565 (quote (begin))) (values (quote begin-form) (quote #f) e552 w554
s555) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) (quote
#f) e552 w554 s555) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda
(tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?67 name569))
tmp567) (quote #f)) (apply (lambda (_571 name572 val573) (values (quote
define-form) name572 val573 w554 s555)) tmp567) ((lambda (tmp574) (if (if
tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?67 name576)
(valid-bound-ids?92 (lambda-var-list116 args577)))) tmp574) (quote #f)) (apply
(lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap95
name581 w554) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name
args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage ()
() ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis?
chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body
chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))))) (wrap95 (cons args582 (cons e1583 e2584))
w554)) (quote (())) s555)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply
(lambda (_587 name588) (id?67 name588)) tmp586) (quote #f)) (apply (lambda
(_589 name590) (values (quote define-form) (wrap95 name590 w554) (quote
(#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i"))
#(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip
strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source unannotate
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap
syntax-object-expression syntax-object? make-syntax-object self-evaluating?
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand)
((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s555))
tmp586) (syntax-error tmp566))) (syntax-dispatch tmp566 (quote (any any))))))
(syntax-dispatch tmp566 (quote (any (any . any) any . each-any))))))
(syntax-dispatch tmp566 (quote (any any any))))) e552) (if (memv t565 (quote
(define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply
(lambda (_593 name594 val595) (id?67 name594)) tmp592) (quote #f)) (apply
(lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598
w554 s555)) tmp592) (syntax-error tmp591))) (syntax-dispatch tmp591 (quote (any
any any))))) e552) (values (quote call) (quote #f) e552 w554 s555))))))))))))))
(values (quote call) (quote #f) e552 w554 s555)))) ((syntax-object?53 e552)
(syntax-type101 (syntax-object-expression54 e552) r553 (join-wraps86 w554
(syntax-object-wrap55 e552)) (quote #f) rib556)) ((annotation?42 e552)
(syntax-type101 (annotation-expression e552) r553 w554 (annotation-source e552)
rib556)) ((let ((x599 e552)) (or (boolean? x599) (number? x599) (string? x599)
(char? x599) (null? x599) (keyword? x599))) (values (quote constant) (quote #f)
e552 w554 s555)) (else (values (quote other) (quote #f) e552 w554 s555)))))
(chi-when-list100 (lambda (e600 when-list601 w602) (let f603 ((when-list604
when-list601) (situations605 (quote ()))) (if (null? when-list604)
situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604)))
(cond ((free-id=?90 x606 (quote #(syntax-object compile ((top) #(ribcage () ()
()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list
situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=?90 x606
(quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top)
(top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip
strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source unannotate
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap
syntax-object-expression syntax-object? make-syntax-object self-evaluating?
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand)
((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load))
((free-id=?90 x606 (quote #(syntax-object eval ((top) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list
situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap95
x606 w602) (quote "invalid eval-when situation"))))) situations605))))))
(chi-install-global99 (lambda (name607 e608) (list (quote
install-global-transformer) (list (quote quote) name607) e608)))
(chi-top-sequence98 (lambda (body609 r610 w611 s612 m613 esew614)
(build-sequence48 s612 (let dobody615 ((body616 body609) (r617 r610) (w618
w611) (m619 m613) (esew620 esew614)) (if (null? body616) (quote ()) (let
((first621 (chi-top102 (car body616) r617 w618 m619 esew620))) (cons first621
(dobody615 (cdr body616) r617 w618 m619 esew620)))))))) (chi-sequence97 (lambda
(body622 r623 w624 s625) (build-sequence48 s625 (let dobody626 ((body627
body622) (r628 r623) (w629 w624)) (if (null? body627) (quote ()) (let
((first630 (chi103 (car body627) r628 w629))) (cons first630 (dobody626 (cdr
body627) r628 w629)))))))) (source-wrap96 (lambda (x631 w632 s633) (wrap95 (if
s633 (make-annotation x631 s633 (quote #f)) x631) w632))) (wrap95 (lambda (x634
w635) (cond ((and (null? (wrap-marks70 w635)) (null? (wrap-subst71 w635)))
x634) ((syntax-object?53 x634) (make-syntax-object52
(syntax-object-expression54 x634) (join-wraps86 w635 (syntax-object-wrap55
x634)))) ((null? x634) x634) (else (make-syntax-object52 x634 w635)))))
(bound-id-member?94 (lambda (x636 list637) (and (not (null? list637)) (or
(bound-id=?91 x636 (car list637)) (bound-id-member?94 x636 (cdr list637))))))
(distinct-bound-ids?93 (lambda (ids638) (let distinct?639 ((ids640 ids638)) (or
(null? ids640) (and (not (bound-id-member?94 (car ids640) (cdr ids640)))
(distinct?639 (cdr ids640))))))) (valid-bound-ids?92 (lambda (ids641) (and (let
all-ids?642 ((ids643 ids641)) (or (null? ids643) (and (id?67 (car ids643))
(all-ids?642 (cdr ids643))))) (distinct-bound-ids?93 ids641)))) (bound-id=?91
(lambda (i644 j645) (if (and (syntax-object?53 i644) (syntax-object?53 j645))
(and (eq? (let ((e646 (syntax-object-expression54 i644))) (if (annotation?42
e646) (annotation-expression e646) e646)) (let ((e647
(syntax-object-expression54 j645))) (if (annotation?42 e647)
(annotation-expression e647) e647))) (same-marks?88 (wrap-marks70
(syntax-object-wrap55 i644)) (wrap-marks70 (syntax-object-wrap55 j645)))) (eq?
(let ((e648 i644)) (if (annotation?42 e648) (annotation-expression e648) e648))
(let ((e649 j645)) (if (annotation?42 e649) (annotation-expression e649)
e649)))))) (free-id=?90 (lambda (i650 j651) (and (eq? (let ((x652 i650)) (let
((e653 (if (syntax-object?53 x652) (syntax-object-expression54 x652) x652)))
(if (annotation?42 e653) (annotation-expression e653) e653))) (let ((x654
j651)) (let ((e655 (if (syntax-object?53 x654) (syntax-object-expression54
x654) x654))) (if (annotation?42 e655) (annotation-expression e655) e655))))
(eq? (id-var-name89 i650 (quote (()))) (id-var-name89 j651 (quote (())))))))
(id-var-name89 (lambda (id656 w657) (letrec ((search-vector-rib660 (lambda
(sym666 subst667 marks668 symnames669 ribcage670) (let ((n671 (vector-length
symnames669))) (let f672 ((i673 (quote 0))) (cond ((fx=40 i673 n671) (search658
sym666 (cdr subst667) marks668)) ((and (eq? (vector-ref symnames669 i673)
sym666) (same-marks?88 marks668 (vector-ref (ribcage-marks77 ribcage670)
i673))) (values (vector-ref (ribcage-labels78 ribcage670) i673) marks668))
(else (f672 (fx+38 i673 (quote 1))))))))) (search-list-rib659 (lambda (sym674
subst675 marks676 symnames677 ribcage678) (let f679 ((symnames680 symnames677)
(i681 (quote 0))) (cond ((null? symnames680) (search658 sym674 (cdr subst675)
marks676)) ((and (eq? (car symnames680) sym674) (same-marks?88 marks676
(list-ref (ribcage-marks77 ribcage678) i681))) (values (list-ref
(ribcage-labels78 ribcage678) i681) marks676)) (else (f679 (cdr symnames680)
(fx+38 i681 (quote 1)))))))) (search658 (lambda (sym682 subst683 marks684) (if
(null? subst683) (values (quote #f) marks684) (let ((fst685 (car subst683)))
(if (eq? fst685 (quote shift)) (search658 sym682 (cdr subst683) (cdr marks684))
(let ((symnames686 (ribcage-symnames76 fst685))) (if (vector? symnames686)
(search-vector-rib660 sym682 subst683 marks684 symnames686 fst685)
(search-list-rib659 sym682 subst683 marks684 symnames686 fst685))))))))) (cond
((symbol? id656) (or (call-with-values (lambda () (search658 id656
(wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x688 . ignore687) x688))
id656)) ((syntax-object?53 id656) (let ((id689 (let ((e691
(syntax-object-expression54 id656))) (if (annotation?42 e691)
(annotation-expression e691) e691))) (w1690 (syntax-object-wrap55 id656))) (let
((marks692 (join-marks87 (wrap-marks70 w657) (wrap-marks70 w1690))))
(call-with-values (lambda () (search658 id689 (wrap-subst71 w657) marks692))
(lambda (new-id693 marks694) (or new-id693 (call-with-values (lambda ()
(search658 id689 (wrap-subst71 w1690) marks694)) (lambda (x696 . ignore695)
x696)) id689)))))) ((annotation?42 id656) (let ((id697 (let ((e698 id656)) (if
(annotation?42 e698) (annotation-expression e698) e698)))) (or
(call-with-values (lambda () (search658 id697 (wrap-subst71 w657) (wrap-marks70
w657))) (lambda (x700 . ignore699) x700)) id697))) (else (error-hook45 (quote
id-var-name) (quote "invalid id") id656)))))) (same-marks?88 (lambda (x701
y702) (or (eq? x701 y702) (and (not (null? x701)) (not (null? y702)) (eq? (car
x701) (car y702)) (same-marks?88 (cdr x701) (cdr y702)))))) (join-marks87
(lambda (m1703 m2704) (smart-append85 m1703 m2704))) (join-wraps86 (lambda
(w1705 w2706) (let ((m1707 (wrap-marks70 w1705)) (s1708 (wrap-subst71 w1705)))
(if (null? m1707) (if (null? s1708) w2706 (make-wrap69 (wrap-marks70 w2706)
(smart-append85 s1708 (wrap-subst71 w2706)))) (make-wrap69 (smart-append85
m1707 (wrap-marks70 w2706)) (smart-append85 s1708 (wrap-subst71 w2706)))))))
(smart-append85 (lambda (m1709 m2710) (if (null? m2710) m1709 (append m1709
m2710)))) (make-binding-wrap84 (lambda (ids711 labels712 w713) (if (null?
ids711) w713 (make-wrap69 (wrap-marks70 w713) (cons (let ((labelvec714
(list->vector labels712))) (let ((n715 (vector-length labelvec714))) (let
((symnamevec716 (make-vector n715)) (marksvec717 (make-vector n715))) (begin
(let f718 ((ids719 ids711) (i720 (quote 0))) (if (not (null? ids719))
(call-with-values (lambda () (id-sym-name&marks68 (car ids719) w713)) (lambda
(symname721 marks722) (begin (vector-set! symnamevec716 i720 symname721)
(vector-set! marksvec717 i720 marks722) (f718 (cdr ids719) (fx+38 i720 (quote
1)))))))) (make-ribcage74 symnamevec716 marksvec717 labelvec714)))))
(wrap-subst71 w713)))))) (extend-ribcage!83 (lambda (ribcage723 id724 label725)
(begin (set-ribcage-symnames!79 ribcage723 (cons (let ((e726
(syntax-object-expression54 id724))) (if (annotation?42 e726)
(annotation-expression e726) e726)) (ribcage-symnames76 ribcage723)))
(set-ribcage-marks!80 ribcage723 (cons (wrap-marks70 (syntax-object-wrap55
id724)) (ribcage-marks77 ribcage723))) (set-ribcage-labels!81 ribcage723 (cons
label725 (ribcage-labels78 ribcage723)))))) (anti-mark82 (lambda (w727)
(make-wrap69 (cons (quote #f) (wrap-marks70 w727)) (cons (quote shift)
(wrap-subst71 w727))))) (set-ribcage-labels!81 (lambda (x728 update729)
(vector-set! x728 (quote 3) update729))) (set-ribcage-marks!80 (lambda (x730
update731) (vector-set! x730 (quote 2) update731))) (set-ribcage-symnames!79
(lambda (x732 update733) (vector-set! x732 (quote 1) update733)))
(ribcage-labels78 (lambda (x734) (vector-ref x734 (quote 3)))) (ribcage-marks77
(lambda (x735) (vector-ref x735 (quote 2)))) (ribcage-symnames76 (lambda (x736)
(vector-ref x736 (quote 1)))) (ribcage?75 (lambda (x737) (and (vector? x737) (=
(vector-length x737) (quote 4)) (eq? (vector-ref x737 (quote 0)) (quote
ribcage))))) (make-ribcage74 (lambda (symnames738 marks739 labels740) (vector
(quote ribcage) symnames738 marks739 labels740))) (gen-labels73 (lambda (ls741)
(if (null? ls741) (quote ()) (cons (gen-label72) (gen-labels73 (cdr ls741))))))
(gen-label72 (lambda () (string (quote #\i)))) (wrap-subst71 cdr) (wrap-marks70
car) (make-wrap69 cons) (id-sym-name&marks68 (lambda (x742 w743) (if
(syntax-object?53 x742) (values (let ((e744 (syntax-object-expression54 x742)))
(if (annotation?42 e744) (annotation-expression e744) e744)) (join-marks87
(wrap-marks70 w743) (wrap-marks70 (syntax-object-wrap55 x742)))) (values (let
((e745 x742)) (if (annotation?42 e745) (annotation-expression e745) e745))
(wrap-marks70 w743))))) (id?67 (lambda (x746) (cond ((symbol? x746) (quote #t))
((syntax-object?53 x746) (symbol? (let ((e747 (syntax-object-expression54
x746))) (if (annotation?42 e747) (annotation-expression e747) e747))))
((annotation?42 x746) (symbol? (annotation-expression x746))) (else (quote
#f))))) (nonsymbol-id?66 (lambda (x748) (and (syntax-object?53 x748) (symbol?
(let ((e749 (syntax-object-expression54 x748))) (if (annotation?42 e749)
(annotation-expression e749) e749)))))) (global-extend65 (lambda (type750
sym751 val752) (put-global-definition-hook46 sym751 (cons type750 val752))))
(lookup64 (lambda (x753 r754) (cond ((assq x753 r754) => cdr) ((symbol? x753)
(or (get-global-definition-hook47 x753) (quote (global)))) (else (quote
(displaced-lexical)))))) (macros-only-env63 (lambda (r755) (if (null? r755)
(quote ()) (let ((a756 (car r755))) (if (eq? (cadr a756) (quote macro)) (cons
a756 (macros-only-env63 (cdr r755))) (macros-only-env63 (cdr r755)))))))
(extend-var-env62 (lambda (labels757 vars758 r759) (if (null? labels757) r759
(extend-var-env62 (cdr labels757) (cdr vars758) (cons (cons (car labels757)
(cons (quote lexical) (car vars758))) r759))))) (extend-env61 (lambda
(labels760 bindings761 r762) (if (null? labels760) r762 (extend-env61 (cdr
labels760) (cdr bindings761) (cons (cons (car labels760) (car bindings761))
r762))))) (binding-value60 cdr) (binding-type59 car) (source-annotation58
(lambda (x763) (cond ((annotation?42 x763) (annotation-source x763))
((syntax-object?53 x763) (source-annotation58 (syntax-object-expression54
x763))) (else (quote #f))))) (set-syntax-object-wrap!57 (lambda (x764
update765) (vector-set! x764 (quote 2) update765)))
(set-syntax-object-expression!56 (lambda (x766 update767) (vector-set! x766
(quote 1) update767))) (syntax-object-wrap55 (lambda (x768) (vector-ref x768
(quote 2)))) (syntax-object-expression54 (lambda (x769) (vector-ref x769 (quote
1)))) (syntax-object?53 (lambda (x770) (and (vector? x770) (= (vector-length
x770) (quote 3)) (eq? (vector-ref x770 (quote 0)) (quote syntax-object)))))
(make-syntax-object52 (lambda (expression771 wrap772) (vector (quote
syntax-object) expression771 wrap772))) (build-letrec51 (lambda (src773 vars774
val-exps775 body-exp776) (if (null? vars774) body-exp776 (list (quote letrec)
(map list vars774 val-exps775) body-exp776)))) (build-named-let50 (lambda
(src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list
(quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780))))
(build-let49 (lambda (src781 vars782 val-exps783 body-exp784) (if (null?
vars782) body-exp784 (list (quote let) (map list vars782 val-exps783)
body-exp784)))) (build-sequence48 (lambda (src785 exps786) (if (null? (cdr
exps786)) (car exps786) (cons (quote begin) exps786))))
(get-global-definition-hook47 (lambda (symbol787) (getprop symbol787 (quote
*sc-expander*)))) (put-global-definition-hook46 (lambda (symbol788 binding789)
(putprop symbol788 (quote *sc-expander*) binding789))) (error-hook45 (lambda
(who790 why791 what792) (error who790 (quote "~a ~s") why791 what792)))
(local-eval-hook44 (lambda (x793) (eval (list noexpand37 x793)
(interaction-environment)))) (top-level-eval-hook43 (lambda (x794) (eval (list
noexpand37 x794) (interaction-environment)))) (annotation?42 (lambda (x795)
(quote #f))) (fx<41 <) (fx=40 =) (fx-39 -) (fx+38 +) (noexpand37 (quote
"noexpand"))) (begin (global-extend65 (quote local-syntax) (quote
letrec-syntax) (quote #t)) (global-extend65 (quote local-syntax) (quote
let-syntax) (quote #f)) (global-extend65 (quote core) (quote fluid-let-syntax)
(lambda (e796 r797 w798 s799) ((lambda (tmp800) ((lambda (tmp801) (if (if
tmp801 (apply (lambda (_802 var803 val804 e1805 e2806) (valid-bound-ids?92
var803)) tmp801) (quote #f)) (apply (lambda (_808 var809 val810 e1811 e2812)
(let ((names813 (map (lambda (x814) (id-var-name89 x814 w798)) var809))) (begin
(for-each (lambda (id816 n817) (let ((t818 (binding-type59 (lookup64 n817
r797)))) (if (memv t818 (quote (displaced-lexical))) (syntax-error
(source-wrap96 id816 w798 s799) (quote "identifier out of context"))))) var809
names813) (chi-body107 (cons e1811 e2812) (source-wrap96 e796 w798 s799)
(extend-env61 names813 (let ((trans-r821 (macros-only-env63 r797))) (map
(lambda (x822) (cons (quote macro) (eval-local-transformer110 (chi103 x822
trans-r821 w798)))) val810)) r797) w798)))) tmp801) ((lambda (_824)
(syntax-error (source-wrap96 e796 w798 s799))) tmp800))) (syntax-dispatch
tmp800 (quote (any #(each (any any)) any . each-any))))) e796)))
(global-extend65 (quote core) (quote quote) (lambda (e825 r826 w827 s828)
((lambda (tmp829) ((lambda (tmp830) (if tmp830 (apply (lambda (_831 e832) (list
(quote quote) (strip114 e832 w827))) tmp830) ((lambda (_833) (syntax-error
(source-wrap96 e825 w827 s828))) tmp829))) (syntax-dispatch tmp829 (quote (any
any))))) e825))) (global-extend65 (quote core) (quote syntax) (letrec
((regen841 (lambda (x842) (let ((t843 (car x842))) (if (memv t843 (quote
(ref))) (cadr x842) (if (memv t843 (quote (primitive))) (cadr x842) (if (memv
t843 (quote (quote))) (list (quote quote) (cadr x842)) (if (memv t843 (quote
(lambda))) (list (quote lambda) (cadr x842) (regen841 (caddr x842))) (if (memv
t843 (quote (map))) (let ((ls844 (map regen841 (cdr x842)))) (cons (if (fx=40
(length ls844) (quote 2)) (quote map) (quote map)) ls844)) (cons (car x842)
(map regen841 (cdr x842))))))))))) (gen-vector840 (lambda (x845) (cond ((eq?
(car x845) (quote list)) (cons (quote vector) (cdr x845))) ((eq? (car x845)
(quote quote)) (list (quote quote) (list->vector (cadr x845)))) (else (list
(quote list->vector) x845))))) (gen-append839 (lambda (x846 y847) (if (equal?
y847 (quote (quote ()))) x846 (list (quote append) x846 y847)))) (gen-cons838
(lambda (x848 y849) (let ((t850 (car y849))) (if (memv t850 (quote (quote)))
(if (eq? (car x848) (quote quote)) (list (quote quote) (cons (cadr x848) (cadr
y849))) (if (eq? (cadr y849) (quote ())) (list (quote list) x848) (list (quote
cons) x848 y849))) (if (memv t850 (quote (list))) (cons (quote list) (cons x848
(cdr y849))) (list (quote cons) x848 y849)))))) (gen-map837 (lambda (e851
map-env852) (let ((formals853 (map cdr map-env852)) (actuals854 (map (lambda
(x855) (list (quote ref) (car x855))) map-env852))) (cond ((eq? (car e851)
(quote ref)) (car actuals854)) ((andmap (lambda (x856) (and (eq? (car x856)
(quote ref)) (memq (cadr x856) formals853))) (cdr e851)) (cons (quote map)
(cons (list (quote primitive) (car e851)) (map (let ((r857 (map cons formals853
actuals854))) (lambda (x858) (cdr (assq (cadr x858) r857)))) (cdr e851)))))
(else (cons (quote map) (cons (list (quote lambda) formals853 e851)
actuals854))))))) (gen-mappend836 (lambda (e859 map-env860) (list (quote apply)
(quote (primitive append)) (gen-map837 e859 map-env860)))) (gen-ref835 (lambda
(src861 var862 level863 maps864) (if (fx=40 level863 (quote 0)) (values var862
maps864) (if (null? maps864) (syntax-error src861 (quote "missing ellipsis in
syntax form")) (call-with-values (lambda () (gen-ref835 src861 var862 (fx-39
level863 (quote 1)) (cdr maps864))) (lambda (outer-var865 outer-maps866) (let
((b867 (assq outer-var865 (car maps864)))) (if b867 (values (cdr b867) maps864)
(let ((inner-var868 (gen-var115 (quote tmp)))) (values inner-var868 (cons (cons
(cons outer-var865 inner-var868) (car maps864)) outer-maps866)))))))))))
(gen-syntax834 (lambda (src869 e870 r871 maps872 ellipsis?873) (if (id?67 e870)
(let ((label874 (id-var-name89 e870 (quote (()))))) (let ((b875 (lookup64
label874 r871))) (if (eq? (binding-type59 b875) (quote syntax))
(call-with-values (lambda () (let ((var.lev876 (binding-value60 b875)))
(gen-ref835 src869 (car var.lev876) (cdr var.lev876) maps872))) (lambda (var877
maps878) (values (list (quote ref) var877) maps878))) (if (ellipsis?873 e870)
(syntax-error src869 (quote "misplaced ellipsis in syntax form")) (values (list
(quote quote) e870) maps872))))) ((lambda (tmp879) ((lambda (tmp880) (if (if
tmp880 (apply (lambda (dots881 e882) (ellipsis?873 dots881)) tmp880) (quote
#f)) (apply (lambda (dots883 e884) (gen-syntax834 src869 e884 r871 maps872
(lambda (x885) (quote #f)))) tmp880) ((lambda (tmp886) (if (if tmp886 (apply
(lambda (x887 dots888 y889) (ellipsis?873 dots888)) tmp886) (quote #f)) (apply
(lambda (x890 dots891 y892) (let f893 ((y894 y892) (k895 (lambda (maps896)
(call-with-values (lambda () (gen-syntax834 src869 x890 r871 (cons (quote ())
maps896) ellipsis?873)) (lambda (x897 maps898) (if (null? (car maps898))
(syntax-error src869 (quote "extra ellipsis in syntax form")) (values
(gen-map837 x897 (car maps898)) (cdr maps898)))))))) ((lambda (tmp899) ((lambda
(tmp900) (if (if tmp900 (apply (lambda (dots901 y902) (ellipsis?873 dots901))
tmp900) (quote #f)) (apply (lambda (dots903 y904) (f893 y904 (lambda (maps905)
(call-with-values (lambda () (k895 (cons (quote ()) maps905))) (lambda (x906
maps907) (if (null? (car maps907)) (syntax-error src869 (quote "extra ellipsis
in syntax form")) (values (gen-mappend836 x906 (car maps907)) (cdr
maps907)))))))) tmp900) ((lambda (_908) (call-with-values (lambda ()
(gen-syntax834 src869 y894 r871 maps872 ellipsis?873)) (lambda (y909 maps910)
(call-with-values (lambda () (k895 maps910)) (lambda (x911 maps912) (values
(gen-append839 x911 y909) maps912)))))) tmp899))) (syntax-dispatch tmp899
(quote (any . any))))) y894))) tmp886) ((lambda (tmp913) (if tmp913 (apply
(lambda (x914 y915) (call-with-values (lambda () (gen-syntax834 src869 x914
r871 maps872 ellipsis?873)) (lambda (x916 maps917) (call-with-values (lambda ()
(gen-syntax834 src869 y915 r871 maps917 ellipsis?873)) (lambda (y918 maps919)
(values (gen-cons838 x916 y918) maps919)))))) tmp913) ((lambda (tmp920) (if
tmp920 (apply (lambda (e1921 e2922) (call-with-values (lambda () (gen-syntax834
src869 (cons e1921 e2922) r871 maps872 ellipsis?873)) (lambda (e924 maps925)
(values (gen-vector840 e924) maps925)))) tmp920) ((lambda (_926) (values (list
(quote quote) e870) maps872)) tmp879))) (syntax-dispatch tmp879 (quote #(vector
(any . each-any))))))) (syntax-dispatch tmp879 (quote (any . any))))))
(syntax-dispatch tmp879 (quote (any any . any)))))) (syntax-dispatch tmp879
(quote (any any))))) e870))))) (lambda (e927 r928 w929 s930) (let ((e931
(source-wrap96 e927 w929 s930))) ((lambda (tmp932) ((lambda (tmp933) (if tmp933
(apply (lambda (_934 x935) (call-with-values (lambda () (gen-syntax834 e931
x935 r928 (quote ()) ellipsis?112)) (lambda (e936 maps937) (regen841 e936))))
tmp933) ((lambda (_938) (syntax-error e931)) tmp932))) (syntax-dispatch tmp932
(quote (any any))))) e931))))) (global-extend65 (quote core) (quote lambda)
(lambda (e939 r940 w941 s942) ((lambda (tmp943) ((lambda (tmp944) (if tmp944
(apply (lambda (_945 c946) (chi-lambda-clause108 (source-wrap96 e939 w941 s942)
c946 r940 w941 (lambda (vars947 body948) (list (quote lambda) vars947
body948)))) tmp944) (syntax-error tmp943))) (syntax-dispatch tmp943 (quote (any
. any))))) e939))) (global-extend65 (quote core) (quote let) (letrec
((chi-let949 (lambda (e950 r951 w952 s953 constructor954 ids955 vals956
exps957) (if (not (valid-bound-ids?92 ids955)) (syntax-error e950 (quote
"duplicate bound variable in")) (let ((labels958 (gen-labels73 ids955))
(new-vars959 (map gen-var115 ids955))) (let ((nw960 (make-binding-wrap84 ids955
labels958 w952)) (nr961 (extend-var-env62 labels958 new-vars959 r951)))
(constructor954 s953 new-vars959 (map (lambda (x962) (chi103 x962 r951 w952))
vals956) (chi-body107 exps957 (source-wrap96 e950 nw960 s953) nr961
nw960)))))))) (lambda (e963 r964 w965 s966) ((lambda (tmp967) ((lambda (tmp968)
(if tmp968 (apply (lambda (_969 id970 val971 e1972 e2973) (chi-let949 e963 r964
w965 s966 build-let49 id970 val971 (cons e1972 e2973))) tmp968) ((lambda
(tmp977) (if (if tmp977 (apply (lambda (_978 f979 id980 val981 e1982 e2983)
(id?67 f979)) tmp977) (quote #f)) (apply (lambda (_984 f985 id986 val987 e1988
e2989) (chi-let949 e963 r964 w965 s966 build-named-let50 (cons f985 id986)
val987 (cons e1988 e2989))) tmp977) ((lambda (_993) (syntax-error
(source-wrap96 e963 w965 s966))) tmp967))) (syntax-dispatch tmp967 (quote (any
any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp967 (quote (any
#(each (any any)) any . each-any))))) e963)))) (global-extend65 (quote core)
(quote letrec) (lambda (e994 r995 w996 s997) ((lambda (tmp998) ((lambda
(tmp999) (if tmp999 (apply (lambda (_1000 id1001 val1002 e11003 e21004) (let
((ids1005 id1001)) (if (not (valid-bound-ids?92 ids1005)) (syntax-error e994
(quote "duplicate bound variable in")) (let ((labels1007 (gen-labels73
ids1005)) (new-vars1008 (map gen-var115 ids1005))) (let ((w1009
(make-binding-wrap84 ids1005 labels1007 w996)) (r1010 (extend-var-env62
labels1007 new-vars1008 r995))) (build-letrec51 s997 new-vars1008 (map (lambda
(x1011) (chi103 x1011 r1010 w1009)) val1002) (chi-body107 (cons e11003 e21004)
(source-wrap96 e994 w1009 s997) r1010 w1009))))))) tmp999) ((lambda (_1014)
(syntax-error (source-wrap96 e994 w996 s997))) tmp998))) (syntax-dispatch
tmp998 (quote (any #(each (any any)) any . each-any))))) e994)))
(global-extend65 (quote core) (quote set!) (lambda (e1015 r1016 w1017 s1018)
((lambda (tmp1019) ((lambda (tmp1020) (if (if tmp1020 (apply (lambda (_1021
id1022 val1023) (id?67 id1022)) tmp1020) (quote #f)) (apply (lambda (_1024
id1025 val1026) (let ((val1027 (chi103 val1026 r1016 w1017)) (n1028
(id-var-name89 id1025 w1017))) (let ((b1029 (lookup64 n1028 r1016))) (let
((t1030 (binding-type59 b1029))) (if (memv t1030 (quote (lexical))) (list
(quote set!) (binding-value60 b1029) val1027) (if (memv t1030 (quote (global)))
(list (quote set!) n1028 val1027) (if (memv t1030 (quote (displaced-lexical)))
(syntax-error (wrap95 id1025 w1017) (quote "identifier out of context"))
(syntax-error (source-wrap96 e1015 w1017 s1018))))))))) tmp1020) ((lambda
(tmp1031) (if tmp1031 (apply (lambda (_1032 getter1033 arg1034 val1035) (cons
(chi103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg
val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))))) getter1033) r1016 w1017) (map (lambda
(e1036) (chi103 e1036 r1016 w1017)) (append arg1034 (list val1035))))) tmp1031)
((lambda (_1038) (syntax-error (source-wrap96 e1015 w1017 s1018))) tmp1019)))
(syntax-dispatch tmp1019 (quote (any (any . each-any) any))))))
(syntax-dispatch tmp1019 (quote (any any any))))) e1015))) (global-extend65
(quote begin) (quote begin) (quote ())) (global-extend65 (quote define) (quote
define) (quote ())) (global-extend65 (quote define-syntax) (quote
define-syntax) (quote ())) (global-extend65 (quote eval-when) (quote eval-when)
(quote ())) (global-extend65 (quote core) (quote syntax-case) (letrec
((gen-syntax-case1042 (lambda (x1043 keys1044 clauses1045 r1046) (if (null?
clauses1045) (list (quote syntax-error) x1043) ((lambda (tmp1047) ((lambda
(tmp1048) (if tmp1048 (apply (lambda (pat1049 exp1050) (if (and (id?67 pat1049)
(andmap (lambda (x1051) (not (free-id=?90 pat1049 x1051))) (cons (quote
#(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top))
#("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call
convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))))) keys1044))) (let ((labels1052 (list
(gen-label72))) (var1053 (gen-var115 pat1049))) (list (list (quote lambda)
(list var1053) (chi103 exp1050 (extend-env61 labels1052 (list (cons (quote
syntax) (cons var1053 (quote 0)))) r1046) (make-binding-wrap84 (list pat1049)
labels1052 (quote (()))))) x1043)) (gen-clause1041 x1043 keys1044 (cdr
clauses1045) r1046 pat1049 (quote #t) exp1050))) tmp1048) ((lambda (tmp1054)
(if tmp1054 (apply (lambda (pat1055 fender1056 exp1057) (gen-clause1041 x1043
keys1044 (cdr clauses1045) r1046 pat1055 fender1056 exp1057)) tmp1054) ((lambda
(_1058) (syntax-error (car clauses1045) (quote "invalid syntax-case clause")))
tmp1047))) (syntax-dispatch tmp1047 (quote (any any any)))))) (syntax-dispatch
tmp1047 (quote (any any))))) (car clauses1045))))) (gen-clause1041 (lambda
(x1059 keys1060 clauses1061 r1062 pat1063 fender1064 exp1065) (call-with-values
(lambda () (convert-pattern1039 pat1063 keys1060)) (lambda (p1066 pvars1067)
(cond ((not (distinct-bound-ids?93 (map car pvars1067))) (syntax-error pat1063
(quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap
(lambda (x1068) (not (ellipsis?112 (car x1068)))) pvars1067)) (syntax-error
pat1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let
((y1069 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list y1069) (let
((y1070 y1069)) (list (quote if) ((lambda (tmp1071) ((lambda (tmp1072) (if
tmp1072 (apply (lambda () y1070) tmp1072) ((lambda (_1073) (list (quote if)
y1070 (build-dispatch-call1040 pvars1067 fender1064 y1070 r1062) (list (quote
quote) (quote #f)))) tmp1071))) (syntax-dispatch tmp1071 (quote #(atom #t)))))
fender1064) (build-dispatch-call1040 pvars1067 exp1065 y1070 r1062)
(gen-syntax-case1042 x1059 keys1060 clauses1061 r1062)))) (if (eq? p1066 (quote
any)) (list (quote list) x1059) (list (quote syntax-dispatch) x1059 (list
(quote quote) p1066))))))))))) (build-dispatch-call1040 (lambda (pvars1074
exp1075 y1076 r1077) (let ((ids1078 (map car pvars1074)) (levels1079 (map cdr
pvars1074))) (let ((labels1080 (gen-labels73 ids1078)) (new-vars1081 (map
gen-var115 ids1078))) (list (quote apply) (list (quote lambda) new-vars1081
(chi103 exp1075 (extend-env61 labels1080 (map (lambda (var1082 level1083) (cons
(quote syntax) (cons var1082 level1083))) new-vars1081 (map cdr pvars1074))
r1077) (make-binding-wrap84 ids1078 labels1080 (quote (()))))) y1076)))))
(convert-pattern1039 (lambda (pattern1084 keys1085) (let cvt1086 ((p1087
pattern1084) (n1088 (quote 0)) (ids1089 (quote ()))) (if (id?67 p1087) (if
(bound-id-member?94 p1087 keys1085) (values (vector (quote free-id) p1087)
ids1089) (values (quote any) (cons (cons p1087 n1088) ids1089))) ((lambda
(tmp1090) ((lambda (tmp1091) (if (if tmp1091 (apply (lambda (x1092 dots1093)
(ellipsis?112 dots1093)) tmp1091) (quote #f)) (apply (lambda (x1094 dots1095)
(call-with-values (lambda () (cvt1086 x1094 (fx+38 n1088 (quote 1)) ids1089))
(lambda (p1096 ids1097) (values (if (eq? p1096 (quote any)) (quote each-any)
(vector (quote each) p1096)) ids1097)))) tmp1091) ((lambda (tmp1098) (if
tmp1098 (apply (lambda (x1099 y1100) (call-with-values (lambda () (cvt1086
y1100 n1088 ids1089)) (lambda (y1101 ids1102) (call-with-values (lambda ()
(cvt1086 x1099 n1088 ids1102)) (lambda (x1103 ids1104) (values (cons x1103
y1101) ids1104)))))) tmp1098) ((lambda (tmp1105) (if tmp1105 (apply (lambda ()
(values (quote ()) ids1089)) tmp1105) ((lambda (tmp1106) (if tmp1106 (apply
(lambda (x1107) (call-with-values (lambda () (cvt1086 x1107 n1088 ids1089))
(lambda (p1109 ids1110) (values (vector (quote vector) p1109) ids1110))))
tmp1106) ((lambda (x1111) (values (vector (quote atom) (strip114 p1087 (quote
(())))) ids1089)) tmp1090))) (syntax-dispatch tmp1090 (quote #(vector
each-any)))))) (syntax-dispatch tmp1090 (quote ()))))) (syntax-dispatch tmp1090
(quote (any . any)))))) (syntax-dispatch tmp1090 (quote (any any)))))
p1087)))))) (lambda (e1112 r1113 w1114 s1115) (let ((e1116 (source-wrap96 e1112
w1114 s1115))) ((lambda (tmp1117) ((lambda (tmp1118) (if tmp1118 (apply (lambda
(_1119 val1120 key1121 m1122) (if (andmap (lambda (x1123) (and (id?67 x1123)
(not (ellipsis?112 x1123)))) key1121) (let ((x1125 (gen-var115 (quote tmp))))
(list (list (quote lambda) (list x1125) (gen-syntax-case1042 x1125 key1121
m1122 r1113)) (chi103 val1120 r1113 (quote (()))))) (syntax-error e1116 (quote
"invalid literals list in")))) tmp1118) (syntax-error tmp1117)))
(syntax-dispatch tmp1117 (quote (any any each-any . each-any))))) e1116)))))
(set! sc-expand (let ((m1128 (quote e)) (esew1129 (quote (eval)))) (lambda
(x1130) (if (and (pair? x1130) (equal? (car x1130) noexpand37)) (cadr x1130)
(chi-top102 x1130 (quote ()) (quote ((top))) m1128 esew1129))))) (set!
sc-expand3 (let ((m1131 (quote e)) (esew1132 (quote (eval)))) (lambda (x1134 .
rest1133) (if (and (pair? x1134) (equal? (car x1134) noexpand37)) (cadr x1134)
(chi-top102 x1134 (quote ()) (quote ((top))) (if (null? rest1133) m1131 (car
rest1133)) (if (or (null? rest1133) (null? (cdr rest1133))) esew1132 (cadr
rest1133))))))) (set! identifier? (lambda (x1135) (nonsymbol-id?66 x1135)))
(set! datum->syntax-object (lambda (id1136 datum1137) (begin (let ((x1138
id1136)) (if (not (nonsymbol-id?66 x1138)) (error-hook45 (quote
datum->syntax-object) (quote "invalid argument") x1138))) (make-syntax-object52
datum1137 (syntax-object-wrap55 id1136))))) (set! syntax-object->datum (lambda
(x1139) (strip114 x1139 (quote (()))))) (set! generate-temporaries (lambda
(ls1140) (begin (let ((x1141 ls1140)) (if (not (list? x1141)) (error-hook45
(quote generate-temporaries) (quote "invalid argument") x1141))) (map (lambda
(x1142) (wrap95 (gensym) (quote ((top))))) ls1140)))) (set! free-identifier=?
(lambda (x1143 y1144) (begin (let ((x1145 x1143)) (if (not (nonsymbol-id?66
x1145)) (error-hook45 (quote free-identifier=?) (quote "invalid argument")
x1145))) (let ((x1146 y1144)) (if (not (nonsymbol-id?66 x1146)) (error-hook45
(quote free-identifier=?) (quote "invalid argument") x1146))) (free-id=?90
x1143 y1144)))) (set! bound-identifier=? (lambda (x1147 y1148) (begin (let
((x1149 x1147)) (if (not (nonsymbol-id?66 x1149)) (error-hook45 (quote
bound-identifier=?) (quote "invalid argument") x1149))) (let ((x1150 y1148))
(if (not (nonsymbol-id?66 x1150)) (error-hook45 (quote bound-identifier=?)
(quote "invalid argument") x1150))) (bound-id=?91 x1147 y1148)))) (set!
syntax-error (lambda (object1152 . messages1151) (begin (for-each (lambda
(x1153) (let ((x1154 x1153)) (if (not (string? x1154)) (error-hook45 (quote
syntax-error) (quote "invalid argument") x1154)))) messages1151) (let
((message1155 (if (null? messages1151) (quote "invalid syntax") (apply
string-append messages1151)))) (error-hook45 (quote #f) message1155 (strip114
object1152 (quote (())))))))) (set! install-global-transformer (lambda (sym1156
v1157) (begin (let ((x1158 sym1156)) (if (not (symbol? x1158)) (error-hook45
(quote define-syntax) (quote "invalid argument") x1158))) (let ((x1159 v1157))
(if (not (procedure? x1159)) (error-hook45 (quote define-syntax) (quote
"invalid argument") x1159))) (global-extend65 (quote macro) sym1156 v1157))))
(letrec ((match1164 (lambda (e1165 p1166 w1167 r1168) (cond ((not r1168) (quote
#f)) ((eq? p1166 (quote any)) (cons (wrap95 e1165 w1167) r1168))
((syntax-object?53 e1165) (match*1163 (let ((e1169 (syntax-object-expression54
e1165))) (if (annotation?42 e1169) (annotation-expression e1169) e1169)) p1166
(join-wraps86 w1167 (syntax-object-wrap55 e1165)) r1168)) (else (match*1163
(let ((e1170 e1165)) (if (annotation?42 e1170) (annotation-expression e1170)
e1170)) p1166 w1167 r1168))))) (match*1163 (lambda (e1171 p1172 w1173 r1174)
(cond ((null? p1172) (and (null? e1171) r1174)) ((pair? p1172) (and (pair?
e1171) (match1164 (car e1171) (car p1172) w1173 (match1164 (cdr e1171) (cdr
p1172) w1173 r1174)))) ((eq? p1172 (quote each-any)) (let ((l1175
(match-each-any1161 e1171 w1173))) (and l1175 (cons l1175 r1174)))) (else (let
((t1176 (vector-ref p1172 (quote 0)))) (if (memv t1176 (quote (each))) (if
(null? e1171) (match-empty1162 (vector-ref p1172 (quote 1)) r1174) (let ((l1177
(match-each1160 e1171 (vector-ref p1172 (quote 1)) w1173))) (and l1177 (let
collect1178 ((l1179 l1177)) (if (null? (car l1179)) r1174 (cons (map car l1179)
(collect1178 (map cdr l1179)))))))) (if (memv t1176 (quote (free-id))) (and
(id?67 e1171) (free-id=?90 (wrap95 e1171 w1173) (vector-ref p1172 (quote 1)))
r1174) (if (memv t1176 (quote (atom))) (and (equal? (vector-ref p1172 (quote
1)) (strip114 e1171 w1173)) r1174) (if (memv t1176 (quote (vector))) (and
(vector? e1171) (match1164 (vector->list e1171) (vector-ref p1172 (quote 1))
w1173 r1174))))))))))) (match-empty1162 (lambda (p1180 r1181) (cond ((null?
p1180) r1181) ((eq? p1180 (quote any)) (cons (quote ()) r1181)) ((pair? p1180)
(match-empty1162 (car p1180) (match-empty1162 (cdr p1180) r1181))) ((eq? p1180
(quote each-any)) (cons (quote ()) r1181)) (else (let ((t1182 (vector-ref p1180
(quote 0)))) (if (memv t1182 (quote (each))) (match-empty1162 (vector-ref p1180
(quote 1)) r1181) (if (memv t1182 (quote (free-id atom))) r1181 (if (memv t1182
(quote (vector))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181)))))))))
(match-each-any1161 (lambda (e1183 w1184) (cond ((annotation?42 e1183)
(match-each-any1161 (annotation-expression e1183) w1184)) ((pair? e1183) (let
((l1185 (match-each-any1161 (cdr e1183) w1184))) (and l1185 (cons (wrap95 (car
e1183) w1184) l1185)))) ((null? e1183) (quote ())) ((syntax-object?53 e1183)
(match-each-any1161 (syntax-object-expression54 e1183) (join-wraps86 w1184
(syntax-object-wrap55 e1183)))) (else (quote #f))))) (match-each1160 (lambda
(e1186 p1187 w1188) (cond ((annotation?42 e1186) (match-each1160
(annotation-expression e1186) p1187 w1188)) ((pair? e1186) (let ((first1189
(match1164 (car e1186) p1187 w1188 (quote ())))) (and first1189 (let ((rest1190
(match-each1160 (cdr e1186) p1187 w1188))) (and rest1190 (cons first1189
rest1190)))))) ((null? e1186) (quote ())) ((syntax-object?53 e1186)
(match-each1160 (syntax-object-expression54 e1186) p1187 (join-wraps86 w1188
(syntax-object-wrap55 e1186)))) (else (quote #f)))))) (set! syntax-dispatch
(lambda (e1191 p1192) (cond ((eq? p1192 (quote any)) (list e1191))
((syntax-object?53 e1191) (match*1163 (let ((e1193 (syntax-object-expression54
e1191))) (if (annotation?42 e1193) (annotation-expression e1193) e1193)) p1192
(syntax-object-wrap55 e1191) (quote ()))) (else (match*1163 (let ((e1194
e1191)) (if (annotation?42 e1194) (annotation-expression e1194) e1194)) p1192
(quote (())) (quote ())))))))))
+(letrec ((lambda-var-list116 (lambda (vars323) (let lvl324 ((vars325 vars323)
(ls326 (quote ())) (w327 (quote (())))) (cond ((pair? vars325) (lvl324 (cdr
vars325) (cons (wrap95 (car vars325) w327) ls326) w327)) ((id?67 vars325) (cons
(wrap95 vars325 w327) ls326)) ((null? vars325) ls326) ((syntax-object?53
vars325) (lvl324 (syntax-object-expression54 vars325) ls326 (join-wraps86 w327
(syntax-object-wrap55 vars325)))) ((annotation?42 vars325) (lvl324
(annotation-expression vars325) ls326 w327)) (else (cons vars325 ls326))))))
(gen-var115 (lambda (id328) (let ((id329 (if (syntax-object?53 id328)
(syntax-object-expression54 id328) id328))) (if (annotation?42 id329) (gensym
(symbol->string (annotation-expression id329))) (gensym (symbol->string
id329)))))) (strip114 (lambda (x330 w331) (if (memq (quote top) (wrap-marks70
w331)) (if (or (annotation?42 x330) (and (pair? x330) (annotation?42 (car
x330)))) (strip-annotation113 x330 (quote #f)) x330) (let f332 ((x333 x330))
(cond ((syntax-object?53 x333) (strip114 (syntax-object-expression54 x333)
(syntax-object-wrap55 x333))) ((pair? x333) (let ((a334 (f332 (car x333)))
(d335 (f332 (cdr x333)))) (if (and (eq? a334 (car x333)) (eq? d335 (cdr x333)))
x333 (cons a334 d335)))) ((vector? x333) (let ((old336 (vector->list x333)))
(let ((new337 (map f332 old336))) (if (andmap eq? old336 new337) x333
(list->vector new337))))) (else x333)))))) (strip-annotation113 (lambda (x338
parent339) (cond ((pair? x338) (let ((new340 (cons (quote #f) (quote #f))))
(begin (when parent339 (set-annotation-stripped! parent339 new340)) (set-car!
new340 (strip-annotation113 (car x338) (quote #f))) (set-cdr! new340
(strip-annotation113 (cdr x338) (quote #f))) new340))) ((annotation?42 x338)
(or (annotation-stripped x338) (strip-annotation113 (annotation-expression
x338) x338))) ((vector? x338) (let ((new341 (make-vector (vector-length
x338)))) (begin (when parent339 (set-annotation-stripped! parent339 new341))
(let loop342 ((i343 (- (vector-length x338) (quote 1)))) (unless (fx<41 i343
(quote 0)) (vector-set! new341 i343 (strip-annotation113 (vector-ref x338 i343)
(quote #f))) (loop342 (fx-39 i343 (quote 1))))) new341))) (else x338))))
(ellipsis?112 (lambda (x344) (and (nonsymbol-id?66 x344) (free-id=?90 x344
(quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis?
chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body
chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))))))))) (chi-void111 (lambda () (list (quote
void)))) (eval-local-transformer110 (lambda (expanded345) (let ((p346
(local-eval-hook44 expanded345))) (if (procedure? p346) p346 (syntax-error p346
(quote "nonprocedure transfomer")))))) (chi-local-syntax109 (lambda (rec?347
e348 r349 w350 s351 k352) ((lambda (tmp353) ((lambda (tmp354) (if tmp354 (apply
(lambda (_355 id356 val357 e1358 e2359) (let ((ids360 id356)) (if (not
(valid-bound-ids?92 ids360)) (syntax-error e348 (quote "duplicate bound keyword
in")) (let ((labels362 (gen-labels73 ids360))) (let ((new-w363
(make-binding-wrap84 ids360 labels362 w350))) (k352 (cons e1358 e2359)
(extend-env61 labels362 (let ((w365 (if rec?347 new-w363 w350)) (trans-r366
(macros-only-env63 r349))) (map (lambda (x367) (cons (quote macro)
(eval-local-transformer110 (chi103 x367 trans-r366 w365)))) val357)) r349)
new-w363 s351)))))) tmp354) ((lambda (_369) (syntax-error (source-wrap96 e348
w350 s351))) tmp353))) (syntax-dispatch tmp353 (quote (any #(each (any any))
any . each-any))))) e348))) (chi-lambda-clause108 (lambda (e370 c371 r372 w373
k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (id377
e1378 e2379) (let ((ids380 id377)) (if (not (valid-bound-ids?92 ids380))
(syntax-error e370 (quote "invalid parameter list in")) (let ((labels382
(gen-labels73 ids380)) (new-vars383 (map gen-var115 ids380))) (k374 new-vars383
(chi-body107 (cons e1378 e2379) e370 (extend-var-env62 labels382 new-vars383
r372) (make-binding-wrap84 ids380 labels382 w373))))))) tmp376) ((lambda
(tmp385) (if tmp385 (apply (lambda (ids386 e1387 e2388) (let ((old-ids389
(lambda-var-list116 ids386))) (if (not (valid-bound-ids?92 old-ids389))
(syntax-error e370 (quote "invalid parameter list in")) (let ((labels390
(gen-labels73 old-ids389)) (new-vars391 (map gen-var115 old-ids389))) (k374
(let f392 ((ls1393 (cdr new-vars391)) (ls2394 (car new-vars391))) (if (null?
ls1393) ls2394 (f392 (cdr ls1393) (cons (car ls1393) ls2394)))) (chi-body107
(cons e1387 e2388) e370 (extend-var-env62 labels390 new-vars391 r372)
(make-binding-wrap84 old-ids389 labels390 w373))))))) tmp385) ((lambda (_396)
(syntax-error e370)) tmp375))) (syntax-dispatch tmp375 (quote (any any .
each-any)))))) (syntax-dispatch tmp375 (quote (each-any any . each-any)))))
c371))) (chi-body107 (lambda (body397 outer-form398 r399 w400) (let ((r401
(cons (quote ("placeholder" placeholder)) r399))) (let ((ribcage402
(make-ribcage74 (quote ()) (quote ()) (quote ())))) (let ((w403 (make-wrap69
(wrap-marks70 w400) (cons ribcage402 (wrap-subst71 w400))))) (let parse404
((body405 (map (lambda (x411) (cons r401 (wrap95 x411 w403))) body397)) (ids406
(quote ())) (labels407 (quote ())) (vars408 (quote ())) (vals409 (quote ()))
(bindings410 (quote ()))) (if (null? body405) (syntax-error outer-form398
(quote "no expressions in body")) (let ((e412 (cdar body405)) (er413 (caar
body405))) (call-with-values (lambda () (syntax-type101 e412 er413 (quote (()))
(quote #f) ribcage402)) (lambda (type414 value415 e416 w417 s418) (let ((t419
type414)) (if (memv t419 (quote (define-form))) (let ((id420 (wrap95 value415
w417)) (label421 (gen-label72))) (let ((var422 (gen-var115 id420))) (begin
(extend-ribcage!83 ribcage402 id420 label421) (parse404 (cdr body405) (cons
id420 ids406) (cons label421 labels407) (cons var422 vars408) (cons (cons er413
(wrap95 e416 w417)) vals409) (cons (cons (quote lexical) var422)
bindings410))))) (if (memv t419 (quote (define-syntax-form))) (let ((id423
(wrap95 value415 w417)) (label424 (gen-label72))) (begin (extend-ribcage!83
ribcage402 id423 label424) (parse404 (cdr body405) (cons id423 ids406) (cons
label424 labels407) vars408 vals409 (cons (cons (quote macro) (cons er413
(wrap95 e416 w417))) bindings410)))) (if (memv t419 (quote (begin-form)))
((lambda (tmp425) ((lambda (tmp426) (if tmp426 (apply (lambda (_427 e1428)
(parse404 (let f429 ((forms430 e1428)) (if (null? forms430) (cdr body405) (cons
(cons er413 (wrap95 (car forms430) w417)) (f429 (cdr forms430))))) ids406
labels407 vars408 vals409 bindings410)) tmp426) (syntax-error tmp425)))
(syntax-dispatch tmp425 (quote (any . each-any))))) e416) (if (memv t419 (quote
(local-syntax-form))) (chi-local-syntax109 value415 e416 er413 w417 s418
(lambda (forms432 er433 w434 s435) (parse404 (let f436 ((forms437 forms432))
(if (null? forms437) (cdr body405) (cons (cons er433 (wrap95 (car forms437)
w434)) (f436 (cdr forms437))))) ids406 labels407 vars408 vals409 bindings410)))
(if (null? ids406) (build-sequence48 (quote #f) (map (lambda (x438) (chi103
(cdr x438) (car x438) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417
s418)) (cdr body405)))) (begin (if (not (valid-bound-ids?92 ids406))
(syntax-error outer-form398 (quote "invalid or duplicate identifier in
definition"))) (let loop439 ((bs440 bindings410) (er-cache441 (quote #f))
(r-cache442 (quote #f))) (if (not (null? bs440)) (let ((b443 (car bs440))) (if
(eq? (car b443) (quote macro)) (let ((er444 (cadr b443))) (let ((r-cache445 (if
(eq? er444 er-cache441) r-cache442 (macros-only-env63 er444)))) (begin
(set-cdr! b443 (eval-local-transformer110 (chi103 (cddr b443) r-cache445 (quote
(()))))) (loop439 (cdr bs440) er444 r-cache445)))) (loop439 (cdr bs440)
er-cache441 r-cache442))))) (set-cdr! r401 (extend-env61 labels407 bindings410
(cdr r401))) (build-letrec51 (quote #f) vars408 (map (lambda (x446) (chi103
(cdr x446) (car x446) (quote (())))) vals409) (build-sequence48 (quote #f) (map
(lambda (x447) (chi103 (cdr x447) (car x447) (quote (())))) (cons (cons er413
(source-wrap96 e416 w417 s418)) (cdr body405))))))))))))))))))))))
(chi-macro106 (lambda (p448 e449 r450 w451 rib452) (letrec
((rebuild-macro-output453 (lambda (x454 m455) (cond ((pair? x454) (cons
(rebuild-macro-output453 (car x454) m455) (rebuild-macro-output453 (cdr x454)
m455))) ((syntax-object?53 x454) (let ((w456 (syntax-object-wrap55 x454))) (let
((ms457 (wrap-marks70 w456)) (s458 (wrap-subst71 w456))) (make-syntax-object52
(syntax-object-expression54 x454) (if (and (pair? ms457) (eq? (car ms457)
(quote #f))) (make-wrap69 (cdr ms457) (if rib452 (cons rib452 (cdr s458)) (cdr
s458))) (make-wrap69 (cons m455 ms457) (if rib452 (cons rib452 (cons (quote
shift) s458)) (cons (quote shift) s458)))))))) ((vector? x454) (let ((n459
(vector-length x454))) (let ((v460 (make-vector n459))) (let doloop461 ((i462
(quote 0))) (if (fx=40 i462 n459) v460 (begin (vector-set! v460 i462
(rebuild-macro-output453 (vector-ref x454 i462) m455)) (doloop461 (fx+38 i462
(quote 1))))))))) ((symbol? x454) (syntax-error x454 (quote "encountered raw
symbol in macro output"))) (else x454))))) (rebuild-macro-output453 (p448
(wrap95 e449 (anti-mark82 w451))) (string (quote #\m)))))) (chi-application105
(lambda (x463 e464 r465 w466 s467) ((lambda (tmp468) ((lambda (tmp469) (if
tmp469 (apply (lambda (e0470 e1471) (cons x463 (map (lambda (e472) (chi103 e472
r465 w466)) e1471))) tmp469) (syntax-error tmp468))) (syntax-dispatch tmp468
(quote (any . each-any))))) e464))) (chi-expr104 (lambda (type474 value475 e476
r477 w478 s479) (let ((t480 type474)) (if (memv t480 (quote (lexical)))
value475 (if (memv t480 (quote (core))) (value475 e476 r477 w478 s479) (if
(memv t480 (quote (lexical-call))) (chi-application105 value475 e476 r477 w478
s479) (if (memv t480 (quote (global-call))) (chi-application105 value475 e476
r477 w478 s479) (if (memv t480 (quote (constant))) (list (quote quote)
(strip114 (source-wrap96 e476 w478 s479) (quote (())))) (if (memv t480 (quote
(global))) value475 (if (memv t480 (quote (call))) (chi-application105 (chi103
(car e476) r477 w478) e476 r477 w478 s479) (if (memv t480 (quote (begin-form)))
((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 e1484
e2485) (chi-sequence97 (cons e1484 e2485) r477 w478 s479)) tmp482)
(syntax-error tmp481))) (syntax-dispatch tmp481 (quote (any any . each-any)))))
e476) (if (memv t480 (quote (local-syntax-form))) (chi-local-syntax109 value475
e476 r477 w478 s479 chi-sequence97) (if (memv t480 (quote (eval-when-form)))
((lambda (tmp487) ((lambda (tmp488) (if tmp488 (apply (lambda (_489 x490 e1491
e2492) (let ((when-list493 (chi-when-list100 e476 x490 w478))) (if (memq (quote
eval) when-list493) (chi-sequence97 (cons e1491 e2492) r477 w478 s479)
(chi-void111)))) tmp488) (syntax-error tmp487))) (syntax-dispatch tmp487 (quote
(any each-any any . each-any))))) e476) (if (memv t480 (quote (define-form
define-syntax-form))) (syntax-error (wrap95 value475 w478) (quote "invalid
context for definition of")) (if (memv t480 (quote (syntax))) (syntax-error
(source-wrap96 e476 w478 s479) (quote "reference to pattern variable outside
syntax form")) (if (memv t480 (quote (displaced-lexical))) (syntax-error
(source-wrap96 e476 w478 s479) (quote "reference to identifier outside its
scope")) (syntax-error (source-wrap96 e476 w478 s479)))))))))))))))))) (chi103
(lambda (e496 r497 w498) (call-with-values (lambda () (syntax-type101 e496 r497
w498 (quote #f) (quote #f))) (lambda (type499 value500 e501 w502 s503)
(chi-expr104 type499 value500 e501 r497 w502 s503))))) (chi-top102 (lambda
(e504 r505 w506 m507 esew508) (call-with-values (lambda () (syntax-type101 e504
r505 w506 (quote #f) (quote #f))) (lambda (type515 value516 e517 w518 s519)
(let ((t520 type515)) (if (memv t520 (quote (begin-form))) ((lambda (tmp521)
((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void111)) tmp522)
((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527)
(chi-top-sequence98 (cons e1526 e2527) r505 w518 s519 m507 esew508)) tmp524)
(syntax-error tmp521))) (syntax-dispatch tmp521 (quote (any any .
each-any)))))) (syntax-dispatch tmp521 (quote (any))))) e517) (if (memv t520
(quote (local-syntax-form))) (chi-local-syntax109 value516 e517 r505 w518 s519
(lambda (body529 r530 w531 s532) (chi-top-sequence98 body529 r530 w531 s532
m507 esew508))) (if (memv t520 (quote (eval-when-form))) ((lambda (tmp533)
((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let
((when-list539 (chi-when-list100 e517 x536 w518)) (body540 (cons e1537 e2538)))
(cond ((eq? m507 (quote e)) (if (memq (quote eval) when-list539)
(chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval)))
(chi-void111))) ((memq (quote load) when-list539) (if (or (memq (quote compile)
when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539)))
(chi-top-sequence98 body540 r505 w518 s519 (quote c&e) (quote (compile load)))
(if (memq m507 (quote (c c&e))) (chi-top-sequence98 body540 r505 w518 s519
(quote c) (quote (load))) (chi-void111)))) ((or (memq (quote compile)
when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539)))
(top-level-eval-hook43 (chi-top-sequence98 body540 r505 w518 s519 (quote e)
(quote (eval)))) (chi-void111)) (else (chi-void111))))) tmp534) (syntax-error
tmp533))) (syntax-dispatch tmp533 (quote (any each-any any . each-any)))))
e517) (if (memv t520 (quote (define-syntax-form))) (let ((n543 (id-var-name89
value516 w518)) (r544 (macros-only-env63 r505))) (let ((t545 m507)) (if (memv
t545 (quote (c))) (if (memq (quote compile) esew508) (let ((e546
(chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin
(top-level-eval-hook43 e546) (if (memq (quote load) esew508) e546
(chi-void111)))) (if (memq (quote load) esew508) (chi-install-global99 n543
(chi103 e517 r544 w518)) (chi-void111))) (if (memv t545 (quote (c&e))) (let
((e547 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin
(top-level-eval-hook43 e547) e547)) (begin (if (memq (quote eval) esew508)
(top-level-eval-hook43 (chi-install-global99 n543 (chi103 e517 r544 w518))))
(chi-void111)))))) (if (memv t520 (quote (define-form))) (let ((n548
(id-var-name89 value516 w518))) (let ((t549 (binding-type59 (lookup64 n548
r505)))) (if (memv t549 (quote (global))) (let ((x550 (list (quote define) n548
(chi103 e517 r505 w518)))) (begin (if (eq? m507 (quote c&e))
(top-level-eval-hook43 x550)) x550)) (if (memv t549 (quote
(displaced-lexical))) (syntax-error (wrap95 value516 w518) (quote "identifier
out of context")) (syntax-error (wrap95 value516 w518) (quote "cannot define
keyword at top level")))))) (let ((x551 (chi-expr104 type515 value516 e517 r505
w518 s519))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x551))
x551)))))))))))) (syntax-type101 (lambda (e552 r553 w554 s555 rib556) (cond
((symbol? e552) (let ((n557 (id-var-name89 e552 w554))) (let ((b558 (lookup64
n557 r553))) (let ((type559 (binding-type59 b558))) (let ((t560 type559)) (if
(memv t560 (quote (lexical))) (values type559 (binding-value60 b558) e552 w554
s555) (if (memv t560 (quote (global))) (values type559 n557 e552 w554 s555) (if
(memv t560 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60
b558) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (values type559
(binding-value60 b558) e552 w554 s555))))))))) ((pair? e552) (let ((first561
(car e552))) (if (id?67 first561) (let ((n562 (id-var-name89 first561 w554)))
(let ((b563 (lookup64 n562 r553))) (let ((type564 (binding-type59 b563))) (let
((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call)
(binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (global))) (values
(quote global-call) n562 e552 w554 s555) (if (memv t565 (quote (macro)))
(syntax-type101 (chi-macro106 (binding-value60 b563) e552 r553 w554 rib556)
r553 (quote (())) s555 rib556) (if (memv t565 (quote (core))) (values type564
(binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (local-syntax)))
(values (quote local-syntax-form) (binding-value60 b563) e552 w554 s555) (if
(memv t565 (quote (begin))) (values (quote begin-form) (quote #f) e552 w554
s555) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) (quote
#f) e552 w554 s555) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda
(tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?67 name569))
tmp567) (quote #f)) (apply (lambda (_571 name572 val573) (values (quote
define-form) name572 val573 w554 s555)) tmp567) ((lambda (tmp574) (if (if
tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?67 name576)
(valid-bound-ids?92 (lambda-var-list116 args577)))) tmp574) (quote #f)) (apply
(lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap95
name581 w554) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name
args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage ()
() ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis?
chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body
chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))))) (wrap95 (cons args582 (cons e1583 e2584))
w554)) (quote (())) s555)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply
(lambda (_587 name588) (id?67 name588)) tmp586) (quote #f)) (apply (lambda
(_589 name590) (values (quote define-form) (wrap95 name590 w554) (quote
(#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i"))
#(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip
strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source unannotate
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap
syntax-object-expression syntax-object? make-syntax-object self-evaluating?
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand)
((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s555))
tmp586) (syntax-error tmp566))) (syntax-dispatch tmp566 (quote (any any))))))
(syntax-dispatch tmp566 (quote (any (any . any) any . each-any))))))
(syntax-dispatch tmp566 (quote (any any any))))) e552) (if (memv t565 (quote
(define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply
(lambda (_593 name594 val595) (id?67 name594)) tmp592) (quote #f)) (apply
(lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598
w554 s555)) tmp592) (syntax-error tmp591))) (syntax-dispatch tmp591 (quote (any
any any))))) e552) (values (quote call) (quote #f) e552 w554 s555))))))))))))))
(values (quote call) (quote #f) e552 w554 s555)))) ((syntax-object?53 e552)
(syntax-type101 (syntax-object-expression54 e552) r553 (join-wraps86 w554
(syntax-object-wrap55 e552)) (quote #f) rib556)) ((annotation?42 e552)
(syntax-type101 (annotation-expression e552) r553 w554 (annotation-source e552)
rib556)) ((let ((x599 e552)) (or (boolean? x599) (number? x599) (string? x599)
(char? x599) (null? x599) (keyword? x599))) (values (quote constant) (quote #f)
e552 w554 s555)) (else (values (quote other) (quote #f) e552 w554 s555)))))
(chi-when-list100 (lambda (e600 when-list601 w602) (let f603 ((when-list604
when-list601) (situations605 (quote ()))) (if (null? when-list604)
situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604)))
(cond ((free-id=?90 x606 (quote #(syntax-object compile ((top) #(ribcage () ()
()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list
situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=?90 x606
(quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top)
(top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip
strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source unannotate
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap
syntax-object-expression syntax-object? make-syntax-object self-evaluating?
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand)
((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load))
((free-id=?90 x606 (quote #(syntax-object eval ((top) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list
situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap95
x606 w602) (quote "invalid eval-when situation"))))) situations605))))))
(chi-install-global99 (lambda (name607 e608) (list (quote
install-global-transformer) (list (quote quote) name607) e608)))
(chi-top-sequence98 (lambda (body609 r610 w611 s612 m613 esew614)
(build-sequence48 s612 (let dobody615 ((body616 body609) (r617 r610) (w618
w611) (m619 m613) (esew620 esew614)) (if (null? body616) (quote ()) (let
((first621 (chi-top102 (car body616) r617 w618 m619 esew620))) (cons first621
(dobody615 (cdr body616) r617 w618 m619 esew620)))))))) (chi-sequence97 (lambda
(body622 r623 w624 s625) (build-sequence48 s625 (let dobody626 ((body627
body622) (r628 r623) (w629 w624)) (if (null? body627) (quote ()) (let
((first630 (chi103 (car body627) r628 w629))) (cons first630 (dobody626 (cdr
body627) r628 w629)))))))) (source-wrap96 (lambda (x631 w632 s633) (wrap95 (if
s633 (make-annotation x631 s633 (quote #f)) x631) w632))) (wrap95 (lambda (x634
w635) (cond ((and (null? (wrap-marks70 w635)) (null? (wrap-subst71 w635)))
x634) ((syntax-object?53 x634) (make-syntax-object52
(syntax-object-expression54 x634) (join-wraps86 w635 (syntax-object-wrap55
x634)))) ((null? x634) x634) (else (make-syntax-object52 x634 w635)))))
(bound-id-member?94 (lambda (x636 list637) (and (not (null? list637)) (or
(bound-id=?91 x636 (car list637)) (bound-id-member?94 x636 (cdr list637))))))
(distinct-bound-ids?93 (lambda (ids638) (let distinct?639 ((ids640 ids638)) (or
(null? ids640) (and (not (bound-id-member?94 (car ids640) (cdr ids640)))
(distinct?639 (cdr ids640))))))) (valid-bound-ids?92 (lambda (ids641) (and (let
all-ids?642 ((ids643 ids641)) (or (null? ids643) (and (id?67 (car ids643))
(all-ids?642 (cdr ids643))))) (distinct-bound-ids?93 ids641)))) (bound-id=?91
(lambda (i644 j645) (if (and (syntax-object?53 i644) (syntax-object?53 j645))
(and (eq? (let ((e646 (syntax-object-expression54 i644))) (if (annotation?42
e646) (annotation-expression e646) e646)) (let ((e647
(syntax-object-expression54 j645))) (if (annotation?42 e647)
(annotation-expression e647) e647))) (same-marks?88 (wrap-marks70
(syntax-object-wrap55 i644)) (wrap-marks70 (syntax-object-wrap55 j645)))) (eq?
(let ((e648 i644)) (if (annotation?42 e648) (annotation-expression e648) e648))
(let ((e649 j645)) (if (annotation?42 e649) (annotation-expression e649)
e649)))))) (free-id=?90 (lambda (i650 j651) (and (eq? (let ((x652 i650)) (let
((e653 (if (syntax-object?53 x652) (syntax-object-expression54 x652) x652)))
(if (annotation?42 e653) (annotation-expression e653) e653))) (let ((x654
j651)) (let ((e655 (if (syntax-object?53 x654) (syntax-object-expression54
x654) x654))) (if (annotation?42 e655) (annotation-expression e655) e655))))
(eq? (id-var-name89 i650 (quote (()))) (id-var-name89 j651 (quote (())))))))
(id-var-name89 (lambda (id656 w657) (letrec ((search-vector-rib660 (lambda
(sym666 subst667 marks668 symnames669 ribcage670) (let ((n671 (vector-length
symnames669))) (let f672 ((i673 (quote 0))) (cond ((fx=40 i673 n671) (search658
sym666 (cdr subst667) marks668)) ((and (eq? (vector-ref symnames669 i673)
sym666) (same-marks?88 marks668 (vector-ref (ribcage-marks77 ribcage670)
i673))) (values (vector-ref (ribcage-labels78 ribcage670) i673) marks668))
(else (f672 (fx+38 i673 (quote 1))))))))) (search-list-rib659 (lambda (sym674
subst675 marks676 symnames677 ribcage678) (let f679 ((symnames680 symnames677)
(i681 (quote 0))) (cond ((null? symnames680) (search658 sym674 (cdr subst675)
marks676)) ((and (eq? (car symnames680) sym674) (same-marks?88 marks676
(list-ref (ribcage-marks77 ribcage678) i681))) (values (list-ref
(ribcage-labels78 ribcage678) i681) marks676)) (else (f679 (cdr symnames680)
(fx+38 i681 (quote 1)))))))) (search658 (lambda (sym682 subst683 marks684) (if
(null? subst683) (values (quote #f) marks684) (let ((fst685 (car subst683)))
(if (eq? fst685 (quote shift)) (search658 sym682 (cdr subst683) (cdr marks684))
(let ((symnames686 (ribcage-symnames76 fst685))) (if (vector? symnames686)
(search-vector-rib660 sym682 subst683 marks684 symnames686 fst685)
(search-list-rib659 sym682 subst683 marks684 symnames686 fst685))))))))) (cond
((symbol? id656) (or (call-with-values (lambda () (search658 id656
(wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x688 . ignore687) x688))
id656)) ((syntax-object?53 id656) (let ((id689 (let ((e691
(syntax-object-expression54 id656))) (if (annotation?42 e691)
(annotation-expression e691) e691))) (w1690 (syntax-object-wrap55 id656))) (let
((marks692 (join-marks87 (wrap-marks70 w657) (wrap-marks70 w1690))))
(call-with-values (lambda () (search658 id689 (wrap-subst71 w657) marks692))
(lambda (new-id693 marks694) (or new-id693 (call-with-values (lambda ()
(search658 id689 (wrap-subst71 w1690) marks694)) (lambda (x696 . ignore695)
x696)) id689)))))) ((annotation?42 id656) (let ((id697 (let ((e698 id656)) (if
(annotation?42 e698) (annotation-expression e698) e698)))) (or
(call-with-values (lambda () (search658 id697 (wrap-subst71 w657) (wrap-marks70
w657))) (lambda (x700 . ignore699) x700)) id697))) (else (error-hook45 (quote
id-var-name) (quote "invalid id") id656)))))) (same-marks?88 (lambda (x701
y702) (or (eq? x701 y702) (and (not (null? x701)) (not (null? y702)) (eq? (car
x701) (car y702)) (same-marks?88 (cdr x701) (cdr y702)))))) (join-marks87
(lambda (m1703 m2704) (smart-append85 m1703 m2704))) (join-wraps86 (lambda
(w1705 w2706) (let ((m1707 (wrap-marks70 w1705)) (s1708 (wrap-subst71 w1705)))
(if (null? m1707) (if (null? s1708) w2706 (make-wrap69 (wrap-marks70 w2706)
(smart-append85 s1708 (wrap-subst71 w2706)))) (make-wrap69 (smart-append85
m1707 (wrap-marks70 w2706)) (smart-append85 s1708 (wrap-subst71 w2706)))))))
(smart-append85 (lambda (m1709 m2710) (if (null? m2710) m1709 (append m1709
m2710)))) (make-binding-wrap84 (lambda (ids711 labels712 w713) (if (null?
ids711) w713 (make-wrap69 (wrap-marks70 w713) (cons (let ((labelvec714
(list->vector labels712))) (let ((n715 (vector-length labelvec714))) (let
((symnamevec716 (make-vector n715)) (marksvec717 (make-vector n715))) (begin
(let f718 ((ids719 ids711) (i720 (quote 0))) (if (not (null? ids719))
(call-with-values (lambda () (id-sym-name&marks68 (car ids719) w713)) (lambda
(symname721 marks722) (begin (vector-set! symnamevec716 i720 symname721)
(vector-set! marksvec717 i720 marks722) (f718 (cdr ids719) (fx+38 i720 (quote
1)))))))) (make-ribcage74 symnamevec716 marksvec717 labelvec714)))))
(wrap-subst71 w713)))))) (extend-ribcage!83 (lambda (ribcage723 id724 label725)
(begin (set-ribcage-symnames!79 ribcage723 (cons (let ((e726
(syntax-object-expression54 id724))) (if (annotation?42 e726)
(annotation-expression e726) e726)) (ribcage-symnames76 ribcage723)))
(set-ribcage-marks!80 ribcage723 (cons (wrap-marks70 (syntax-object-wrap55
id724)) (ribcage-marks77 ribcage723))) (set-ribcage-labels!81 ribcage723 (cons
label725 (ribcage-labels78 ribcage723)))))) (anti-mark82 (lambda (w727)
(make-wrap69 (cons (quote #f) (wrap-marks70 w727)) (cons (quote shift)
(wrap-subst71 w727))))) (set-ribcage-labels!81 (lambda (x728 update729)
(vector-set! x728 (quote 3) update729))) (set-ribcage-marks!80 (lambda (x730
update731) (vector-set! x730 (quote 2) update731))) (set-ribcage-symnames!79
(lambda (x732 update733) (vector-set! x732 (quote 1) update733)))
(ribcage-labels78 (lambda (x734) (vector-ref x734 (quote 3)))) (ribcage-marks77
(lambda (x735) (vector-ref x735 (quote 2)))) (ribcage-symnames76 (lambda (x736)
(vector-ref x736 (quote 1)))) (ribcage?75 (lambda (x737) (and (vector? x737) (=
(vector-length x737) (quote 4)) (eq? (vector-ref x737 (quote 0)) (quote
ribcage))))) (make-ribcage74 (lambda (symnames738 marks739 labels740) (vector
(quote ribcage) symnames738 marks739 labels740))) (gen-labels73 (lambda (ls741)
(if (null? ls741) (quote ()) (cons (gen-label72) (gen-labels73 (cdr ls741))))))
(gen-label72 (lambda () (string (quote #\i)))) (wrap-subst71 cdr) (wrap-marks70
car) (make-wrap69 cons) (id-sym-name&marks68 (lambda (x742 w743) (if
(syntax-object?53 x742) (values (let ((e744 (syntax-object-expression54 x742)))
(if (annotation?42 e744) (annotation-expression e744) e744)) (join-marks87
(wrap-marks70 w743) (wrap-marks70 (syntax-object-wrap55 x742)))) (values (let
((e745 x742)) (if (annotation?42 e745) (annotation-expression e745) e745))
(wrap-marks70 w743))))) (id?67 (lambda (x746) (cond ((symbol? x746) (quote #t))
((syntax-object?53 x746) (symbol? (let ((e747 (syntax-object-expression54
x746))) (if (annotation?42 e747) (annotation-expression e747) e747))))
((annotation?42 x746) (symbol? (annotation-expression x746))) (else (quote
#f))))) (nonsymbol-id?66 (lambda (x748) (and (syntax-object?53 x748) (symbol?
(let ((e749 (syntax-object-expression54 x748))) (if (annotation?42 e749)
(annotation-expression e749) e749)))))) (global-extend65 (lambda (type750
sym751 val752) (put-global-definition-hook46 sym751 (cons type750 val752))))
(lookup64 (lambda (x753 r754) (cond ((assq x753 r754) => cdr) ((symbol? x753)
(or (get-global-definition-hook47 x753) (quote (global)))) (else (quote
(displaced-lexical)))))) (macros-only-env63 (lambda (r755) (if (null? r755)
(quote ()) (let ((a756 (car r755))) (if (eq? (cadr a756) (quote macro)) (cons
a756 (macros-only-env63 (cdr r755))) (macros-only-env63 (cdr r755)))))))
(extend-var-env62 (lambda (labels757 vars758 r759) (if (null? labels757) r759
(extend-var-env62 (cdr labels757) (cdr vars758) (cons (cons (car labels757)
(cons (quote lexical) (car vars758))) r759))))) (extend-env61 (lambda
(labels760 bindings761 r762) (if (null? labels760) r762 (extend-env61 (cdr
labels760) (cdr bindings761) (cons (cons (car labels760) (car bindings761))
r762))))) (binding-value60 cdr) (binding-type59 car) (source-annotation58
(lambda (x763) (cond ((annotation?42 x763) (annotation-source x763))
((syntax-object?53 x763) (source-annotation58 (syntax-object-expression54
x763))) (else (quote #f))))) (set-syntax-object-wrap!57 (lambda (x764
update765) (vector-set! x764 (quote 2) update765)))
(set-syntax-object-expression!56 (lambda (x766 update767) (vector-set! x766
(quote 1) update767))) (syntax-object-wrap55 (lambda (x768) (vector-ref x768
(quote 2)))) (syntax-object-expression54 (lambda (x769) (vector-ref x769 (quote
1)))) (syntax-object?53 (lambda (x770) (and (vector? x770) (= (vector-length
x770) (quote 3)) (eq? (vector-ref x770 (quote 0)) (quote syntax-object)))))
(make-syntax-object52 (lambda (expression771 wrap772) (vector (quote
syntax-object) expression771 wrap772))) (build-letrec51 (lambda (src773 vars774
val-exps775 body-exp776) (if (null? vars774) body-exp776 (list (quote letrec)
(map list vars774 val-exps775) body-exp776)))) (build-named-let50 (lambda
(src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list
(quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780))))
(build-let49 (lambda (src781 vars782 val-exps783 body-exp784) (if (null?
vars782) body-exp784 (list (quote let) (map list vars782 val-exps783)
body-exp784)))) (build-sequence48 (lambda (src785 exps786) (if (null? (cdr
exps786)) (car exps786) (cons (quote begin) exps786))))
(get-global-definition-hook47 (lambda (symbol787) (getprop symbol787 (quote
*sc-expander*)))) (put-global-definition-hook46 (lambda (symbol788 binding789)
(putprop symbol788 (quote *sc-expander*) binding789))) (error-hook45 (lambda
(who790 why791 what792) (error who790 (quote "~a ~s") why791 what792)))
(local-eval-hook44 (lambda (x793) (eval (list noexpand37 x793)
(interaction-environment)))) (top-level-eval-hook43 (lambda (x794) (eval (list
noexpand37 x794) (interaction-environment)))) (annotation?42 (lambda (x795)
(quote #f))) (fx<41 <) (fx=40 =) (fx-39 -) (fx+38 +) (noexpand37 (quote
"noexpand"))) (begin (global-extend65 (quote local-syntax) (quote
letrec-syntax) (quote #t)) (global-extend65 (quote local-syntax) (quote
let-syntax) (quote #f)) (global-extend65 (quote core) (quote fluid-let-syntax)
(lambda (e796 r797 w798 s799) ((lambda (tmp800) ((lambda (tmp801) (if (if
tmp801 (apply (lambda (_802 var803 val804 e1805 e2806) (valid-bound-ids?92
var803)) tmp801) (quote #f)) (apply (lambda (_808 var809 val810 e1811 e2812)
(let ((names813 (map (lambda (x814) (id-var-name89 x814 w798)) var809))) (begin
(for-each (lambda (id816 n817) (let ((t818 (binding-type59 (lookup64 n817
r797)))) (if (memv t818 (quote (displaced-lexical))) (syntax-error
(source-wrap96 id816 w798 s799) (quote "identifier out of context"))))) var809
names813) (chi-body107 (cons e1811 e2812) (source-wrap96 e796 w798 s799)
(extend-env61 names813 (let ((trans-r821 (macros-only-env63 r797))) (map
(lambda (x822) (cons (quote macro) (eval-local-transformer110 (chi103 x822
trans-r821 w798)))) val810)) r797) w798)))) tmp801) ((lambda (_824)
(syntax-error (source-wrap96 e796 w798 s799))) tmp800))) (syntax-dispatch
tmp800 (quote (any #(each (any any)) any . each-any))))) e796)))
(global-extend65 (quote core) (quote quote) (lambda (e825 r826 w827 s828)
((lambda (tmp829) ((lambda (tmp830) (if tmp830 (apply (lambda (_831 e832) (list
(quote quote) (strip114 e832 w827))) tmp830) ((lambda (_833) (syntax-error
(source-wrap96 e825 w827 s828))) tmp829))) (syntax-dispatch tmp829 (quote (any
any))))) e825))) (global-extend65 (quote core) (quote syntax) (letrec
((regen841 (lambda (x842) (let ((t843 (car x842))) (if (memv t843 (quote
(ref))) (cadr x842) (if (memv t843 (quote (primitive))) (cadr x842) (if (memv
t843 (quote (quote))) (list (quote quote) (cadr x842)) (if (memv t843 (quote
(lambda))) (list (quote lambda) (cadr x842) (regen841 (caddr x842))) (if (memv
t843 (quote (map))) (let ((ls844 (map regen841 (cdr x842)))) (cons (if (fx=40
(length ls844) (quote 2)) (quote map) (quote map)) ls844)) (cons (car x842)
(map regen841 (cdr x842))))))))))) (gen-vector840 (lambda (x845) (cond ((eq?
(car x845) (quote list)) (cons (quote vector) (cdr x845))) ((eq? (car x845)
(quote quote)) (list (quote quote) (list->vector (cadr x845)))) (else (list
(quote list->vector) x845))))) (gen-append839 (lambda (x846 y847) (if (equal?
y847 (quote (quote ()))) x846 (list (quote append) x846 y847)))) (gen-cons838
(lambda (x848 y849) (let ((t850 (car y849))) (if (memv t850 (quote (quote)))
(if (eq? (car x848) (quote quote)) (list (quote quote) (cons (cadr x848) (cadr
y849))) (if (eq? (cadr y849) (quote ())) (list (quote list) x848) (list (quote
cons) x848 y849))) (if (memv t850 (quote (list))) (cons (quote list) (cons x848
(cdr y849))) (list (quote cons) x848 y849)))))) (gen-map837 (lambda (e851
map-env852) (let ((formals853 (map cdr map-env852)) (actuals854 (map (lambda
(x855) (list (quote ref) (car x855))) map-env852))) (cond ((eq? (car e851)
(quote ref)) (car actuals854)) ((andmap (lambda (x856) (and (eq? (car x856)
(quote ref)) (memq (cadr x856) formals853))) (cdr e851)) (cons (quote map)
(cons (list (quote primitive) (car e851)) (map (let ((r857 (map cons formals853
actuals854))) (lambda (x858) (cdr (assq (cadr x858) r857)))) (cdr e851)))))
(else (cons (quote map) (cons (list (quote lambda) formals853 e851)
actuals854))))))) (gen-mappend836 (lambda (e859 map-env860) (list (quote apply)
(quote (primitive append)) (gen-map837 e859 map-env860)))) (gen-ref835 (lambda
(src861 var862 level863 maps864) (if (fx=40 level863 (quote 0)) (values var862
maps864) (if (null? maps864) (syntax-error src861 (quote "missing ellipsis in
syntax form")) (call-with-values (lambda () (gen-ref835 src861 var862 (fx-39
level863 (quote 1)) (cdr maps864))) (lambda (outer-var865 outer-maps866) (let
((b867 (assq outer-var865 (car maps864)))) (if b867 (values (cdr b867) maps864)
(let ((inner-var868 (gen-var115 (quote tmp)))) (values inner-var868 (cons (cons
(cons outer-var865 inner-var868) (car maps864)) outer-maps866)))))))))))
(gen-syntax834 (lambda (src869 e870 r871 maps872 ellipsis?873) (if (id?67 e870)
(let ((label874 (id-var-name89 e870 (quote (()))))) (let ((b875 (lookup64
label874 r871))) (if (eq? (binding-type59 b875) (quote syntax))
(call-with-values (lambda () (let ((var.lev876 (binding-value60 b875)))
(gen-ref835 src869 (car var.lev876) (cdr var.lev876) maps872))) (lambda (var877
maps878) (values (list (quote ref) var877) maps878))) (if (ellipsis?873 e870)
(syntax-error src869 (quote "misplaced ellipsis in syntax form")) (values (list
(quote quote) e870) maps872))))) ((lambda (tmp879) ((lambda (tmp880) (if (if
tmp880 (apply (lambda (dots881 e882) (ellipsis?873 dots881)) tmp880) (quote
#f)) (apply (lambda (dots883 e884) (gen-syntax834 src869 e884 r871 maps872
(lambda (x885) (quote #f)))) tmp880) ((lambda (tmp886) (if (if tmp886 (apply
(lambda (x887 dots888 y889) (ellipsis?873 dots888)) tmp886) (quote #f)) (apply
(lambda (x890 dots891 y892) (let f893 ((y894 y892) (k895 (lambda (maps896)
(call-with-values (lambda () (gen-syntax834 src869 x890 r871 (cons (quote ())
maps896) ellipsis?873)) (lambda (x897 maps898) (if (null? (car maps898))
(syntax-error src869 (quote "extra ellipsis in syntax form")) (values
(gen-map837 x897 (car maps898)) (cdr maps898)))))))) ((lambda (tmp899) ((lambda
(tmp900) (if (if tmp900 (apply (lambda (dots901 y902) (ellipsis?873 dots901))
tmp900) (quote #f)) (apply (lambda (dots903 y904) (f893 y904 (lambda (maps905)
(call-with-values (lambda () (k895 (cons (quote ()) maps905))) (lambda (x906
maps907) (if (null? (car maps907)) (syntax-error src869 (quote "extra ellipsis
in syntax form")) (values (gen-mappend836 x906 (car maps907)) (cdr
maps907)))))))) tmp900) ((lambda (_908) (call-with-values (lambda ()
(gen-syntax834 src869 y894 r871 maps872 ellipsis?873)) (lambda (y909 maps910)
(call-with-values (lambda () (k895 maps910)) (lambda (x911 maps912) (values
(gen-append839 x911 y909) maps912)))))) tmp899))) (syntax-dispatch tmp899
(quote (any . any))))) y894))) tmp886) ((lambda (tmp913) (if tmp913 (apply
(lambda (x914 y915) (call-with-values (lambda () (gen-syntax834 src869 x914
r871 maps872 ellipsis?873)) (lambda (x916 maps917) (call-with-values (lambda ()
(gen-syntax834 src869 y915 r871 maps917 ellipsis?873)) (lambda (y918 maps919)
(values (gen-cons838 x916 y918) maps919)))))) tmp913) ((lambda (tmp920) (if
tmp920 (apply (lambda (e1921 e2922) (call-with-values (lambda () (gen-syntax834
src869 (cons e1921 e2922) r871 maps872 ellipsis?873)) (lambda (e924 maps925)
(values (gen-vector840 e924) maps925)))) tmp920) ((lambda (_926) (values (list
(quote quote) e870) maps872)) tmp879))) (syntax-dispatch tmp879 (quote #(vector
(any . each-any))))))) (syntax-dispatch tmp879 (quote (any . any))))))
(syntax-dispatch tmp879 (quote (any any . any)))))) (syntax-dispatch tmp879
(quote (any any))))) e870))))) (lambda (e927 r928 w929 s930) (let ((e931
(source-wrap96 e927 w929 s930))) ((lambda (tmp932) ((lambda (tmp933) (if tmp933
(apply (lambda (_934 x935) (call-with-values (lambda () (gen-syntax834 e931
x935 r928 (quote ()) ellipsis?112)) (lambda (e936 maps937) (regen841 e936))))
tmp933) ((lambda (_938) (syntax-error e931)) tmp932))) (syntax-dispatch tmp932
(quote (any any))))) e931))))) (global-extend65 (quote core) (quote lambda)
(lambda (e939 r940 w941 s942) ((lambda (tmp943) ((lambda (tmp944) (if tmp944
(apply (lambda (_945 c946) (chi-lambda-clause108 (source-wrap96 e939 w941 s942)
c946 r940 w941 (lambda (vars947 body948) (list (quote lambda) vars947
body948)))) tmp944) (syntax-error tmp943))) (syntax-dispatch tmp943 (quote (any
. any))))) e939))) (global-extend65 (quote core) (quote let) (letrec
((chi-let949 (lambda (e950 r951 w952 s953 constructor954 ids955 vals956
exps957) (if (not (valid-bound-ids?92 ids955)) (syntax-error e950 (quote
"duplicate bound variable in")) (let ((labels958 (gen-labels73 ids955))
(new-vars959 (map gen-var115 ids955))) (let ((nw960 (make-binding-wrap84 ids955
labels958 w952)) (nr961 (extend-var-env62 labels958 new-vars959 r951)))
(constructor954 s953 new-vars959 (map (lambda (x962) (chi103 x962 r951 w952))
vals956) (chi-body107 exps957 (source-wrap96 e950 nw960 s953) nr961
nw960)))))))) (lambda (e963 r964 w965 s966) ((lambda (tmp967) ((lambda (tmp968)
(if tmp968 (apply (lambda (_969 id970 val971 e1972 e2973) (chi-let949 e963 r964
w965 s966 build-let49 id970 val971 (cons e1972 e2973))) tmp968) ((lambda
(tmp977) (if (if tmp977 (apply (lambda (_978 f979 id980 val981 e1982 e2983)
(id?67 f979)) tmp977) (quote #f)) (apply (lambda (_984 f985 id986 val987 e1988
e2989) (chi-let949 e963 r964 w965 s966 build-named-let50 (cons f985 id986)
val987 (cons e1988 e2989))) tmp977) ((lambda (_993) (syntax-error
(source-wrap96 e963 w965 s966))) tmp967))) (syntax-dispatch tmp967 (quote (any
any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp967 (quote (any
#(each (any any)) any . each-any))))) e963)))) (global-extend65 (quote core)
(quote letrec) (lambda (e994 r995 w996 s997) ((lambda (tmp998) ((lambda
(tmp999) (if tmp999 (apply (lambda (_1000 id1001 val1002 e11003 e21004) (let
((ids1005 id1001)) (if (not (valid-bound-ids?92 ids1005)) (syntax-error e994
(quote "duplicate bound variable in")) (let ((labels1007 (gen-labels73
ids1005)) (new-vars1008 (map gen-var115 ids1005))) (let ((w1009
(make-binding-wrap84 ids1005 labels1007 w996)) (r1010 (extend-var-env62
labels1007 new-vars1008 r995))) (build-letrec51 s997 new-vars1008 (map (lambda
(x1011) (chi103 x1011 r1010 w1009)) val1002) (chi-body107 (cons e11003 e21004)
(source-wrap96 e994 w1009 s997) r1010 w1009))))))) tmp999) ((lambda (_1014)
(syntax-error (source-wrap96 e994 w996 s997))) tmp998))) (syntax-dispatch
tmp998 (quote (any #(each (any any)) any . each-any))))) e994)))
(global-extend65 (quote core) (quote set!) (lambda (e1015 r1016 w1017 s1018)
((lambda (tmp1019) ((lambda (tmp1020) (if (if tmp1020 (apply (lambda (_1021
id1022 val1023) (id?67 id1022)) tmp1020) (quote #f)) (apply (lambda (_1024
id1025 val1026) (let ((val1027 (chi103 val1026 r1016 w1017)) (n1028
(id-var-name89 id1025 w1017))) (let ((b1029 (lookup64 n1028 r1016))) (let
((t1030 (binding-type59 b1029))) (if (memv t1030 (quote (lexical))) (list
(quote set!) (binding-value60 b1029) val1027) (if (memv t1030 (quote (global)))
(list (quote set!) n1028 val1027) (if (memv t1030 (quote (displaced-lexical)))
(syntax-error (wrap95 id1025 w1017) (quote "identifier out of context"))
(syntax-error (source-wrap96 e1015 w1017 s1018))))))))) tmp1020) ((lambda
(tmp1031) (if tmp1031 (apply (lambda (_1032 getter1033 arg1034 val1035) (cons
(chi103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg
val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))))) getter1033) r1016 w1017) (map (lambda
(e1036) (chi103 e1036 r1016 w1017)) (append arg1034 (list val1035))))) tmp1031)
((lambda (_1038) (syntax-error (source-wrap96 e1015 w1017 s1018))) tmp1019)))
(syntax-dispatch tmp1019 (quote (any (any . each-any) any))))))
(syntax-dispatch tmp1019 (quote (any any any))))) e1015))) (global-extend65
(quote begin) (quote begin) (quote ())) (global-extend65 (quote define) (quote
define) (quote ())) (global-extend65 (quote define-syntax) (quote
define-syntax) (quote ())) (global-extend65 (quote eval-when) (quote eval-when)
(quote ())) (global-extend65 (quote core) (quote syntax-case) (letrec
((gen-syntax-case1042 (lambda (x1043 keys1044 clauses1045 r1046) (if (null?
clauses1045) (list (quote syntax-error) x1043) ((lambda (tmp1047) ((lambda
(tmp1048) (if tmp1048 (apply (lambda (pat1049 exp1050) (if (and (id?67 pat1049)
(andmap (lambda (x1051) (not (free-id=?90 pat1049 x1051))) (cons (quote
#(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top))
#("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call
convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-wrap syntax-object-expression
syntax-object? make-syntax-object self-evaluating? build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))))) keys1044))) (let ((labels1052 (list
(gen-label72))) (var1053 (gen-var115 pat1049))) (list (list (quote lambda)
(list var1053) (chi103 exp1050 (extend-env61 labels1052 (list (cons (quote
syntax) (cons var1053 (quote 0)))) r1046) (make-binding-wrap84 (list pat1049)
labels1052 (quote (()))))) x1043)) (gen-clause1041 x1043 keys1044 (cdr
clauses1045) r1046 pat1049 (quote #t) exp1050))) tmp1048) ((lambda (tmp1054)
(if tmp1054 (apply (lambda (pat1055 fender1056 exp1057) (gen-clause1041 x1043
keys1044 (cdr clauses1045) r1046 pat1055 fender1056 exp1057)) tmp1054) ((lambda
(_1058) (syntax-error (car clauses1045) (quote "invalid syntax-case clause")))
tmp1047))) (syntax-dispatch tmp1047 (quote (any any any)))))) (syntax-dispatch
tmp1047 (quote (any any))))) (car clauses1045))))) (gen-clause1041 (lambda
(x1059 keys1060 clauses1061 r1062 pat1063 fender1064 exp1065) (call-with-values
(lambda () (convert-pattern1039 pat1063 keys1060)) (lambda (p1066 pvars1067)
(cond ((not (distinct-bound-ids?93 (map car pvars1067))) (syntax-error pat1063
(quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap
(lambda (x1068) (not (ellipsis?112 (car x1068)))) pvars1067)) (syntax-error
pat1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let
((y1069 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list y1069) (let
((y1070 y1069)) (list (quote if) ((lambda (tmp1071) ((lambda (tmp1072) (if
tmp1072 (apply (lambda () y1070) tmp1072) ((lambda (_1073) (list (quote if)
y1070 (build-dispatch-call1040 pvars1067 fender1064 y1070 r1062) (list (quote
quote) (quote #f)))) tmp1071))) (syntax-dispatch tmp1071 (quote #(atom #t)))))
fender1064) (build-dispatch-call1040 pvars1067 exp1065 y1070 r1062)
(gen-syntax-case1042 x1059 keys1060 clauses1061 r1062)))) (if (eq? p1066 (quote
any)) (list (quote list) x1059) (list (quote syntax-dispatch) x1059 (list
(quote quote) p1066))))))))))) (build-dispatch-call1040 (lambda (pvars1074
exp1075 y1076 r1077) (let ((ids1078 (map car pvars1074)) (levels1079 (map cdr
pvars1074))) (let ((labels1080 (gen-labels73 ids1078)) (new-vars1081 (map
gen-var115 ids1078))) (list (quote apply) (list (quote lambda) new-vars1081
(chi103 exp1075 (extend-env61 labels1080 (map (lambda (var1082 level1083) (cons
(quote syntax) (cons var1082 level1083))) new-vars1081 (map cdr pvars1074))
r1077) (make-binding-wrap84 ids1078 labels1080 (quote (()))))) y1076)))))
(convert-pattern1039 (lambda (pattern1084 keys1085) (let cvt1086 ((p1087
pattern1084) (n1088 (quote 0)) (ids1089 (quote ()))) (if (id?67 p1087) (if
(bound-id-member?94 p1087 keys1085) (values (vector (quote free-id) p1087)
ids1089) (values (quote any) (cons (cons p1087 n1088) ids1089))) ((lambda
(tmp1090) ((lambda (tmp1091) (if (if tmp1091 (apply (lambda (x1092 dots1093)
(ellipsis?112 dots1093)) tmp1091) (quote #f)) (apply (lambda (x1094 dots1095)
(call-with-values (lambda () (cvt1086 x1094 (fx+38 n1088 (quote 1)) ids1089))
(lambda (p1096 ids1097) (values (if (eq? p1096 (quote any)) (quote each-any)
(vector (quote each) p1096)) ids1097)))) tmp1091) ((lambda (tmp1098) (if
tmp1098 (apply (lambda (x1099 y1100) (call-with-values (lambda () (cvt1086
y1100 n1088 ids1089)) (lambda (y1101 ids1102) (call-with-values (lambda ()
(cvt1086 x1099 n1088 ids1102)) (lambda (x1103 ids1104) (values (cons x1103
y1101) ids1104)))))) tmp1098) ((lambda (tmp1105) (if tmp1105 (apply (lambda ()
(values (quote ()) ids1089)) tmp1105) ((lambda (tmp1106) (if tmp1106 (apply
(lambda (x1107) (call-with-values (lambda () (cvt1086 x1107 n1088 ids1089))
(lambda (p1109 ids1110) (values (vector (quote vector) p1109) ids1110))))
tmp1106) ((lambda (x1111) (values (vector (quote atom) (strip114 p1087 (quote
(())))) ids1089)) tmp1090))) (syntax-dispatch tmp1090 (quote #(vector
each-any)))))) (syntax-dispatch tmp1090 (quote ()))))) (syntax-dispatch tmp1090
(quote (any . any)))))) (syntax-dispatch tmp1090 (quote (any any)))))
p1087)))))) (lambda (e1112 r1113 w1114 s1115) (let ((e1116 (source-wrap96 e1112
w1114 s1115))) ((lambda (tmp1117) ((lambda (tmp1118) (if tmp1118 (apply (lambda
(_1119 val1120 key1121 m1122) (if (andmap (lambda (x1123) (and (id?67 x1123)
(not (ellipsis?112 x1123)))) key1121) (let ((x1125 (gen-var115 (quote tmp))))
(list (list (quote lambda) (list x1125) (gen-syntax-case1042 x1125 key1121
m1122 r1113)) (chi103 val1120 r1113 (quote (()))))) (syntax-error e1116 (quote
"invalid literals list in")))) tmp1118) (syntax-error tmp1117)))
(syntax-dispatch tmp1117 (quote (any any each-any . each-any))))) e1116)))))
(set! sc-expand (let ((m1128 (quote e)) (esew1129 (quote (eval)))) (lambda
(x1130) (if (and (pair? x1130) (equal? (car x1130) noexpand37)) (cadr x1130)
(chi-top102 x1130 (quote ()) (quote ((top))) m1128 esew1129))))) (set!
sc-expand3 (let ((m1131 (quote e)) (esew1132 (quote (eval)))) (lambda (x1134 .
rest1133) (if (and (pair? x1134) (equal? (car x1134) noexpand37)) (cadr x1134)
(chi-top102 x1134 (quote ()) (quote ((top))) (if (null? rest1133) m1131 (car
rest1133)) (if (or (null? rest1133) (null? (cdr rest1133))) esew1132 (cadr
rest1133))))))) (set! identifier? (lambda (x1135) (nonsymbol-id?66 x1135)))
(set! datum->syntax-object (lambda (id1136 datum1137) (begin (let ((x1138
id1136)) (if (not (nonsymbol-id?66 x1138)) (error-hook45 (quote
datum->syntax-object) (quote "invalid argument") x1138))) (make-syntax-object52
datum1137 (syntax-object-wrap55 id1136))))) (set! syntax-object->datum (lambda
(x1139) (strip114 x1139 (quote (()))))) (set! generate-temporaries (lambda
(ls1140) (begin (let ((x1141 ls1140)) (if (not (list? x1141)) (error-hook45
(quote generate-temporaries) (quote "invalid argument") x1141))) (map (lambda
(x1142) (wrap95 (gensym) (quote ((top))))) ls1140)))) (set! free-identifier=?
(lambda (x1143 y1144) (begin (let ((x1145 x1143)) (if (not (nonsymbol-id?66
x1145)) (error-hook45 (quote free-identifier=?) (quote "invalid argument")
x1145))) (let ((x1146 y1144)) (if (not (nonsymbol-id?66 x1146)) (error-hook45
(quote free-identifier=?) (quote "invalid argument") x1146))) (free-id=?90
x1143 y1144)))) (set! bound-identifier=? (lambda (x1147 y1148) (begin (let
((x1149 x1147)) (if (not (nonsymbol-id?66 x1149)) (error-hook45 (quote
bound-identifier=?) (quote "invalid argument") x1149))) (let ((x1150 y1148))
(if (not (nonsymbol-id?66 x1150)) (error-hook45 (quote bound-identifier=?)
(quote "invalid argument") x1150))) (bound-id=?91 x1147 y1148)))) (set!
syntax-error (lambda (object1152 . messages1151) (begin (for-each (lambda
(x1153) (let ((x1154 x1153)) (if (not (string? x1154)) (error-hook45 (quote
syntax-error) (quote "invalid argument") x1154)))) messages1151) (let
((message1155 (if (null? messages1151) (quote "invalid syntax") (apply
string-append messages1151)))) (error-hook45 (quote #f) message1155 (strip114
object1152 (quote (())))))))) (set! install-global-transformer (lambda (sym1156
v1157) (begin (let ((x1158 sym1156)) (if (not (symbol? x1158)) (error-hook45
(quote define-syntax) (quote "invalid argument") x1158))) (let ((x1159 v1157))
(if (not (procedure? x1159)) (error-hook45 (quote define-syntax) (quote
"invalid argument") x1159))) (global-extend65 (quote macro) sym1156 v1157))))
(letrec ((match1164 (lambda (e1165 p1166 w1167 r1168) (cond ((not r1168) (quote
#f)) ((eq? p1166 (quote any)) (cons (wrap95 e1165 w1167) r1168))
((syntax-object?53 e1165) (match*1163 (let ((e1169 (syntax-object-expression54
e1165))) (if (annotation?42 e1169) (annotation-expression e1169) e1169)) p1166
(join-wraps86 w1167 (syntax-object-wrap55 e1165)) r1168)) (else (match*1163
(let ((e1170 e1165)) (if (annotation?42 e1170) (annotation-expression e1170)
e1170)) p1166 w1167 r1168))))) (match*1163 (lambda (e1171 p1172 w1173 r1174)
(cond ((null? p1172) (and (null? e1171) r1174)) ((pair? p1172) (and (pair?
e1171) (match1164 (car e1171) (car p1172) w1173 (match1164 (cdr e1171) (cdr
p1172) w1173 r1174)))) ((eq? p1172 (quote each-any)) (let ((l1175
(match-each-any1161 e1171 w1173))) (and l1175 (cons l1175 r1174)))) (else (let
((t1176 (vector-ref p1172 (quote 0)))) (if (memv t1176 (quote (each))) (if
(null? e1171) (match-empty1162 (vector-ref p1172 (quote 1)) r1174) (let ((l1177
(match-each1160 e1171 (vector-ref p1172 (quote 1)) w1173))) (and l1177 (let
collect1178 ((l1179 l1177)) (if (null? (car l1179)) r1174 (cons (map car l1179)
(collect1178 (map cdr l1179)))))))) (if (memv t1176 (quote (free-id))) (and
(id?67 e1171) (free-id=?90 (wrap95 e1171 w1173) (vector-ref p1172 (quote 1)))
r1174) (if (memv t1176 (quote (atom))) (and (equal? (vector-ref p1172 (quote
1)) (strip114 e1171 w1173)) r1174) (if (memv t1176 (quote (vector))) (and
(vector? e1171) (match1164 (vector->list e1171) (vector-ref p1172 (quote 1))
w1173 r1174))))))))))) (match-empty1162 (lambda (p1180 r1181) (cond ((null?
p1180) r1181) ((eq? p1180 (quote any)) (cons (quote ()) r1181)) ((pair? p1180)
(match-empty1162 (car p1180) (match-empty1162 (cdr p1180) r1181))) ((eq? p1180
(quote each-any)) (cons (quote ()) r1181)) (else (let ((t1182 (vector-ref p1180
(quote 0)))) (if (memv t1182 (quote (each))) (match-empty1162 (vector-ref p1180
(quote 1)) r1181) (if (memv t1182 (quote (free-id atom))) r1181 (if (memv t1182
(quote (vector))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181)))))))))
(match-each-any1161 (lambda (e1183 w1184) (cond ((annotation?42 e1183)
(match-each-any1161 (annotation-expression e1183) w1184)) ((pair? e1183) (let
((l1185 (match-each-any1161 (cdr e1183) w1184))) (and l1185 (cons (wrap95 (car
e1183) w1184) l1185)))) ((null? e1183) (quote ())) ((syntax-object?53 e1183)
(match-each-any1161 (syntax-object-expression54 e1183) (join-wraps86 w1184
(syntax-object-wrap55 e1183)))) (else (quote #f))))) (match-each1160 (lambda
(e1186 p1187 w1188) (cond ((annotation?42 e1186) (match-each1160
(annotation-expression e1186) p1187 w1188)) ((pair? e1186) (let ((first1189
(match1164 (car e1186) p1187 w1188 (quote ())))) (and first1189 (let ((rest1190
(match-each1160 (cdr e1186) p1187 w1188))) (and rest1190 (cons first1189
rest1190)))))) ((null? e1186) (quote ())) ((syntax-object?53 e1186)
(match-each1160 (syntax-object-expression54 e1186) p1187 (join-wraps86 w1188
(syntax-object-wrap55 e1186)))) (else (quote #f)))))) (set! syntax-dispatch
(lambda (e1191 p1192) (cond ((eq? p1192 (quote any)) (list e1191))
((syntax-object?53 e1191) (match*1163 (let ((e1193 (syntax-object-expression54
e1191))) (if (annotation?42 e1193) (annotation-expression e1193) e1193)) p1192
(syntax-object-wrap55 e1191) (quote ()))) (else (match*1163 (let ((e1194
e1191)) (if (annotation?42 e1194) (annotation-expression e1194) e1194)) p1192
(quote (())) (quote ())))))))))
(install-global-transformer (quote with-syntax) (lambda (x1195) ((lambda
(tmp1196) ((lambda (tmp1197) (if tmp1197 (apply (lambda (_1198 e11199 e21200)
(cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))
(cons e11199 e21200))) tmp1197) ((lambda (tmp1202) (if tmp1202 (apply (lambda
(_1203 out1204 in1205 e11206 e21207) (list (quote #(syntax-object syntax-case
((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1205
(quote ()) (list out1204 (cons (quote #(syntax-object begin ((top) #(ribcage
#(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11206 e21207)))))
tmp1202) ((lambda (tmp1209) (if tmp1209 (apply (lambda (_1210 out1211 in1212
e11213 e21214) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_
out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote
#(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))))) in1212) (quote ()) (list out1211 (cons (quote
#(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))))) (cons e11213 e21214))))) tmp1209) (syntax-error tmp1196)))
(syntax-dispatch tmp1196 (quote (any #(each (any any)) any . each-any))))))
(syntax-dispatch tmp1196 (quote (any ((any any)) any . each-any))))))
(syntax-dispatch tmp1196 (quote (any () any . each-any))))) x1195)))
(install-global-transformer (quote syntax-rules) (lambda (x1218) ((lambda
(tmp1219) ((lambda (tmp1220) (if tmp1220 (apply (lambda (_1221 k1222
keyword1223 pattern1224 template1225) (list (quote #(syntax-object lambda
((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern
template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object
syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k
keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k1222 (map
(lambda (tmp1228 tmp1227) (list (cons (quote #(syntax-object dummy ((top)
#(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top))
#("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))
tmp1227) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword
pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1228))) template1225
pattern1224)))))) tmp1220) (syntax-error tmp1219))) (syntax-dispatch tmp1219
(quote (any each-any . #(each ((any . any) any))))))) x1218)))
(install-global-transformer (quote let*) (lambda (x1229) ((lambda (tmp1230)
((lambda (tmp1231) (if (if tmp1231 (apply (lambda (let*1232 x1233 v1234 e11235
e21236) (andmap identifier? x1233)) tmp1231) (quote #f)) (apply (lambda
(let*1238 x1239 v1240 e11241 e21242) (let f1243 ((bindings1244 (map list x1239
v1240))) (if (null? bindings1244) (cons (quote #(syntax-object let ((top)
#(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i"))
#(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ())
(cons e11241 e21242))) ((lambda (tmp1248) ((lambda (tmp1249) (if tmp1249 (apply
(lambda (body1250 binding1251) (list (quote #(syntax-object let ((top)
#(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2)
#((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))))) (list binding1251) body1250)) tmp1249)
(syntax-error tmp1248))) (syntax-dispatch tmp1248 (quote (any any))))) (list
(f1243 (cdr bindings1244)) (car bindings1244)))))) tmp1231) (syntax-error
tmp1230))) (syntax-dispatch tmp1230 (quote (any #(each (any any)) any .
each-any))))) x1229)))
Index: guile/guile-core/ice-9/psyntax.ss
diff -u guile/guile-core/ice-9/psyntax.ss:1.11
guile/guile-core/ice-9/psyntax.ss:1.12
--- guile/guile-core/ice-9/psyntax.ss:1.11 Sat May 5 20:29:52 2001
+++ guile/guile-core/ice-9/psyntax.ss Fri May 18 18:31:32 2001
@@ -424,7 +424,7 @@
(define-syntax build-lexical-var
(syntax-rules ()
- ((_ src id) (gentemp (symbol->string id) generated-symbols))))
+ ((_ src id) (gensym (symbol->string id)))))
(define-syntax self-evaluating?
(syntax-rules ()
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- guile/guile-core/ice-9 psyntax.ss psyntax.pp ma...,
Marius Vollmer <=