From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:25 -0800
Subject: Import Upstream version 2a6

---
 scaexpp.scm | 2956 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 2956 insertions(+)
 create mode 100644 scaexpp.scm

(limited to 'scaexpp.scm')

diff --git a/scaexpp.scm b/scaexpp.scm
new file mode 100644
index 0000000..aa058a6
--- /dev/null
+++ b/scaexpp.scm
@@ -0,0 +1,2956 @@
+;;; "scaexpp.scm" syntax-case macros
+;;; Copyright (C) 1992 R. Kent Dybvig
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright notice in full.  This software
+;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
+;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
+;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
+;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
+;;; NATURE WHATSOEVER.
+
+;;; Written by Robert Hieb & Kent Dybvig
+
+;;; This file was munged by a simple minded sed script since it left
+;;; its original authors' hands.  See syncase.sh for the horrid details.
+
+(begin ((lambda ()
+(letrec ((lambda-var-list (lambda (vars)
+((letrec ((lvl (lambda (vars ls)
+(if (pair? vars)
+(lvl (cdr vars)
+(cons (car vars)
+ls))
+(if (id? vars)
+(cons vars
+ls)
+(if (null?
+vars)
+ls
+(if (syntax-object?
+vars)
+(lvl (unwrap
+vars)
+ls)
+(cons vars
+ls))))))))
+lvl)
+vars
+'())))
+(gen-var (lambda (id) (gen-sym (id-sym-name id))))
+(gen-sym (lambda (sym)
+(syncase:new-symbol-hook (symbol->string sym))))
+(strip (lambda (x)
+(if (syntax-object? x)
+(strip (syntax-object-expression x))
+(if (pair? x)
+((lambda (a d)
+(if (if (eq? a (car x))
+(eq? d (cdr x))
+#f)
+x
+(cons a d)))
+(strip (car x))
+(strip (cdr x)))
+(if (vector? x)
+((lambda (old)
+((lambda (new)
+(if (syncase:andmap eq? old new)
+x
+(list->vector new)))
+(map strip old)))
+(vector->list x))
+x)))))
+(regen (lambda (x)
+((lambda (g000139)
+(if (memv g000139 '(ref))
+(syncase:build-lexical-reference (cadr x))
+(if (memv g000139 '(primitive))
+(syncase:build-global-reference (cadr x))
+(if (memv g000139 '(id))
+(syncase:build-identifier (cadr x))
+(if (memv g000139 '(quote))
+(syncase:build-data (cadr x))
+(if (memv
+g000139
+'(lambda))
+(syncase:build-lambda
+(cadr x)
+(regen (caddr x)))
+(begin g000139
+(syncase:build-application
+(syncase:build-global-reference
+(car x))
+(map regen
+(cdr x))))))))))
+(car x))))
+(gen-vector (lambda (x)
+(if (eq? (car x) 'list)
+(syncase:list* 'vector (cdr x))
+(if (eq? (car x) 'quote)
+(list
+'quote
+(list->vector (cadr x)))
+(list 'list->vector x)))))
+(gen-append (lambda (x y)
+(if (equal? y ''())
+x
+(list 'append x y))))
+(gen-cons (lambda (x y)
+(if (eq? (car y) 'list)
+(syncase:list* 'list x (cdr y))
+(if (if (eq? (car x) 'quote)
+(eq? (car y) 'quote)
+#f)
+(list
+'quote
+(cons (cadr x) (cadr y)))
+(if (equal? y ''())
+(list 'list x)
+(list 'cons x y))))))
+(gen-map (lambda (e map-env)
+((lambda (formals actuals)
+(if (eq? (car e) 'ref)
+(car actuals)
+(if (syncase:andmap
+(lambda (x)
+(if (eq? (car x) 'ref)
+(memq (cadr x)
+formals)
+#f))
+(cdr e))
+(syncase:list*
+'map
+(list 'primitive (car e))
+(map ((lambda (r)
+(lambda (x)
+(cdr (assq (cadr x)
+r))))
+(map cons
+formals
+actuals))
+(cdr e)))
+(syncase:list*
+'map
+(list 'lambda formals e)
+actuals))))
+(map cdr map-env)
+(map (lambda (x) (list 'ref (car x)))
+map-env))))
+(gen-ref (lambda (var level maps k)
+(if (= level 0)
+(k var maps)
+(gen-ref
+var
+(- level 1)
+(cdr maps)
+(lambda (outer-var outer-maps)
+((lambda (b)
+(if b
+(k (cdr b) maps)
+((lambda (inner-var)
+(k inner-var
+(cons (cons (cons outer-var
+inner-var)
+(car maps))
+outer-maps)))
+(gen-sym var))))
+(assq outer-var (car maps))))))))
+(chi-syntax (lambda (src exp r w)
+((letrec ((gen (lambda (e maps k)
+(if (id? e)
+((lambda (n)
+((lambda (b)
+(if (eq? (binding-type
+b)
+'syntax)
+((lambda (level)
+(if (< (length
+maps)
+level)
+(syntax-error
+src
+"missing ellipsis in")
+(gen-ref
+n
+level
+maps
+(lambda (x
+maps)
+(k (list
+'ref
+x)
+maps)))))
+(binding-value
+b))
+(if (ellipsis?
+(wrap e
+w))
+(syntax-error
+src
+"invalid context for ... in")
+(k (list
+'id
+(wrap e
+w))
+maps))))
+(lookup
+n
+e
+r)))
+(id-var-name
+e
+w))
+((lambda (g000141)
+((lambda (g000142)
+((lambda (g000140)
+(if (not (eq? g000140
+'no))
+((lambda (_dots1
+_dots2)
+(if (if (ellipsis?
+(wrap _dots1
+w))
+(ellipsis?
+(wrap _dots2
+w))
+#f)
+(k (list
+'id
+(wrap _dots1
+w))
+maps)
+(g000142)))
+(car g000140)
+(cadr g000140))
+(g000142)))
+(syntax-dispatch
+g000141
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(lambda ()
+((lambda (g000144)
+((lambda (g000145)
+((lambda (g000143)
+(if (not (eq? g000143
+'no))
+((lambda (_x
+_dots
+_y)
+(if (ellipsis?
+(wrap _dots
+w))
+(gen _y
+maps
+(lambda (y
+maps)
+(gen _x
+(cons '()
+maps)
+(lambda (x
+maps)
+(if (null?
+(car maps))
+(syntax-error
+src
+"extra ellipsis in")
+(k (gen-append
+(gen-map
+x
+(car maps))
+y)
+(cdr maps)))))))
+(g000145)))
+(car g000143)
+(cadr g000143)
+(caddr
+g000143))
+(g000145)))
+(syntax-dispatch
+g000144
+'(pair (any)
+pair
+(any)
+any)
+(vector))))
+(lambda ()
+((lambda (g000147)
+((lambda (g000146)
+(if (not (eq? g000146
+'no))
+((lambda (_x
+_y)
+(gen _x
+maps
+(lambda (x
+maps)
+(gen _y
+maps
+(lambda (y
+maps)
+(k (gen-cons
+x
+y)
+maps))))))
+(car g000146)
+(cadr g000146))
+((lambda (g000149)
+((lambda (g000148)
+(if (not (eq? g000148
+'no))
+((lambda (_e1
+_e2)
+(gen (cons _e1
+_e2)
+maps
+(lambda (e
+maps)
+(k (gen-vector
+e)
+maps))))
+(car g000148)
+(cadr g000148))
+((lambda (g000151)
+((lambda (g000150)
+(if (not (eq? g000150
+'no))
+((lambda (__)
+(k (list
+'quote
+(wrap e
+w))
+maps))
+(car g000150))
+(syntax-error
+g000151)))
+(syntax-dispatch
+g000151
+'(any)
+(vector))))
+g000149)))
+(syntax-dispatch
+g000149
+'(vector
+pair
+(any)
+each
+any)
+(vector))))
+g000147)))
+(syntax-dispatch
+g000147
+'(pair (any)
+any)
+(vector))))
+g000144))))
+g000141))))
+e)))))
+gen)
+exp
+'()
+(lambda (e maps) (regen e)))))
+(ellipsis? (lambda (x)
+;; I dont know what this is supposed to do, and removing it seemed harmless.
+;; (if (if (top-level-bound? 'dp) dp #f)
+;; (break)
+;; (syncase:void))
+(if (identifier? x)
+(free-id=? x '...)
+#f)))
+(chi-syntax-definition (lambda (e w)
+((lambda (g000153)
+((lambda (g000154)
+((lambda (g000152)
+(if (not (eq? g000152
+'no))
+((lambda (__
+_name
+_val)
+(if (id? _name)
+(list _name
+_val)
+(g000154)))
+(car g000152)
+(cadr g000152)
+(caddr
+g000152))
+(g000154)))
+(syntax-dispatch
+g000153
+'(pair (any)
+pair
+(any)
+pair
+(any)
+atom)
+(vector))))
+(lambda ()
+(syntax-error
+g000153))))
+(wrap e w))))
+(chi-definition (lambda (e w)
+((lambda (g000156)
+((lambda (g000157)
+((lambda (g000155)
+(if (not (eq? g000155
+'no))
+(apply
+(lambda (__
+_name
+_args
+_e1
+_e2)
+(if (if (id? _name)
+(valid-bound-ids?
+(lambda-var-list
+_args))
+#f)
+(list _name
+(cons '#(syntax-object
+lambda
+(top))
+(cons _args
+(cons _e1
+_e2))))
+(g000157)))
+g000155)
+(g000157)))
+(syntax-dispatch
+g000156
+'(pair (any)
+pair
+(pair (any) any)
+pair
+(any)
+each
+any)
+(vector))))
+(lambda ()
+((lambda (g000159)
+((lambda (g000158)
+(if (not (eq? g000158
+'no))
+((lambda (__
+_name
+_val)
+(list _name
+_val))
+(car g000158)
+(cadr g000158)
+(caddr
+g000158))
+((lambda (g000161)
+((lambda (g000162)
+((lambda (g000160)
+(if (not (eq? g000160
+'no))
+((lambda (__
+_name)
+(if (id? _name)
+(list _name
+(list '#(syntax-object
+syncase:void
+(top))))
+(g000162)))
+(car g000160)
+(cadr g000160))
+(g000162)))
+(syntax-dispatch
+g000161
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(lambda ()
+(syntax-error
+g000161))))
+g000159)))
+(syntax-dispatch
+g000159
+'(pair (any)
+pair
+(any)
+pair
+(any)
+atom)
+(vector))))
+g000156))))
+(wrap e w))))
+(chi-sequence (lambda (e w)
+((lambda (g000164)
+((lambda (g000163)
+(if (not (eq? g000163 'no))
+((lambda (__ _e) _e)
+(car g000163)
+(cadr g000163))
+(syntax-error g000164)))
+(syntax-dispatch
+g000164
+'(pair (any) each any)
+(vector))))
+(wrap e w))))
+(chi-macro-def (lambda (def r w)
+(syncase:eval-hook (chi def null-env w))))
+(chi-local-syntax (lambda (e r w)
+((lambda (g000166)
+((lambda (g000167)
+((lambda (g000165)
+(if (not (eq? g000165
+'no))
+(apply
+(lambda (_who
+_var
+_val
+_e1
+_e2)
+(if (valid-bound-ids?
+_var)
+((lambda (new-vars)
+((lambda (new-w)
+(chi-body
+(cons _e1
+_e2)
+e
+(extend-macro-env
+new-vars
+((lambda (w)
+(map (lambda (x)
+(chi-macro-def
+x
+r
+w))
+_val))
+(if (free-id=?
+_who
+'#(syntax-object
+letrec-syntax
+(top)))
+new-w
+w))
+r)
+new-w))
+(make-binding-wrap
+_var
+new-vars
+w)))
+(map gen-var
+_var))
+(g000167)))
+g000165)
+(g000167)))
+(syntax-dispatch
+g000166
+'(pair (any)
+pair
+(each pair
+(any)
+pair
+(any)
+atom)
+pair
+(any)
+each
+any)
+(vector))))
+(lambda ()
+((lambda (g000169)
+((lambda (g000168)
+(if (not (eq? g000168
+'no))
+((lambda (__)
+(syntax-error
+(wrap e
+w)))
+(car g000168))
+(syntax-error
+g000169)))
+(syntax-dispatch
+g000169
+'(any)
+(vector))))
+g000166))))
+e)))
+(chi-body (lambda (body source r w)
+(if (null? (cdr body))
+(chi (car body) r w)
+((letrec ((parse1 (lambda (body
+var-ids
+var-vals
+macro-ids
+macro-vals)
+(if (null? body)
+(syntax-error
+(wrap source
+w)
+"no expressions in body")
+((letrec ((parse2 (lambda (e)
+((lambda (b)
+((lambda (g000170)
+(if (memv
+g000170
+'(macro))
+(parse2
+(chi-macro
+(binding-value
+b)
+e
+r
+empty-wrap
+(lambda (e
+r
+w)
+(wrap e
+w))))
+(if (memv
+g000170
+'(definition))
+(parse1
+(cdr body)
+(cons (cadr b)
+var-ids)
+(cons (caddr
+b)
+var-vals)
+macro-ids
+macro-vals)
+(if (memv
+g000170
+'(syntax-definition))
+(parse1
+(cdr body)
+var-ids
+var-vals
+(cons (cadr b)
+macro-ids)
+(cons (caddr
+b)
+macro-vals))
+(if (memv
+g000170
+'(sequence))
+(parse1
+(append
+(cdr b)
+(cdr body))
+var-ids
+var-vals
+macro-ids
+macro-vals)
+(begin g000170
+(if (valid-bound-ids?
+(append
+var-ids
+macro-ids))
+((lambda (new-var-names
+new-macro-names)
+((lambda (w)
+((lambda (r)
+(syncase:build-letrec
+new-var-names
+(map (lambda (x)
+(chi x
+r
+w))
+var-vals)
+(syncase:build-sequence
+(map (lambda (x)
+(chi x
+r
+w))
+body))))
+(extend-macro-env
+new-macro-names
+(map (lambda (x)
+(chi-macro-def
+x
+r
+w))
+macro-vals)
+(extend-var-env
+new-var-names
+r))))
+(make-binding-wrap
+(append
+macro-ids
+var-ids)
+(append
+new-macro-names
+new-var-names)
+empty-wrap)))
+(map gen-var
+var-ids)
+(map gen-var
+macro-ids))
+(syntax-error
+(wrap source
+w)
+"invalid identifier"))))))))
+(car b)))
+(syntax-type
+e
+r
+empty-wrap)))))
+parse2)
+(car body))))))
+parse1)
+(map (lambda (x) (wrap x w)) body)
+'()
+'()
+'()
+'()))))
+(syntax-type (lambda (e r w)
+(if (syntax-object? e)
+(syntax-type
+(syntax-object-expression e)
+r
+(join-wraps
+(syntax-object-wrap e)
+w))
+(if (if (pair? e)
+(identifier? (car e))
+#f)
+((lambda (n)
+((lambda (b)
+((lambda (g000171)
+(if (memv
+g000171
+'(special))
+(if (memv
+n
+'(define))
+(cons 'definition
+(chi-definition
+e
+w))
+(if (memv
+n
+'(define-syntax))
+(cons 'syntax-definition
+(chi-syntax-definition
+e
+w))
+(if (memv
+n
+'(begin))
+(cons 'sequence
+(chi-sequence
+e
+w))
+(begin n
+(syncase:void)))))
+(begin g000171
+b)))
+(binding-type b)))
+(lookup n (car e) r)))
+(id-var-name (car e) w))
+'(other)))))
+(chi-args (lambda (args r w source source-w)
+(if (pair? args)
+(cons (chi (car args) r w)
+(chi-args
+(cdr args)
+r
+w
+source
+source-w))
+(if (null? args)
+'()
+(if (syntax-object? args)
+(chi-args
+(syntax-object-expression
+args)
+r
+(join-wraps
+w
+(syntax-object-wrap
+args))
+source
+source-w)
+(syntax-error
+(wrap source source-w)))))))
+(chi-ref (lambda (e name binding w)
+((lambda (g000172)
+(if (memv g000172 '(lexical))
+(syncase:build-lexical-reference name)
+(if (memv
+g000172
+'(global global-unbound))
+(syncase:build-global-reference name)
+(begin g000172
+(id-error
+(wrap e w))))))
+(binding-type binding))))
+(chi-macro (letrec ((check-macro-output (lambda (x)
+(if (pair?
+x)
+(begin (check-macro-output
+(car x))
+(check-macro-output
+(cdr x)))
+((lambda (g000173)
+(if g000173
+g000173
+(if (vector?
+x)
+((lambda (n)
+((letrec ((g000174 (lambda (i)
+(if (= i
+n)
+(syncase:void)
+(begin (check-macro-output
+(vector-ref
+x
+i))
+(g000174
+(+ i
+1)))))))
+g000174)
+0))
+(vector-length
+x))
+(if (symbol?
+x)
+(syntax-error
+x
+"encountered raw symbol")
+(syncase:void)))))
+(syntax-object?
+x))))))
+(lambda (p e r w k)
+((lambda (mw)
+((lambda (x)
+(check-macro-output x)
+(k x r mw))
+(p (wrap e (join-wraps mw w)))))
+(new-mark-wrap)))))
+(chi-pair (lambda (e r w k)
+((lambda (first rest)
+(if (id? first)
+((lambda (n)
+((lambda (b)
+((lambda (g000175)
+(if (memv
+g000175
+'(core))
+((binding-value b)
+e
+r
+w)
+(if (memv
+g000175
+'(macro))
+(chi-macro
+(binding-value
+b)
+e
+r
+w
+k)
+(if (memv
+g000175
+'(special))
+((binding-value
+b)
+e
+r
+w
+k)
+(begin g000175
+(syncase:build-application
+(chi-ref
+first
+n
+b
+w)
+(chi-args
+rest
+r
+w
+e
+w)))))))
+(binding-type b)))
+(lookup n first r)))
+(id-var-name first w))
+(syncase:build-application
+(chi first r w)
+(chi-args rest r w e w))))
+(car e)
+(cdr e))))
+(chi (lambda (e r w)
+(if (symbol? e)
+((lambda (n)
+(chi-ref e n (lookup n e r) w))
+(id-var-name e w))
+(if (pair? e)
+(chi-pair e r w chi)
+(if (syntax-object? e)
+(chi (syntax-object-expression e)
+r
+(join-wraps
+w
+(syntax-object-wrap e)))
+(if ((lambda (g000176)
+(if g000176
+g000176
+((lambda (g000177)
+(if g000177
+g000177
+((lambda (g000178)
+(if g000178
+g000178
+(char?
+e)))
+(string? e))))
+(number? e))))
+(boolean? e))
+(syncase:build-data e)
+(syntax-error (wrap e w))))))))
+(chi-top (lambda (e r w)
+(if (pair? e)
+(chi-pair e r w chi-top)
+(if (syntax-object? e)
+(chi-top
+(syntax-object-expression e)
+r
+(join-wraps
+w
+(syntax-object-wrap e)))
+(chi e r w)))))
+(wrap (lambda (x w)
+(if (null? w)
+x
+(if (syntax-object? x)
+(make-syntax-object
+(syntax-object-expression x)
+(join-wraps
+w
+(syntax-object-wrap x)))
+(if (null? x)
+x
+(make-syntax-object x w))))))
+(unwrap (lambda (x)
+(if (syntax-object? x)
+((lambda (e w)
+(if (pair? e)
+(cons (wrap (car e) w)
+(wrap (cdr e) w))
+(if (vector? e)
+(list->vector
+(map (lambda (x)
+(wrap x w))
+(vector->list e)))
+e)))
+(syntax-object-expression x)
+(syntax-object-wrap x))
+x)))
+(bound-id-member? (lambda (x list)
+(if (not (null? list))
+((lambda (g000179)
+(if g000179
+g000179
+(bound-id-member?
+x
+(cdr list))))
+(bound-id=? x (car list)))
+#f)))
+(valid-bound-ids? (lambda (ids)
+(if ((letrec ((all-ids? (lambda (ids)
+((lambda (g000181)
+(if g000181
+g000181
+(if (id? (car ids))
+(all-ids?
+(cdr ids))
+#f)))
+(null?
+ids)))))
+all-ids?)
+ids)
+((letrec ((unique? (lambda (ids)
+((lambda (g000180)
+(if g000180
+g000180
+(if (not (bound-id-member?
+(car ids)
+(cdr ids)))
+(unique?
+(cdr ids))
+#f)))
+(null?
+ids)))))
+unique?)
+ids)
+#f)))
+(bound-id=? (lambda (i j)
+(if (eq? (id-sym-name i)
+(id-sym-name j))
+((lambda (i j)
+(if (eq? (car i) (car j))
+(same-marks?
+(cdr i)
+(cdr j))
+#f))
+(id-var-name&marks i empty-wrap)
+(id-var-name&marks j empty-wrap))
+#f)))
+(free-id=? (lambda (i j)
+(if (eq? (id-sym-name i) (id-sym-name j))
+(eq? (id-var-name i empty-wrap)
+(id-var-name j empty-wrap))
+#f)))
+(id-var-name&marks (lambda (id w)
+(if (null? w)
+(if (symbol? id)
+(list id)
+(id-var-name&marks
+(syntax-object-expression
+id)
+(syntax-object-wrap
+id)))
+((lambda (n&m first)
+(if (pair? first)
+((lambda (n)
+((letrec ((search (lambda (rib)
+(if (null?
+rib)
+n&m
+(if (if (eq? (caar rib)
+n)
+(same-marks?
+(cdr n&m)
+(cddar
+rib))
+#f)
+(cdar rib)
+(search
+(cdr rib)))))))
+search)
+first))
+(car n&m))
+(cons (car n&m)
+(if ((lambda (g000182)
+(if g000182
+g000182
+(not (eqv? first
+(cadr n&m)))))
+(null?
+(cdr n&m)))
+(cons first
+(cdr n&m))
+(cddr n&m)))))
+(id-var-name&marks
+id
+(cdr w))
+(car w)))))
+(id-var-name (lambda (id w)
+(if (null? w)
+(if (symbol? id)
+id
+(id-var-name
+(syntax-object-expression
+id)
+(syntax-object-wrap id)))
+(if (pair? (car w))
+(car (id-var-name&marks id w))
+(id-var-name id (cdr w))))))
+(same-marks? (lambda (x y)
+(if (null? x)
+(null? y)
+(if (not (null? y))
+(if (eqv? (car x) (car y))
+(same-marks?
+(cdr x)
+(cdr y))
+#f)
+#f))))
+(join-wraps2 (lambda (w1 w2)
+((lambda (x w1)
+(if (null? w1)
+(if (if (not (pair? x))
+(eqv? x (car w2))
+#f)
+(cdr w2)
+(cons x w2))
+(cons x (join-wraps2 w1 w2))))
+(car w1)
+(cdr w1))))
+(join-wraps1 (lambda (w1 w2)
+(if (null? w1)
+w2
+(cons (car w1)
+(join-wraps1 (cdr w1) w2)))))
+(join-wraps (lambda (w1 w2)
+(if (null? w2)
+w1
+(if (null? w1)
+w2
+(if (pair? (car w2))
+(join-wraps1 w1 w2)
+(join-wraps2 w1 w2))))))
+(make-wrap-rib (lambda (ids new-names w)
+(if (null? ids)
+'()
+(cons ((lambda (n&m)
+(cons (car n&m)
+(cons (car new-names)
+(cdr n&m))))
+(id-var-name&marks
+(car ids)
+w))
+(make-wrap-rib
+(cdr ids)
+(cdr new-names)
+w)))))
+(make-binding-wrap (lambda (ids new-names w)
+(if (null? ids)
+w
+(cons (make-wrap-rib
+ids
+new-names
+w)
+w))))
+(new-mark-wrap (lambda ()
+(set! current-mark
+(+ current-mark 1))
+(list current-mark)))
+(current-mark 0)
+(top-wrap '(top))
+(empty-wrap '())
+(id-sym-name (lambda (x)
+(if (symbol? x)
+x
+(syntax-object-expression x))))
+(id? (lambda (x)
+((lambda (g000183)
+(if g000183
+g000183
+(if (syntax-object? x)
+(symbol?
+(syntax-object-expression x))
+#f)))
+(symbol? x))))
+(global-extend (lambda (type sym val)
+(extend-global-env
+sym
+(cons type val))))
+(lookup (lambda (name id r)
+(if (eq? name (id-sym-name id))
+(global-lookup name)
+((letrec ((search (lambda (r name)
+(if (null? r)
+'(displaced-lexical)
+(if (pair?
+(car r))
+(if (eq? (caar r)
+name)
+(cdar r)
+(search
+(cdr r)
+name))
+(if (eq? (car r)
+name)
+'(lexical)
+(search
+(cdr r)
+name)))))))
+search)
+r
+name))))
+(extend-syntax-env (lambda (vars vals r)
+(if (null? vars)
+r
+(cons (cons (car vars)
+(cons 'syntax
+(car vals)))
+(extend-syntax-env
+(cdr vars)
+(cdr vals)
+r)))))
+(extend-var-env append)
+(extend-macro-env (lambda (vars vals r)
+(if (null? vars)
+r
+(cons (cons (car vars)
+(cons 'macro
+(car vals)))
+(extend-macro-env
+(cdr vars)
+(cdr vals)
+r)))))
+(null-env '())
+(global-lookup (lambda (sym)
+((lambda (g000184)
+(if g000184
+g000184
+'(global-unbound)))
+(syncase:get-global-definition-hook sym))))
+(extend-global-env (lambda (sym binding)
+(syncase:put-global-definition-hook
+sym
+binding)))
+(binding-value cdr)
+(binding-type car)
+(arg-check (lambda (pred? x who)
+(if (not (pred? x))
+(syncase:error-hook who "invalid argument" x)
+(syncase:void))))
+(id-error (lambda (x)
+(syntax-error
+x
+"invalid context for identifier")))
+(scope-error (lambda (id)
+(syntax-error
+id
+"invalid context for bound identifier")))
+(syntax-object-wrap (lambda (x) (vector-ref x 2)))
+(syntax-object-expression (lambda (x) (vector-ref x 1)))
+(make-syntax-object (lambda (expression wrap)
+(vector
+'syntax-object
+expression
+wrap)))
+(syntax-object? (lambda (x)
+(if (vector? x)
+(if (= (vector-length x) 3)
+(eq? (vector-ref x 0)
+'syntax-object)
+#f)
+#f))))
+(global-extend 'core 'letrec-syntax chi-local-syntax)
+(global-extend 'core 'let-syntax chi-local-syntax)
+(global-extend
+'core
+'quote
+(lambda (e r w)
+((lambda (g000136)
+((lambda (g000135)
+(if (not (eq? g000135 'no))
+((lambda (__ _e) (syncase:build-data (strip _e)))
+(car g000135)
+(cadr g000135))
+((lambda (g000138)
+((lambda (g000137)
+(if (not (eq? g000137 'no))
+((lambda (__)
+(syntax-error (wrap e w)))
+(car g000137))
+(syntax-error g000138)))
+(syntax-dispatch
+g000138
+'(any)
+(vector))))
+g000136)))
+(syntax-dispatch
+g000136
+'(pair (any) pair (any) atom)
+(vector))))
+e)))
+(global-extend
+'core
+'syntax
+(lambda (e r w)
+((lambda (g000132)
+((lambda (g000131)
+(if (not (eq? g000131 'no))
+((lambda (__ _x) (chi-syntax e _x r w))
+(car g000131)
+(cadr g000131))
+((lambda (g000134)
+((lambda (g000133)
+(if (not (eq? g000133 'no))
+((lambda (__)
+(syntax-error (wrap e w)))
+(car g000133))
+(syntax-error g000134)))
+(syntax-dispatch
+g000134
+'(any)
+(vector))))
+g000132)))
+(syntax-dispatch
+g000132
+'(pair (any) pair (any) atom)
+(vector))))
+e)))
+(global-extend
+'core
+'syntax-lambda
+(lambda (e r w)
+((lambda (g000127)
+((lambda (g000128)
+((lambda (g000126)
+(if (not (eq? g000126 'no))
+((lambda (__ _id _level _exp)
+(if (if (valid-bound-ids? _id)
+(map (lambda (x)
+(if (integer? x)
+(if (exact? x)
+(not (negative?
+x))
+#f)
+#f))
+(map unwrap _level))
+#f)
+((lambda (new-vars)
+(syncase:build-lambda
+new-vars
+(chi _exp
+(extend-syntax-env
+new-vars
+(map unwrap
+_level)
+r)
+(make-binding-wrap
+_id
+new-vars
+w))))
+(map gen-var _id))
+(g000128)))
+(car g000126)
+(cadr g000126)
+(caddr g000126)
+(cadddr g000126))
+(g000128)))
+(syntax-dispatch
+g000127
+'(pair (any)
+pair
+(each pair (any) pair (any) atom)
+pair
+(any)
+atom)
+(vector))))
+(lambda ()
+((lambda (g000130)
+((lambda (g000129)
+(if (not (eq? g000129 'no))
+((lambda (__)
+(syntax-error (wrap e w)))
+(car g000129))
+(syntax-error g000130)))
+(syntax-dispatch
+g000130
+'(any)
+(vector))))
+g000127))))
+e)))
+(global-extend
+'core
+'lambda
+(lambda (e r w)
+((lambda (g000121)
+((lambda (g000120)
+(if (not (eq? g000120 'no))
+((lambda (__ _id _e1 _e2)
+(if (not (valid-bound-ids? _id))
+(syntax-error
+(wrap e w)
+"invalid parameter list")
+((lambda (new-vars)
+(syncase:build-lambda
+new-vars
+(chi-body
+(cons _e1 _e2)
+e
+(extend-var-env
+new-vars
+r)
+(make-binding-wrap
+_id
+new-vars
+w))))
+(map gen-var _id))))
+(car g000120)
+(cadr g000120)
+(caddr g000120)
+(cadddr g000120))
+((lambda (g000123)
+((lambda (g000122)
+(if (not (eq? g000122 'no))
+((lambda (__ _ids _e1 _e2)
+((lambda (old-ids)
+(if (not (valid-bound-ids?
+(lambda-var-list
+_ids)))
+(syntax-error
+(wrap e w)
+"invalid parameter list")
+((lambda (new-vars)
+(syncase:build-improper-lambda
+(reverse
+(cdr new-vars))
+(car new-vars)
+(chi-body
+(cons _e1
+_e2)
+e
+(extend-var-env
+new-vars
+r)
+(make-binding-wrap
+old-ids
+new-vars
+w))))
+(map gen-var
+old-ids))))
+(lambda-var-list _ids)))
+(car g000122)
+(cadr g000122)
+(caddr g000122)
+(cadddr g000122))
+((lambda (g000125)
+((lambda (g000124)
+(if (not (eq? g000124
+'no))
+((lambda (__)
+(syntax-error
+(wrap e w)))
+(car g000124))
+(syntax-error
+g000125)))
+(syntax-dispatch
+g000125
+'(any)
+(vector))))
+g000123)))
+(syntax-dispatch
+g000123
+'(pair (any)
+pair
+(any)
+pair
+(any)
+each
+any)
+(vector))))
+g000121)))
+(syntax-dispatch
+g000121
+'(pair (any)
+pair
+(each any)
+pair
+(any)
+each
+any)
+(vector))))
+e)))
+(global-extend
+'core
+'letrec
+(lambda (e r w)
+((lambda (g000116)
+((lambda (g000117)
+((lambda (g000115)
+(if (not (eq? g000115 'no))
+(apply
+(lambda (__ _id _val _e1 _e2)
+(if (valid-bound-ids? _id)
+((lambda (new-vars)
+((lambda (w r)
+(syncase:build-letrec
+new-vars
+(map (lambda (x)
+(chi x
+r
+w))
+_val)
+(chi-body
+(cons _e1 _e2)
+e
+r
+w)))
+(make-binding-wrap
+_id
+new-vars
+w)
+(extend-var-env
+new-vars
+r)))
+(map gen-var _id))
+(g000117)))
+g000115)
+(g000117)))
+(syntax-dispatch
+g000116
+'(pair (any)
+pair
+(each pair (any) pair (any) atom)
+pair
+(any)
+each
+any)
+(vector))))
+(lambda ()
+((lambda (g000119)
+((lambda (g000118)
+(if (not (eq? g000118 'no))
+((lambda (__)
+(syntax-error (wrap e w)))
+(car g000118))
+(syntax-error g000119)))
+(syntax-dispatch
+g000119
+'(any)
+(vector))))
+g000116))))
+e)))
+(global-extend
+'core
+'if
+(lambda (e r w)
+((lambda (g000110)
+((lambda (g000109)
+(if (not (eq? g000109 'no))
+((lambda (__ _test _then)
+(syncase:build-conditional
+(chi _test r w)
+(chi _then r w)
+(chi (list '#(syntax-object
+syncase:void
+(top)))
+r
+empty-wrap)))
+(car g000109)
+(cadr g000109)
+(caddr g000109))
+((lambda (g000112)
+((lambda (g000111)
+(if (not (eq? g000111 'no))
+((lambda (__ _test _then _else)
+(syncase:build-conditional
+(chi _test r w)
+(chi _then r w)
+(chi _else r w)))
+(car g000111)
+(cadr g000111)
+(caddr g000111)
+(cadddr g000111))
+((lambda (g000114)
+((lambda (g000113)
+(if (not (eq? g000113
+'no))
+((lambda (__)
+(syntax-error
+(wrap e w)))
+(car g000113))
+(syntax-error
+g000114)))
+(syntax-dispatch
+g000114
+'(any)
+(vector))))
+g000112)))
+(syntax-dispatch
+g000112
+'(pair (any)
+pair
+(any)
+pair
+(any)
+pair
+(any)
+atom)
+(vector))))
+g000110)))
+(syntax-dispatch
+g000110
+'(pair (any) pair (any) pair (any) atom)
+(vector))))
+e)))
+(global-extend
+'core
+'set!
+(lambda (e r w)
+((lambda (g000104)
+((lambda (g000105)
+((lambda (g000103)
+(if (not (eq? g000103 'no))
+((lambda (__ _id _val)
+(if (id? _id)
+((lambda (val n)
+((lambda (g000108)
+(if (memv
+g000108
+'(lexical))
+(syncase:build-lexical-assignment
+n
+val)
+(if (memv
+g000108
+'(global
+global-unbound))
+(syncase:build-global-assignment
+n
+val)
+(begin g000108
+(id-error
+(wrap _id
+w))))))
+(binding-type
+(lookup n _id r))))
+(chi _val r w)
+(id-var-name _id w))
+(g000105)))
+(car g000103)
+(cadr g000103)
+(caddr g000103))
+(g000105)))
+(syntax-dispatch
+g000104
+'(pair (any) pair (any) pair (any) atom)
+(vector))))
+(lambda ()
+((lambda (g000107)
+((lambda (g000106)
+(if (not (eq? g000106 'no))
+((lambda (__)
+(syntax-error (wrap e w)))
+(car g000106))
+(syntax-error g000107)))
+(syntax-dispatch
+g000107
+'(any)
+(vector))))
+g000104))))
+e)))
+(global-extend
+'special
+'begin
+(lambda (e r w k)
+((lambda (body)
+(if (null? body)
+(if (eqv? k chi-top)
+(chi (list '#(syntax-object syncase:void (top)))
+r
+empty-wrap)
+(syntax-error
+(wrap e w)
+"no expressions in body of"))
+(syncase:build-sequence
+((letrec ((dobody (lambda (body)
+(if (null? body)
+'()
+((lambda (first)
+(cons first
+(dobody
+(cdr body))))
+(k (car body)
+r
+empty-wrap))))))
+dobody)
+body))))
+(chi-sequence e w))))
+(global-extend
+'special
+'define
+(lambda (e r w k)
+(if (eqv? k chi-top)
+((lambda (n&v)
+((lambda (n)
+(global-extend 'global n '())
+(syncase:build-global-definition
+n
+(chi (cadr n&v) r empty-wrap)))
+(id-var-name (car n&v) empty-wrap)))
+(chi-definition e w))
+(syntax-error
+(wrap e w)
+"invalid context for definition"))))
+(global-extend
+'special
+'define-syntax
+(lambda (e r w k)
+(if (eqv? k chi-top)
+((lambda (n&v)
+(global-extend
+'macro
+(id-var-name (car n&v) empty-wrap)
+(chi-macro-def (cadr n&v) r empty-wrap))
+(chi (list '#(syntax-object syncase:void (top)))
+r
+empty-wrap))
+(chi-syntax-definition e w))
+(syntax-error
+(wrap e w)
+"invalid context for definition"))))
+(set! expand-syntax
+(lambda (x) (chi-top x null-env top-wrap)))
+(set! implicit-identifier
+(lambda (id sym)
+(arg-check id? id 'implicit-identifier)
+(arg-check symbol? sym 'implicit-identifier)
+(if (syntax-object? id)
+(wrap sym (syntax-object-wrap id))
+sym)))
+(set! syntax-object->datum (lambda (x) (strip x)))
+(set! generate-temporaries
+(lambda (ls)
+(arg-check list? ls 'generate-temporaries)
+(map (lambda (x) (wrap (syncase:new-symbol-hook "g") top-wrap)) ls)))
+(set! free-identifier=?
+(lambda (x y)
+(arg-check id? x 'free-identifier=?)
+(arg-check id? y 'free-identifier=?)
+(free-id=? x y)))
+(set! bound-identifier=?
+(lambda (x y)
+(arg-check id? x 'bound-identifier=?)
+(arg-check id? y 'bound-identifier=?)
+(bound-id=? x y)))
+(set! identifier? (lambda (x) (id? x)))
+(set! syntax-error
+(lambda (object . messages)
+(for-each
+(lambda (x) (arg-check string? x 'syntax-error))
+messages)
+((lambda (message)
+(syncase:error-hook 'expand-syntax message (strip object)))
+(if (null? messages)
+"invalid syntax"
+(apply string-append messages)))))
+(set! syncase:install-global-transformer
+(lambda (sym p) (global-extend 'macro sym p)))
+((lambda ()
+(letrec ((match (lambda (e p k w r)
+(if (eq? r 'no)
+r
+((lambda (g000100)
+(if (memv g000100 '(any))
+(cons (wrap e w) r)
+(if (memv
+g000100
+'(free-id))
+(if (if (identifier?
+e)
+(free-id=?
+(wrap e w)
+(vector-ref
+k
+(cdr p)))
+#f)
+r
+'no)
+(begin g000100
+(if (syntax-object?
+e)
+(match*
+(syntax-object-expression
+e)
+p
+k
+(join-wraps
+w
+(syntax-object-wrap
+e))
+r)
+(match*
+e
+p
+k
+w
+r))))))
+(car p)))))
+(match* (lambda (e p k w r)
+((lambda (g000101)
+(if (memv g000101 '(pair))
+(if (pair? e)
+(match
+(car e)
+(cadr p)
+k
+w
+(match
+(cdr e)
+(cddr p)
+k
+w
+r))
+'no)
+(if (memv g000101 '(each))
+(if (eq? (cadr p) 'any)
+((lambda (l)
+(if (eq? l 'no)
+l
+(cons l r)))
+(match-each-any
+e
+w))
+(if (null? e)
+(match-empty
+(cdr p)
+r)
+((lambda (l)
+(if (eq? l
+'no)
+l
+((letrec ((collect (lambda (l)
+(if (null?
+(car l))
+r
+(cons (map car
+l)
+(collect
+(map cdr
+l)))))))
+collect)
+l)))
+(match-each
+e
+(cdr p)
+k
+w))))
+(if (memv
+g000101
+'(atom))
+(if (equal?
+(cdr p)
+e)
+r
+'no)
+(if (memv
+g000101
+'(vector))
+(if (vector? e)
+(match
+(vector->list
+e)
+(cdr p)
+k
+w
+r)
+'no)
+(begin g000101
+(syncase:void)))))))
+(car p))))
+(match-empty (lambda (p r)
+((lambda (g000102)
+(if (memv g000102 '(any))
+(cons '() r)
+(if (memv
+g000102
+'(each))
+(match-empty
+(cdr p)
+r)
+(if (memv
+g000102
+'(pair))
+(match-empty
+(cadr p)
+(match-empty
+(cddr p)
+r))
+(if (memv
+g000102
+'(free-id
+atom))
+r
+(if (memv
+g000102
+'(vector))
+(match-empty
+(cdr p)
+r)
+(begin g000102
+(syncase:void))))))))
+(car p))))
+(match-each-any (lambda (e w)
+(if (pair? e)
+((lambda (l)
+(if (eq? l 'no)
+l
+(cons (wrap (car e)
+w)
+l)))
+(match-each-any
+(cdr e)
+w))
+(if (null? e)
+'()
+(if (syntax-object?
+e)
+(match-each-any
+(syntax-object-expression
+e)
+(join-wraps
+w
+(syntax-object-wrap
+e)))
+'no)))))
+(match-each (lambda (e p k w)
+(if (pair? e)
+((lambda (first)
+(if (eq? first 'no)
+first
+((lambda (rest)
+(if (eq? rest
+'no)
+rest
+(cons first
+rest)))
+(match-each
+(cdr e)
+p
+k
+w))))
+(match (car e) p k w '()))
+(if (null? e)
+'()
+(if (syntax-object? e)
+(match-each
+(syntax-object-expression
+e)
+p
+k
+(join-wraps
+w
+(syntax-object-wrap
+e)))
+'no))))))
+(set! syntax-dispatch
+(lambda (expression pattern keys)
+(match
+expression
+pattern
+keys
+empty-wrap
+'())))))))))
+(syncase:install-global-transformer
+'let
+(lambda (x)
+((lambda (g00095)
+((lambda (g00096)
+((lambda (g00094)
+(if (not (eq? g00094 'no))
+(apply
+(lambda (__ _x _v _e1 _e2)
+(if (syncase:andmap identifier? _x)
+(cons (cons '#(syntax-object
+lambda
+(top))
+(cons _x
+(cons _e1 _e2)))
+_v)
+(g00096)))
+g00094)
+(g00096)))
+(syntax-dispatch
+g00095
+'(pair (any)
+pair
+(each pair (any) pair (any) atom)
+pair
+(any)
+each
+any)
+(vector))))
+(lambda ()
+((lambda (g00098)
+((lambda (g00099)
+((lambda (g00097)
+(if (not (eq? g00097 'no))
+(apply
+(lambda (__ _f _x _v _e1 _e2)
+(if (syncase:andmap
+identifier?
+(cons _f _x))
+(cons (list '#(syntax-object
+letrec
+(top))
+(list (list _f
+(cons '#(syntax-object
+lambda
+(top))
+(cons _x
+(cons _e1
+_e2)))))
+_f)
+_v)
+(g00099)))
+g00097)
+(g00099)))
+(syntax-dispatch
+g00098
+'(pair (any)
+pair
+(any)
+pair
+(each pair (any) pair (any) atom)
+pair
+(any)
+each
+any)
+(vector))))
+(lambda () (syntax-error g00098))))
+g00095))))
+x)))
+(syncase:install-global-transformer
+'syntax-case
+((lambda ()
+(letrec ((syncase:build-dispatch-call (lambda (args body val)
+((lambda (g00046)
+((lambda (g00045)
+(if (not (eq? g00045
+'no))
+body
+((lambda (g00048)
+((lambda (g00047)
+(if (not (eq? g00047
+'no))
+((lambda (_arg1)
+((lambda (g00066)
+((lambda (g00065)
+(if (not (eq? g00065
+'no))
+((lambda (_body
+_val)
+(list (list '#(syntax-object
+syntax-lambda
+(top))
+(list _arg1)
+_body)
+(list '#(syntax-object
+car
+(top))
+_val)))
+(car g00065)
+(cadr g00065))
+(syntax-error
+g00066)))
+(syntax-dispatch
+g00066
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(list body
+val)))
+(car g00047))
+((lambda (g00050)
+((lambda (g00049)
+(if (not (eq? g00049
+'no))
+((lambda (_arg1
+_arg2)
+((lambda (g00064)
+((lambda (g00063)
+(if (not (eq? g00063
+'no))
+((lambda (_body
+_val)
+(list (list '#(syntax-object
+syntax-lambda
+(top))
+(list _arg1
+_arg2)
+_body)
+(list '#(syntax-object
+car
+(top))
+_val)
+(list '#(syntax-object
+cadr
+(top))
+_val)))
+(car g00063)
+(cadr g00063))
+(syntax-error
+g00064)))
+(syntax-dispatch
+g00064
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(list body
+val)))
+(car g00049)
+(cadr g00049))
+((lambda (g00052)
+((lambda (g00051)
+(if (not (eq? g00051
+'no))
+((lambda (_arg1
+_arg2
+_arg3)
+((lambda (g00062)
+((lambda (g00061)
+(if (not (eq? g00061
+'no))
+((lambda (_body
+_val)
+(list (list '#(syntax-object
+syntax-lambda
+(top))
+(list _arg1
+_arg2
+_arg3)
+_body)
+(list '#(syntax-object
+car
+(top))
+_val)
+(list '#(syntax-object
+cadr
+(top))
+_val)
+(list '#(syntax-object
+caddr
+(top))
+_val)))
+(car g00061)
+(cadr g00061))
+(syntax-error
+g00062)))
+(syntax-dispatch
+g00062
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(list body
+val)))
+(car g00051)
+(cadr g00051)
+(caddr
+g00051))
+((lambda (g00054)
+((lambda (g00053)
+(if (not (eq? g00053
+'no))
+((lambda (_arg1
+_arg2
+_arg3
+_arg4)
+((lambda (g00060)
+((lambda (g00059)
+(if (not (eq? g00059
+'no))
+((lambda (_body
+_val)
+(list (list '#(syntax-object
+syntax-lambda
+(top))
+(list _arg1
+_arg2
+_arg3
+_arg4)
+_body)
+(list '#(syntax-object
+car
+(top))
+_val)
+(list '#(syntax-object
+cadr
+(top))
+_val)
+(list '#(syntax-object
+caddr
+(top))
+_val)
+(list '#(syntax-object
+cadddr
+(top))
+_val)))
+(car g00059)
+(cadr g00059))
+(syntax-error
+g00060)))
+(syntax-dispatch
+g00060
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(list body
+val)))
+(car g00053)
+(cadr g00053)
+(caddr
+g00053)
+(cadddr
+g00053))
+((lambda (g00056)
+((lambda (g00055)
+(if (not (eq? g00055
+'no))
+((lambda (_arg)
+((lambda (g00058)
+((lambda (g00057)
+(if (not (eq? g00057
+'no))
+((lambda (_body
+_val)
+(list '#(syntax-object
+apply
+(top))
+(list '#(syntax-object
+syntax-lambda
+(top))
+_arg
+_body)
+_val))
+(car g00057)
+(cadr g00057))
+(syntax-error
+g00058)))
+(syntax-dispatch
+g00058
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(list body
+val)))
+(car g00055))
+(syntax-error
+g00056)))
+(syntax-dispatch
+g00056
+'(each any)
+(vector))))
+g00054)))
+(syntax-dispatch
+g00054
+'(pair (any)
+pair
+(any)
+pair
+(any)
+pair
+(any)
+atom)
+(vector))))
+g00052)))
+(syntax-dispatch
+g00052
+'(pair (any)
+pair
+(any)
+pair
+(any)
+atom)
+(vector))))
+g00050)))
+(syntax-dispatch
+g00050
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+g00048)))
+(syntax-dispatch
+g00048
+'(pair (any)
+atom)
+(vector))))
+g00046)))
+(syntax-dispatch
+g00046
+'(atom)
+(vector))))
+args)))
+(extract-bound-syntax-ids (lambda (pattern keys)
+((letrec ((gen (lambda (p
+n
+ids)
+(if (identifier?
+p)
+(if (key? p
+keys)
+ids
+(cons (list p
+n)
+ids))
+((lambda (g00068)
+((lambda (g00069)
+((lambda (g00067)
+(if (not (eq? g00067
+'no))
+((lambda (_x
+_dots)
+(if (ellipsis?
+_dots)
+(gen _x
+(+ n
+1)
+ids)
+(g00069)))
+(car g00067)
+(cadr g00067))
+(g00069)))
+(syntax-dispatch
+g00068
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(lambda ()
+((lambda (g00071)
+((lambda (g00070)
+(if (not (eq? g00070
+'no))
+((lambda (_x
+_y)
+(gen _x
+n
+(gen _y
+n
+ids)))
+(car g00070)
+(cadr g00070))
+((lambda (g00073)
+((lambda (g00072)
+(if (not (eq? g00072
+'no))
+((lambda (_x)
+(gen _x
+n
+ids))
+(car g00072))
+((lambda (g00075)
+((lambda (g00074)
+(if (not (eq? g00074
+'no))
+((lambda (_x)
+ids)
+(car g00074))
+(syntax-error
+g00075)))
+(syntax-dispatch
+g00075
+'(any)
+(vector))))
+g00073)))
+(syntax-dispatch
+g00073
+'(vector
+each
+any)
+(vector))))
+g00071)))
+(syntax-dispatch
+g00071
+'(pair (any)
+any)
+(vector))))
+g00068))))
+p)))))
+gen)
+pattern
+0
+'())))
+(valid-syntax-pattern? (lambda (pattern keys)
+(letrec ((check? (lambda (p
+ids)
+(if (identifier?
+p)
+(if (eq? ids
+'no)
+ids
+(if (key? p
+keys)
+ids
+(if (if (not (ellipsis?
+p))
+(not (memid
+p
+ids))
+#f)
+(cons p
+ids)
+'no)))
+((lambda (g00077)
+((lambda (g00078)
+((lambda (g00076)
+(if (not (eq? g00076
+'no))
+((lambda (_x
+_dots)
+(if (ellipsis?
+_dots)
+(check?
+_x
+ids)
+(g00078)))
+(car g00076)
+(cadr g00076))
+(g00078)))
+(syntax-dispatch
+g00077
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(lambda ()
+((lambda (g00080)
+((lambda (g00079)
+(if (not (eq? g00079
+'no))
+((lambda (_x
+_y)
+(check?
+_x
+(check?
+_y
+ids)))
+(car g00079)
+(cadr g00079))
+((lambda (g00082)
+((lambda (g00081)
+(if (not (eq? g00081
+'no))
+((lambda (_x)
+(check?
+_x
+ids))
+(car g00081))
+((lambda (g00084)
+((lambda (g00083)
+(if (not (eq? g00083
+'no))
+((lambda (_x)
+ids)
+(car g00083))
+(syntax-error
+g00084)))
+(syntax-dispatch
+g00084
+'(any)
+(vector))))
+g00082)))
+(syntax-dispatch
+g00082
+'(vector
+each
+any)
+(vector))))
+g00080)))
+(syntax-dispatch
+g00080
+'(pair (any)
+any)
+(vector))))
+g00077))))
+p)))))
+(not (eq? (check?
+pattern
+'())
+'no)))))
+(valid-keyword? (lambda (k)
+(if (identifier? k)
+(not (free-identifier=?
+k
+'...))
+#f)))
+(convert-syntax-dispatch-pattern (lambda (pattern
+keys)
+((letrec ((gen (lambda (p)
+(if (identifier?
+p)
+(if (key? p
+keys)
+(cons '#(syntax-object
+free-id
+(top))
+(key-index
+p
+keys))
+(list '#(syntax-object
+any
+(top))))
+((lambda (g00086)
+((lambda (g00087)
+((lambda (g00085)
+(if (not (eq? g00085
+'no))
+((lambda (_x
+_dots)
+(if (ellipsis?
+_dots)
+(cons '#(syntax-object
+each
+(top))
+(gen _x))
+(g00087)))
+(car g00085)
+(cadr g00085))
+(g00087)))
+(syntax-dispatch
+g00086
+'(pair (any)
+pair
+(any)
+atom)
+(vector))))
+(lambda ()
+((lambda (g00089)
+((lambda (g00088)
+(if (not (eq? g00088
+'no))
+((lambda (_x
+_y)
+(cons '#(syntax-object
+pair
+(top))
+(cons (gen _x)
+(gen _y))))
+(car g00088)
+(cadr g00088))
+((lambda (g00091)
+((lambda (g00090)
+(if (not (eq? g00090
+'no))
+((lambda (_x)
+(cons '#(syntax-object
+vector
+(top))
+(gen _x)))
+(car g00090))
+((lambda (g00093)
+((lambda (g00092)
+(if (not (eq? g00092
+'no))
+((lambda (_x)
+(cons '#(syntax-object
+atom
+(top))
+p))
+(car g00092))
+(syntax-error
+g00093)))
+(syntax-dispatch
+g00093
+'(any)
+(vector))))
+g00091)))
+(syntax-dispatch
+g00091
+'(vector
+each
+any)
+(vector))))
+g00089)))
+(syntax-dispatch
+g00089
+'(pair (any)
+any)
+(vector))))
+g00086))))
+p)))))
+gen)
+pattern)))
+(key-index (lambda (p keys)
+(- (length keys)
+(length (memid p keys)))))
+(key? (lambda (p keys)
+(if (identifier? p) (memid p keys) #f)))
+(memid (lambda (i ids)
+(if (not (null? ids))
+(if (bound-identifier=? i (car ids))
+ids
+(memid i (cdr ids)))
+#f)))
+(ellipsis? (lambda (x)
+(if (identifier? x)
+(free-identifier=? x '...)
+#f))))
+(lambda (x)
+((lambda (g00030)
+((lambda (g00031)
+((lambda (g00029)
+(if (not (eq? g00029 'no))
+((lambda (__ _val _key)
+(if (syncase:andmap valid-keyword? _key)
+(list '#(syntax-object
+syntax-error
+(top))
+_val)
+(g00031)))
+(car g00029)
+(cadr g00029)
+(caddr g00029))
+(g00031)))
+(syntax-dispatch
+g00030
+'(pair (any)
+pair
+(any)
+pair
+(each any)
+atom)
+(vector))))
+(lambda ()
+((lambda (g00033)
+((lambda (g00034)
+((lambda (g00032)
+(if (not (eq? g00032 'no))
+(apply
+(lambda (__
+_val
+_key
+_pat
+_exp)
+(if (if (identifier?
+_pat)
+(if (syncase:andmap
+valid-keyword?
+_key)
+(syncase:andmap
+(lambda (x)
+(not (free-identifier=?
+_pat
+x)))
+(cons '...
+_key))
+#f)
+#f)
+(list (list '#(syntax-object
+syntax-lambda
+(top))
+(list (list _pat
+0))
+_exp)
+_val)
+(g00034)))
+g00032)
+(g00034)))
+(syntax-dispatch
+g00033
+'(pair (any)
+pair
+(any)
+pair
+(each any)
+pair
+(pair (any) pair (any) atom)
+atom)
+(vector))))
+(lambda ()
+((lambda (g00036)
+((lambda (g00037)
+((lambda (g00035)
+(if (not (eq? g00035 'no))
+(apply
+(lambda (__
+_val
+_key
+_pat
+_exp
+_e1
+_e2
+_e3)
+(if (if (syncase:andmap
+valid-keyword?
+_key)
+(valid-syntax-pattern?
+_pat
+_key)
+#f)
+((lambda (g00044)
+((lambda (g00043)
+(if (not (eq? g00043
+'no))
+((lambda (_pattern
+_y
+_call)
+(list '#(syntax-object
+let
+(top))
+(list (list '#(syntax-object
+x
+(top))
+_val))
+(list '#(syntax-object
+let
+(top))
+(list (list _y
+(list '#(syntax-object
+syntax-dispatch
+(top))
+'#(syntax-object
+x
+(top))
+(list '#(syntax-object
+quote
+(top))
+_pattern)
+(list '#(syntax-object
+syntax
+(top))
+(list->vector
+_key)))))
+(list '#(syntax-object
+if
+(top))
+(list '#(syntax-object
+not
+(top))
+(list '#(syntax-object
+eq?
+(top))
+_y
+(list '#(syntax-object
+quote
+(top))
+'#(syntax-object
+no
+(top)))))
+_call
+(cons '#(syntax-object
+syntax-case
+(top))
+(cons '#(syntax-object
+x
+(top))
+(cons _key
+(map (lambda (__e1
+__e2
+__e3)
+(cons __e1
+(cons __e2
+__e3)))
+_e1
+_e2
+_e3))))))))
+(car g00043)
+(cadr g00043)
+(caddr
+g00043))
+(syntax-error
+g00044)))
+(syntax-dispatch
+g00044
+'(pair (any)
+pair
+(any)
+pair
+(any)
+atom)
+(vector))))
+(list (convert-syntax-dispatch-pattern
+_pat
+_key)
+'#(syntax-object
+y
+(top))
+(syncase:build-dispatch-call
+(extract-bound-syntax-ids
+_pat
+_key)
+_exp
+'#(syntax-object
+y
+(top)))))
+(g00037)))
+g00035)
+(g00037)))
+(syntax-dispatch
+g00036
+'(pair (any)
+pair
+(any)
+pair
+(each any)
+pair
+(pair (any)
+pair
+(any)
+atom)
+each
+pair
+(any)
+pair
+(any)
+each
+any)
+(vector))))
+(lambda ()
+((lambda (g00039)
+((lambda (g00040)
+((lambda (g00038)
+(if (not (eq? g00038
+'no))
+(apply
+(lambda (__
+_val
+_key
+_pat
+_fender
+_exp
+_e1
+_e2
+_e3)
+(if (if (syncase:andmap
+valid-keyword?
+_key)
+(valid-syntax-pattern?
+_pat
+_key)
+#f)
+((lambda (g00042)
+((lambda (g00041)
+(if (not (eq? g00041
+'no))
+((lambda (_pattern
+_y
+_dorest
+_call)
+(list '#(syntax-object
+let
+(top))
+(list (list '#(syntax-object
+x
+(top))
+_val))
+(list '#(syntax-object
+let
+(top))
+(list (list _dorest
+(list '#(syntax-object
+lambda
+(top))
+'()
+(cons '#(syntax-object
+syntax-case
+(top))
+(cons '#(syntax-object
+x
+(top))
+(cons _key
+(map (lambda (__e1
+__e2
+__e3)
+(cons __e1
+(cons __e2
+__e3)))
+_e1
+_e2
+_e3)))))))
+(list '#(syntax-object
+let
+(top))
+(list (list _y
+(list '#(syntax-object
+syntax-dispatch
+(top))
+'#(syntax-object
+x
+(top))
+(list '#(syntax-object
+quote
+(top))
+_pattern)
+(list '#(syntax-object
+syntax
+(top))
+(list->vector
+_key)))))
+(list '#(syntax-object
+if
+(top))
+(list '#(syntax-object
+not
+(top))
+(list '#(syntax-object
+eq?
+(top))
+_y
+(list '#(syntax-object
+quote
+(top))
+'#(syntax-object
+no
+(top)))))
+_call
+(list _dorest))))))
+(car g00041)
+(cadr g00041)
+(caddr
+g00041)
+(cadddr
+g00041))
+(syntax-error
+g00042)))
+(syntax-dispatch
+g00042
+'(pair (any)
+pair
+(any)
+pair
+(any)
+pair
+(any)
+atom)
+(vector))))
+(list (convert-syntax-dispatch-pattern
+_pat
+_key)
+'#(syntax-object
+y
+(top))
+'#(syntax-object
+dorest
+(top))
+(syncase:build-dispatch-call
+(extract-bound-syntax-ids
+_pat
+_key)
+(list '#(syntax-object
+if
+(top))
+_fender
+_exp
+(list '#(syntax-object
+dorest
+(top))))
+'#(syntax-object
+y
+(top)))))
+(g00040)))
+g00038)
+(g00040)))
+(syntax-dispatch
+g00039
+'(pair (any)
+pair
+(any)
+pair
+(each any)
+pair
+(pair (any)
+pair
+(any)
+pair
+(any)
+atom)
+each
+pair
+(any)
+pair
+(any)
+each
+any)
+(vector))))
+(lambda ()
+(syntax-error
+g00039))))
+g00036))))
+g00033))))
+g00030))))
+x)))))))
-- 
cgit v1.2.3