summaryrefslogtreecommitdiff
path: root/module/ice-9
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2012-03-03 20:20:16 -0500
committerMark H Weaver <mhw@netris.org>2012-03-03 20:20:16 -0500
commitd019ef92886bebc2d0e79db7c16abacc50b6f77d (patch)
tree11adf595d7346e590850270e13cd8ac78f1e73a1 /module/ice-9
parentd5dbe0c1d5c0d53a652285ca565fa6c30a668f7f (diff)
parent1af6d2a717f499564fbbc297c79e00ac14b0dcf9 (diff)
downloadguile-d019ef92886bebc2d0e79db7c16abacc50b6f77d.tar.gz
Merge branch 'stable-2.0'
Conflicts: module/ice-9/psyntax-pp.scm module/language/tree-il.scm
Diffstat (limited to 'module/ice-9')
-rw-r--r--module/ice-9/compile-psyntax.scm80
-rw-r--r--module/ice-9/pretty-print.scm16
-rw-r--r--module/ice-9/psyntax-pp.scm28495
-rw-r--r--module/ice-9/psyntax.scm12
4 files changed, 3279 insertions, 25324 deletions
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 3d803e9c7..201ae395e 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -17,11 +17,70 @@
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (language tree-il)
- (language tree-il optimize)
+ (language tree-il primitives)
(language tree-il canonicalize)
+ (srfi srfi-1)
(ice-9 pretty-print)
(system syntax))
+;; Minimize a syntax-object such that it can no longer be used as the
+;; first argument to 'datum->syntax', but is otherwise equivalent.
+(define (squeeze-syntax-object! syn)
+ (define (ensure-list x) (if (vector? x) (vector->list x) x))
+ (let ((x (vector-ref syn 1))
+ (wrap (vector-ref syn 2))
+ (mod (vector-ref syn 3)))
+ (let ((marks (car wrap))
+ (subst (cdr wrap)))
+ (define (set-wrap! marks subst)
+ (vector-set! syn 2 (cons marks subst)))
+ (cond
+ ((symbol? x)
+ (let loop ((marks marks) (subst subst))
+ (cond
+ ((null? subst) (set-wrap! marks subst) syn)
+ ((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst)))
+ ((find (lambda (entry) (and (eq? x (car entry))
+ (equal? marks (cadr entry))))
+ (apply map list (map ensure-list
+ (cdr (vector->list (car subst))))))
+ => (lambda (entry)
+ (set-wrap! marks
+ (list (list->vector
+ (cons 'ribcage
+ (map vector entry)))))
+ syn))
+ (else (loop marks (cdr subst))))))
+ ((or (pair? x) (vector? x))
+ syn)
+ (else x)))))
+
+(define (squeeze-constant! x)
+ (define (syntax-object? x)
+ (and (vector? x)
+ (= 4 (vector-length x))
+ (eq? 'syntax-object (vector-ref x 0))))
+ (cond ((syntax-object? x)
+ (squeeze-syntax-object! x))
+ ((pair? x)
+ (set-car! x (squeeze-constant! (car x)))
+ (set-cdr! x (squeeze-constant! (cdr x)))
+ x)
+ ((vector? x)
+ (for-each (lambda (i)
+ (vector-set! x i (squeeze-constant! (vector-ref x i))))
+ (iota (vector-length x)))
+ x)
+ (else x)))
+
+(define (squeeze-tree-il! x)
+ (post-order! (lambda (x)
+ (if (const? x)
+ (set! (const-exp x)
+ (squeeze-constant! (const-exp x))))
+ #f)
+ x))
+
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
;; changing session identifiers.
(set! syntax-session-id (lambda () "*"))
@@ -40,12 +99,19 @@
(close-port in))
(begin
(pretty-print (tree-il->scheme
- (canonicalize!
- (optimize!
- (macroexpand x 'c '(compile load eval))
- (current-module)
- '())))
- out)
+ (squeeze-tree-il!
+ (canonicalize!
+ (resolve-primitives!
+ (macroexpand x 'c '(compile load eval))
+ (current-module))))
+ (current-module)
+ (list #:avoid-lambda? #f
+ #:use-case? #f
+ #:strip-numeric-suffixes? #t
+ #:use-derived-syntax?
+ (and (pair? x)
+ (eq? 'let (car x)))))
+ out #:width 120 #:max-expr-width 70)
(newline out)
(loop (read in))))))
(system (format #f "mv -f ~s.tmp ~s" target target)))
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 8a0c0b855..bf45eed42 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -1,6 +1,7 @@
;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010,
+;;;; 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -32,7 +33,8 @@
(define genwrite:newline-str (make-string 1 #\newline))
-(define (generic-write obj display? width per-line-prefix output)
+(define (generic-write
+ obj display? width max-expr-width per-line-prefix output)
(define (read-macro? l)
(define (length1? l) (and (pair? l) (null? (cdr l))))
@@ -93,7 +95,7 @@
(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
(let ((result '())
(left (min (+ (- (- width col) extra) 1) max-expr-width)))
- (generic-write obj display? #f ""
+ (generic-write obj display? #f max-expr-width ""
(lambda (str)
(set! result (cons str result))
(set! left (- left (string-length str)))
@@ -223,12 +225,10 @@
(define max-call-head-width 5)
- (define max-expr-width 50)
-
(define (style head)
(case head
- ((lambda let* letrec define define-public
- define-syntax let-syntax letrec-syntax)
+ ((lambda lambda* let* letrec define define* define-public
+ define-syntax let-syntax letrec-syntax with-syntax)
pp-LAMBDA)
((if set!) pp-IF)
((cond) pp-COND)
@@ -273,6 +273,7 @@
#:key
(port (or port* (current-output-port)))
(width 79)
+ (max-expr-width 50)
(display? #f)
(per-line-prefix ""))
"Pretty-print OBJ on PORT, which is a keyword argument defaulting to
@@ -286,6 +287,7 @@ Instead of with a keyword argument, you can also specify the output
port directly after OBJ, like (pretty-print OBJ PORT)."
(generic-write obj display?
(- width (string-length per-line-prefix))
+ max-expr-width
per-line-prefix
(lambda (s) (display s port) #t)))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 9e3c91e52..f82a14c0c 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,25448 +1,3335 @@
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f)
-(let ((session-id-4308 (if #f #f))
- (transformer-environment-4369 (if #f #f)))
- (letrec*
- ((top-level-eval-hook-4306
- (lambda (x-34042 mod-34043)
- (primitive-eval x-34042)))
- (maybe-name-value!-4312
- (lambda (name-17933 val-17934)
- (if (if (struct? val-17934)
- (eq? (struct-vtable val-17934)
- (vector-ref %expanded-vtables 14))
- #f)
- (let ((meta-17941 (struct-ref val-17934 1)))
- (if (not (assq 'name meta-17941))
- (let ((v-17946
- (cons (cons 'name name-17933) meta-17941)))
- (struct-set! val-17934 1 v-17946)))))))
- (build-call-4314
- (lambda (source-17748 fun-exp-17749 arg-exps-17750)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- source-17748
- fun-exp-17749
- arg-exps-17750)))
- (analyze-variable-4319
- (lambda (mod-17756
- var-17757
- modref-cont-17758
- bare-cont-17759)
- (if (not mod-17756)
- (bare-cont-17759 var-17757)
- (let ((kind-17760 (car mod-17756))
- (mod-17761 (cdr mod-17756)))
- (if (eqv? kind-17760 'public)
- (modref-cont-17758 mod-17761 var-17757 #t)
- (if (eqv? kind-17760 'private)
- (if (not (equal? mod-17761 (module-name (current-module))))
- (modref-cont-17758 mod-17761 var-17757 #f)
- (bare-cont-17759 var-17757))
- (if (eqv? kind-17760 'bare)
- (bare-cont-17759 var-17757)
- (if (eqv? kind-17760 'hygiene)
- (if (if (not (equal?
- mod-17761
- (module-name (current-module))))
- (module-variable
- (resolve-module mod-17761)
- var-17757)
- #f)
- (modref-cont-17758 mod-17761 var-17757 #f)
- (bare-cont-17759 var-17757))
- (syntax-violation
- #f
- "bad module kind"
- var-17757
- mod-17761)))))))))
- (build-simple-lambda-4323
- (lambda (src-17788
- req-17789
- rest-17790
- vars-17791
- meta-17792
- exp-17793)
- (let ((body-17799
- (make-struct/no-tail
- (vector-ref %expanded-vtables 15)
- src-17788
- req-17789
- #f
- rest-17790
- #f
- '()
- vars-17791
- exp-17793
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- src-17788
- meta-17792
- body-17799))))
- (build-primcall-4326
- (lambda (src-17811 name-17812 args-17813)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- src-17811
- name-17812
- args-17813)))
- (build-sequence-4329
- (lambda (src-34044 exps-34045)
- (if (null? (cdr exps-34045))
- (car exps-34045)
- (let ((head-34049 (car exps-34045))
- (tail-34050
- (build-sequence-4329 #f (cdr exps-34045))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- src-34044
- head-34049
- tail-34050)))))
- (build-named-let-4331
- (lambda (src-17819
- ids-17820
- vars-17821
- val-exps-17822
- body-exp-17823)
- (let ((f-17824 (car vars-17821))
- (f-name-17825 (car ids-17820))
- (vars-17826 (cdr vars-17821))
- (ids-17827 (cdr ids-17820)))
- (let ((proc-17828
- (let ((body-17848
- (make-struct/no-tail
- (vector-ref %expanded-vtables 15)
- src-17819
- ids-17827
- #f
- #f
- #f
- '()
- vars-17826
- body-exp-17823
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- src-17819
- '()
- body-17848))))
- (begin
- (if (if (struct? proc-17828)
- (eq? (struct-vtable proc-17828)
- (vector-ref %expanded-vtables 14))
- #f)
- (let ((meta-17872 (struct-ref proc-17828 1)))
- (if (not (assq 'name meta-17872))
- (let ((v-17879
- (cons (cons 'name f-name-17825) meta-17872)))
- (struct-set! proc-17828 1 v-17879)))))
- (for-each
- maybe-name-value!-4312
- ids-17827
- val-exps-17822)
- (let ((names-17903 (list f-name-17825))
- (gensyms-17904 (list f-17824))
- (vals-17905 (list proc-17828))
- (body-17906
- (let ((fun-exp-17910
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- src-17819
- f-name-17825
- f-17824)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- src-17819
- fun-exp-17910
- val-exps-17822))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 17)
- src-17819
- #f
- names-17903
- gensyms-17904
- vals-17905
- body-17906)))))))
- (build-letrec-4332
- (lambda (src-17926
- in-order?-17927
- ids-17928
- vars-17929
- val-exps-17930
- body-exp-17931)
- (if (null? vars-17929)
- body-exp-17931
- (begin
- (for-each
- maybe-name-value!-4312
- ids-17928
- val-exps-17930)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 17)
- src-17926
- in-order?-17927
- ids-17928
- vars-17929
- val-exps-17930
- body-exp-17931)))))
- (make-syntax-object-4333
- (lambda (expression-17957 wrap-17958 module-17959)
- (vector
- 'syntax-object
- expression-17957
- wrap-17958
- module-17959)))
- (extend-env-4342
- (lambda (labels-17961 bindings-17962 r-17963)
- (if (null? labels-17961)
- r-17963
- (extend-env-4342
- (cdr labels-17961)
- (cdr bindings-17962)
- (cons (cons (car labels-17961) (car bindings-17962))
- r-17963)))))
- (extend-var-env-4343
- (lambda (labels-17964 vars-17965 r-17966)
- (if (null? labels-17964)
- r-17966
- (extend-var-env-4343
- (cdr labels-17964)
- (cdr vars-17965)
- (cons (cons (car labels-17964)
- (cons 'lexical (car vars-17965)))
- r-17966)))))
- (macros-only-env-4344
- (lambda (r-17967)
- (if (null? r-17967)
- '()
- (let ((a-17968 (car r-17967)))
- (if (let ((t-17971 (car (cdr a-17968))))
- (if (eq? t-17971 'macro)
- #t
- (eq? t-17971 'syntax-parameter)))
- (cons a-17968
- (macros-only-env-4344 (cdr r-17967)))
- (macros-only-env-4344 (cdr r-17967)))))))
- (global-extend-4345
- (lambda (type-17973 sym-17974 val-17975)
- (module-define!
- (current-module)
- sym-17974
- (make-syntax-transformer
- sym-17974
- type-17973
- val-17975))))
- (id?-4347
- (lambda (x-11477)
- (if (symbol? x-11477)
- #t
- (if (if (vector? x-11477)
- (if (= (vector-length x-11477) 4)
- (eq? (vector-ref x-11477 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-11477 1))
- #f))))
- (gen-labels-4350
- (lambda (ls-17985)
- (if (null? ls-17985)
- '()
- (cons (string-append
- "l-"
- (session-id-4308)
- (symbol->string (gensym "-")))
- (gen-labels-4350 (cdr ls-17985))))))
- (make-binding-wrap-4361
- (lambda (ids-17989 labels-17990 w-17991)
- (if (null? ids-17989)
- w-17991
- (cons (car w-17991)
- (cons (let ((labelvec-17992 (list->vector labels-17990)))
- (let ((n-17993 (vector-length labelvec-17992)))
- (let ((symnamevec-17994 (make-vector n-17993))
- (marksvec-17995 (make-vector n-17993)))
- (begin
- (letrec*
- ((f-17996
- (lambda (ids-18193 i-18194)
- (if (not (null? ids-18193))
- (call-with-values
- (lambda ()
- (let ((x-18197 (car ids-18193)))
- (if (if (vector? x-18197)
- (if (= (vector-length
- x-18197)
- 4)
- (eq? (vector-ref
- x-18197
- 0)
- 'syntax-object)
- #f)
- #f)
- (values
- (vector-ref x-18197 1)
- (let ((m1-18213
- (car w-17991))
- (m2-18214
- (car (vector-ref
- x-18197
- 2))))
- (if (null? m2-18214)
- m1-18213
- (append
- m1-18213
- m2-18214))))
- (values
- x-18197
- (car w-17991)))))
- (lambda (symname-18234 marks-18235)
- (begin
- (vector-set!
- symnamevec-17994
- i-18194
- symname-18234)
- (vector-set!
- marksvec-17995
- i-18194
- marks-18235)
- (f-17996
- (cdr ids-18193)
- (#{1+}# i-18194)))))))))
- (f-17996 ids-17989 0))
- (vector
- 'ribcage
- symnamevec-17994
- marksvec-17995
- labelvec-17992)))))
- (cdr w-17991))))))
- (same-marks?-4365
- (lambda (x-34051 y-34052)
- (if (eq? x-34051 y-34052)
- (eq? x-34051 y-34052)
- (if (not (null? x-34051))
- (if (not (null? y-34052))
- (if (eq? (car x-34051) (car y-34052))
- (same-marks?-4365 (cdr x-34051) (cdr y-34052))
- #f)
- #f)
- #f))))
- (id-var-name-4366
- (lambda (id-34060 w-34061 mod-34062)
- (letrec*
- ((search-34063
- (lambda (sym-34129 subst-34130 marks-34131 mod-34132)
- (if (null? subst-34130)
- (values #f marks-34131)
- (let ((fst-34133 (car subst-34130)))
- (if (eq? fst-34133 'shift)
- (search-34063
- sym-34129
- (cdr subst-34130)
- (cdr marks-34131)
- mod-34132)
- (let ((symnames-34135 (vector-ref fst-34133 1)))
- (if (vector? symnames-34135)
- (search-vector-rib-34065
- sym-34129
- subst-34130
- marks-34131
- symnames-34135
- fst-34133
- mod-34132)
- (search-list-rib-34064
- sym-34129
- subst-34130
- marks-34131
- symnames-34135
- fst-34133
- mod-34132))))))))
- (search-list-rib-34064
- (lambda (sym-34310
- subst-34311
- marks-34312
- symnames-34313
- ribcage-34314
- mod-34315)
- (letrec*
- ((f-34316
- (lambda (symnames-34319 i-34320)
- (if (null? symnames-34319)
- (search-34063
- sym-34310
- (cdr subst-34311)
- marks-34312
- mod-34315)
- (if (if (eq? (car symnames-34319) sym-34310)
- (same-marks?-4365
- marks-34312
- (list-ref
- (vector-ref ribcage-34314 2)
- i-34320))
- #f)
- (let ((n-34466
- (list-ref
- (vector-ref ribcage-34314 3)
- i-34320)))
- (if (pair? n-34466)
- (if (equal? mod-34315 (car n-34466))
- (values (cdr n-34466) marks-34312)
- (f-34316
- (cdr symnames-34319)
- (#{1+}# i-34320)))
- (values n-34466 marks-34312)))
- (f-34316 (cdr symnames-34319) (#{1+}# i-34320)))))))
- (f-34316 symnames-34313 0))))
- (search-vector-rib-34065
- (lambda (sym-34471
- subst-34472
- marks-34473
- symnames-34474
- ribcage-34475
- mod-34476)
- (let ((n-34477 (vector-length symnames-34474)))
- (letrec*
- ((f-34478
- (lambda (i-34481)
- (if (= i-34481 n-34477)
- (search-34063
- sym-34471
- (cdr subst-34472)
- marks-34473
- mod-34476)
- (if (if (eq? (vector-ref symnames-34474 i-34481)
- sym-34471)
- (same-marks?-4365
- marks-34473
- (vector-ref
- (vector-ref ribcage-34475 2)
- i-34481))
- #f)
- (let ((n-34628
- (vector-ref
- (vector-ref ribcage-34475 3)
- i-34481)))
- (if (pair? n-34628)
- (if (equal? mod-34476 (car n-34628))
- (values (cdr n-34628) marks-34473)
- (f-34478 (#{1+}# i-34481)))
- (values n-34628 marks-34473)))
- (f-34478 (#{1+}# i-34481)))))))
- (f-34478 0))))))
- (if (symbol? id-34060)
- (let ((t-34066
- (search-34063
- id-34060
- (cdr w-34061)
- (car w-34061)
- mod-34062)))
- (if t-34066 t-34066 id-34060))
- (if (if (vector? id-34060)
- (if (= (vector-length id-34060) 4)
- (eq? (vector-ref id-34060 0) 'syntax-object)
- #f)
- #f)
- (let ((id-34081 (vector-ref id-34060 1))
- (w1-34082 (vector-ref id-34060 2))
- (mod-34083 (vector-ref id-34060 3)))
- (let ((marks-34084
- (let ((m1-34094 (car w-34061))
- (m2-34095 (car w1-34082)))
- (if (null? m2-34095)
- m1-34094
- (append m1-34094 m2-34095)))))
- (call-with-values
- (lambda ()
- (search-34063
- id-34081
- (cdr w-34061)
- marks-34084
- mod-34083))
- (lambda (new-id-34115 marks-34116)
- (if new-id-34115
- new-id-34115
- (let ((t-34124
- (search-34063
- id-34081
- (cdr w1-34082)
- marks-34116
- mod-34083)))
- (if t-34124 t-34124 id-34081)))))))
- (syntax-violation
- 'id-var-name
- "invalid id"
- id-34060))))))
- (locally-bound-identifiers-4367
- (lambda (w-18242 mod-18243)
+(letrec*
+ ((make-void
+ (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
+ (make-const
+ (lambda (src exp)
+ (make-struct (vector-ref %expanded-vtables 1) 0 src exp)))
+ (make-primitive-ref
+ (lambda (src name)
+ (make-struct (vector-ref %expanded-vtables 2) 0 src name)))
+ (make-lexical-ref
+ (lambda (src name gensym)
+ (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym)))
+ (make-lexical-set
+ (lambda (src name gensym exp)
+ (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp)))
+ (make-module-ref
+ (lambda (src mod name public?)
+ (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?)))
+ (make-module-set
+ (lambda (src mod name public? exp)
+ (make-struct
+ (vector-ref %expanded-vtables 6)
+ 0
+ src
+ mod
+ name
+ public?
+ exp)))
+ (make-toplevel-ref
+ (lambda (src name)
+ (make-struct (vector-ref %expanded-vtables 7) 0 src name)))
+ (make-toplevel-set
+ (lambda (src name exp)
+ (make-struct (vector-ref %expanded-vtables 8) 0 src name exp)))
+ (make-toplevel-define
+ (lambda (src name exp)
+ (make-struct (vector-ref %expanded-vtables 9) 0 src name exp)))
+ (make-conditional
+ (lambda (src test consequent alternate)
+ (make-struct
+ (vector-ref %expanded-vtables 10)
+ 0
+ src
+ test
+ consequent
+ alternate)))
+ (make-call
+ (lambda (src proc args)
+ (make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
+ (make-primcall
+ (lambda (src name args)
+ (make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
+ (make-seq
+ (lambda (src head tail)
+ (make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
+ (make-lambda
+ (lambda (src meta body)
+ (make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
+ (make-lambda-case
+ (lambda (src req opt rest kw inits gensyms body alternate)
+ (make-struct
+ (vector-ref %expanded-vtables 15)
+ 0
+ src
+ req
+ opt
+ rest
+ kw
+ inits
+ gensyms
+ body
+ alternate)))
+ (make-let
+ (lambda (src names gensyms vals body)
+ (make-struct
+ (vector-ref %expanded-vtables 16)
+ 0
+ src
+ names
+ gensyms
+ vals
+ body)))
+ (make-letrec
+ (lambda (src in-order? names gensyms vals body)
+ (make-struct
+ (vector-ref %expanded-vtables 17)
+ 0
+ src
+ in-order?
+ names
+ gensyms
+ vals
+ body)))
+ (make-dynlet
+ (lambda (src fluids vals body)
+ (make-struct
+ (vector-ref %expanded-vtables 18)
+ 0
+ src
+ fluids
+ vals
+ body)))
+ (lambda?
+ (lambda (x)
+ (and (struct? x)
+ (eq? (struct-vtable x) (vector-ref %expanded-vtables 14)))))
+ (lambda-meta (lambda (x) (struct-ref x 1)))
+ (set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
+ (top-level-eval-hook (lambda (x mod) (primitive-eval x)))
+ (local-eval-hook (lambda (x mod) (primitive-eval x)))
+ (session-id
+ (let ((v (module-variable (current-module) 'syntax-session-id)))
+ (lambda () ((variable-ref v)))))
+ (put-global-definition-hook
+ (lambda (symbol type val)
+ (module-define!
+ (current-module)
+ symbol
+ (make-syntax-transformer symbol type val))))
+ (get-global-definition-hook
+ (lambda (symbol module)
+ (if (and (not module) (current-module))
+ (warn "module system is booted, we should have a module" symbol))
+ (let ((v (module-variable
+ (if module (resolve-module (cdr module)) (current-module))
+ symbol)))
+ (and v
+ (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (macro-type val)
+ (cons (macro-type val) (macro-binding val))))))))
+ (decorate-source
+ (lambda (e s)
+ (if (and s (supports-source-properties? e))
+ (set-source-properties! e s))
+ e))
+ (maybe-name-value!
+ (lambda (name val)
+ (if (lambda? val)
+ (let ((meta (lambda-meta val)))
+ (if (not (assq 'name meta))
+ (set-lambda-meta! val (acons 'name name meta)))))))
+ (build-void (lambda (source) (make-void source)))
+ (build-call
+ (lambda (source fun-exp arg-exps)
+ (make-call source fun-exp arg-exps)))
+ (build-conditional
+ (lambda (source test-exp then-exp else-exp)
+ (make-conditional source test-exp then-exp else-exp)))
+ (build-dynlet
+ (lambda (source fluids vals body)
+ (make-dynlet source fluids vals body)))
+ (build-lexical-reference
+ (lambda (type source name var) (make-lexical-ref source name var)))
+ (build-lexical-assignment
+ (lambda (source name var exp)
+ (maybe-name-value! name exp)
+ (make-lexical-set source name var exp)))
+ (analyze-variable
+ (lambda (mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont var)
+ (let ((kind (car mod)) (mod (cdr mod)))
+ (let ((key kind))
+ (cond ((memv key '(public)) (modref-cont mod var #t))
+ ((memv key '(private))
+ (if (not (equal? mod (module-name (current-module))))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ ((memv key '(bare)) (bare-cont var))
+ ((memv key '(hygiene))
+ (if (and (not (equal? mod (module-name (current-module))))
+ (module-variable (resolve-module mod) var))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ (else (syntax-violation #f "bad module kind" var mod))))))))
+ (build-global-reference
+ (lambda (source var mod)
+ (analyze-variable
+ mod
+ var
+ (lambda (mod var public?) (make-module-ref source mod var public?))
+ (lambda (var) (make-toplevel-ref source var)))))
+ (build-global-assignment
+ (lambda (source var exp mod)
+ (maybe-name-value! var exp)
+ (analyze-variable
+ mod
+ var
+ (lambda (mod var public?)
+ (make-module-set source mod var public? exp))
+ (lambda (var) (make-toplevel-set source var exp)))))
+ (build-global-definition
+ (lambda (source var exp)
+ (maybe-name-value! var exp)
+ (make-toplevel-define source var exp)))
+ (build-simple-lambda
+ (lambda (src req rest vars meta exp)
+ (make-lambda
+ src
+ meta
+ (make-lambda-case src req #f rest #f '() vars exp #f))))
+ (build-case-lambda
+ (lambda (src meta body) (make-lambda src meta body)))
+ (build-lambda-case
+ (lambda (src req opt rest kw inits vars body else-case)
+ (make-lambda-case src req opt rest kw inits vars body else-case)))
+ (build-primcall
+ (lambda (src name args) (make-primcall src name args)))
+ (build-primref (lambda (src name) (make-primitive-ref src name)))
+ (build-data (lambda (src exp) (make-const src exp)))
+ (build-sequence
+ (lambda (src exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq src (car exps) (build-sequence #f (cdr exps))))))
+ (build-let
+ (lambda (src ids vars val-exps body-exp)
+ (for-each maybe-name-value! ids val-exps)
+ (if (null? vars) body-exp (make-let src ids vars val-exps body-exp))))
+ (build-named-let
+ (lambda (src ids vars val-exps body-exp)
+ (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids)))
+ (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
+ (maybe-name-value! f-name proc)
+ (for-each maybe-name-value! ids val-exps)
+ (make-letrec
+ src
+ #f
+ (list f-name)
+ (list f)
+ (list proc)
+ (build-call src (build-lexical-reference 'fun src f-name f) val-exps))))))
+ (build-letrec
+ (lambda (src in-order? ids vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ (begin
+ (for-each maybe-name-value! ids val-exps)
+ (make-letrec src in-order? ids vars val-exps body-exp)))))
+ (make-syntax-object
+ (lambda (expression wrap module)
+ (vector 'syntax-object expression wrap module)))
+ (syntax-object?
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) 4)
+ (eq? (vector-ref x 0) 'syntax-object))))
+ (syntax-object-expression (lambda (x) (vector-ref x 1)))
+ (syntax-object-wrap (lambda (x) (vector-ref x 2)))
+ (syntax-object-module (lambda (x) (vector-ref x 3)))
+ (set-syntax-object-expression!
+ (lambda (x update) (vector-set! x 1 update)))
+ (set-syntax-object-wrap!
+ (lambda (x update) (vector-set! x 2 update)))
+ (set-syntax-object-module!
+ (lambda (x update) (vector-set! x 3 update)))
+ (source-annotation
+ (lambda (x)
+ (let ((props (source-properties
+ (if (syntax-object? x) (syntax-object-expression x) x))))
+ (and (pair? props) props))))
+ (extend-env
+ (lambda (labels bindings r)
+ (if (null? labels)
+ r
+ (extend-env
+ (cdr labels)
+ (cdr bindings)
+ (cons (cons (car labels) (car bindings)) r)))))
+ (extend-var-env
+ (lambda (labels vars r)
+ (if (null? labels)
+ r
+ (extend-var-env
+ (cdr labels)
+ (cdr vars)
+ (cons (cons (car labels) (cons 'lexical (car vars))) r)))))
+ (macros-only-env
+ (lambda (r)
+ (if (null? r)
+ '()
+ (let ((a (car r)))
+ (if (memq (cadr a) '(macro syntax-parameter))
+ (cons a (macros-only-env (cdr r)))
+ (macros-only-env (cdr r)))))))
+ (global-extend
+ (lambda (type sym val) (put-global-definition-hook sym type val)))
+ (nonsymbol-id?
+ (lambda (x)
+ (and (syntax-object? x) (symbol? (syntax-object-expression x)))))
+ (id? (lambda (x)
+ (if (symbol? x)
+ #t
+ (and (syntax-object? x) (symbol? (syntax-object-expression x))))))
+ (id-sym-name&marks
+ (lambda (x w)
+ (if (syntax-object? x)
+ (values
+ (syntax-object-expression x)
+ (join-marks (car w) (car (syntax-object-wrap x))))
+ (values x (car w)))))
+ (gen-label
+ (lambda ()
+ (string-append "l-" (session-id) (symbol->string (gensym "-")))))
+ (gen-labels
+ (lambda (ls)
+ (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
+ (make-ribcage
+ (lambda (symnames marks labels)
+ (vector 'ribcage symnames marks labels)))
+ (ribcage?
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) 4)
+ (eq? (vector-ref x 0) 'ribcage))))
+ (ribcage-symnames (lambda (x) (vector-ref x 1)))
+ (ribcage-marks (lambda (x) (vector-ref x 2)))
+ (ribcage-labels (lambda (x) (vector-ref x 3)))
+ (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update)))
+ (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update)))
+ (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update)))
+ (anti-mark
+ (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w)))))
+ (extend-ribcage!
+ (lambda (ribcage id label)
+ (set-ribcage-symnames!
+ ribcage
+ (cons (syntax-object-expression id) (ribcage-symnames ribcage)))
+ (set-ribcage-marks!
+ ribcage
+ (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage)))))
+ (make-binding-wrap
+ (lambda (ids labels w)
+ (if (null? ids)
+ w
+ (cons (car w)
+ (cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec)))
+ (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
+ (let f ((ids ids) (i 0))
+ (if (not (null? ids))
+ (call-with-values
+ (lambda () (id-sym-name&marks (car ids) w))
+ (lambda (symname marks)
+ (vector-set! symnamevec i symname)
+ (vector-set! marksvec i marks)
+ (f (cdr ids) (+ i 1))))))
+ (make-ribcage symnamevec marksvec labelvec)))
+ (cdr w))))))
+ (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2))))
+ (join-wraps
+ (lambda (w1 w2)
+ (let ((m1 (car w1)) (s1 (cdr w1)))
+ (if (null? m1)
+ (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2))))
+ (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2)))))))
+ (join-marks (lambda (m1 m2) (smart-append m1 m2)))
+ (same-marks?
+ (lambda (x y)
+ (or (eq? x y)
+ (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y))
+ (same-marks? (cdr x) (cdr y))))))
+ (id-var-name
+ (lambda (id w mod)
+ (letrec*
+ ((search
+ (lambda (sym subst marks mod)
+ (if (null? subst)
+ (values #f marks)
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (search sym (cdr subst) (cdr marks) mod)
+ (let ((symnames (ribcage-symnames fst)))
+ (if (vector? symnames)
+ (search-vector-rib sym subst marks symnames fst mod)
+ (search-list-rib sym subst marks symnames fst mod))))))))
+ (search-list-rib
+ (lambda (sym subst marks symnames ribcage mod)
+ (let f ((symnames symnames) (i 0))
+ (cond ((null? symnames) (search sym (cdr subst) marks mod))
+ ((and (eq? (car symnames) sym)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (let ((n (list-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (+ i 1)))
+ (values n marks))))
+ (else (f (cdr symnames) (+ i 1)))))))
+ (search-vector-rib
+ (lambda (sym subst marks symnames ribcage mod)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0))
+ (cond ((= i n) (search sym (cdr subst) marks mod))
+ ((and (eq? (vector-ref symnames i) sym)
+ (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
+ (let ((n (vector-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1)))
+ (values n marks))))
+ (else (f (+ i 1)))))))))
+ (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id))
+ ((syntax-object? id)
+ (let ((id (syntax-object-expression id))
+ (w1 (syntax-object-wrap id))
+ (mod (syntax-object-module id)))
+ (let ((marks (join-marks (car w) (car w1))))
+ (call-with-values
+ (lambda () (search id (cdr w) marks mod))
+ (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id))))))
+ (else (syntax-violation 'id-var-name "invalid id" id))))))
+ (locally-bound-identifiers
+ (lambda (w mod)
+ (letrec*
+ ((scan (lambda (subst results)
+ (if (null? subst)
+ results
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (scan (cdr subst) results)
+ (let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst)))
+ (if (vector? symnames)
+ (scan-vector-rib subst symnames marks results)
+ (scan-list-rib subst symnames marks results))))))))
+ (scan-list-rib
+ (lambda (subst symnames marks results)
+ (let f ((symnames symnames) (marks marks) (results results))
+ (if (null? symnames)
+ (scan (cdr subst) results)
+ (f (cdr symnames)
+ (cdr marks)
+ (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod)
+ results))))))
+ (scan-vector-rib
+ (lambda (subst symnames marks results)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0) (results results))
+ (if (= i n)
+ (scan (cdr subst) results)
+ (f (+ i 1)
+ (cons (wrap (vector-ref symnames i)
+ (anti-mark (cons (vector-ref marks i) subst))
+ mod)
+ results))))))))
+ (scan (cdr w) '()))))
+ (resolve-identifier
+ (lambda (id w r mod resolve-syntax-parameters?)
+ (letrec*
+ ((resolve-syntax-parameters
+ (lambda (b)
+ (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter))
+ (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b))))
+ b)))
+ (resolve-global
+ (lambda (var mod)
+ (let ((b (resolve-syntax-parameters
+ (or (get-global-definition-hook var mod) '(global)))))
+ (if (eq? (car b) 'global)
+ (values 'global var mod)
+ (values (car b) (cdr b) mod)))))
+ (resolve-lexical
+ (lambda (label mod)
+ (let ((b (resolve-syntax-parameters
+ (or (assq-ref r label) '(displaced-lexical)))))
+ (values (car b) (cdr b) mod)))))
+ (let ((n (id-var-name id w mod)))
+ (cond ((syntax-object? n)
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
+ ((symbol? n)
+ (resolve-global
+ n
+ (if (syntax-object? id) (syntax-object-module id) mod)))
+ ((string? n)
+ (resolve-lexical
+ n
+ (if (syntax-object? id) (syntax-object-module id) mod)))
+ (else (error "unexpected id-var-name" id w n)))))))
+ (transformer-environment
+ (make-fluid
+ (lambda (k)
+ (error "called outside the dynamic extent of a syntax transformer"))))
+ (with-transformer-environment
+ (lambda (k) ((fluid-ref transformer-environment) k)))
+ (free-id=?
+ (lambda (i j)
+ (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
+ (mj (and (syntax-object? j) (syntax-object-module j)))
+ (ni (id-var-name i '(()) mi))
+ (nj (id-var-name j '(()) mj)))
(letrec*
- ((scan-18244
- (lambda (subst-18249 results-18250)
- (if (null? subst-18249)
- results-18250
- (let ((fst-18251 (car subst-18249)))
- (if (eq? fst-18251 'shift)
- (scan-18244 (cdr subst-18249) results-18250)
- (let ((symnames-18253 (vector-ref fst-18251 1))
- (marks-18254 (vector-ref fst-18251 2)))
- (if (vector? symnames-18253)
- (scan-vector-rib-18246
- subst-18249
- symnames-18253
- marks-18254
- results-18250)
- (scan-list-rib-18245
- subst-18249
- symnames-18253
- marks-18254
- results-18250))))))))
- (scan-list-rib-18245
- (lambda (subst-18371
- symnames-18372
- marks-18373
- results-18374)
- (letrec*
- ((f-18375
- (lambda (symnames-18560 marks-18561 results-18562)
- (if (null? symnames-18560)
- (scan-18244 (cdr subst-18371) results-18562)
- (f-18375
- (cdr symnames-18560)
- (cdr marks-18561)
- (cons (let ((x-18568 (car symnames-18560))
- (w-18569
- (let ((w-18573
- (cons (car marks-18561)
- subst-18371)))
- (cons (cons #f (car w-18573))
- (cons 'shift
- (cdr w-18573))))))
- (if (if (null? (car w-18569))
- (null? (cdr w-18569))
- #f)
- x-18568
- (if (if (vector? x-18568)
- (if (= (vector-length x-18568) 4)
- (eq? (vector-ref x-18568 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-18585
- (vector-ref x-18568 1))
- (wrap-18586
- (let ((w2-18594
- (vector-ref x-18568 2)))
- (let ((m1-18595 (car w-18569))
- (s1-18596
- (cdr w-18569)))
- (if (null? m1-18595)
- (if (null? s1-18596)
- w2-18594
- (cons (car w2-18594)
- (let ((m2-18607
- (cdr w2-18594)))
- (if (null? m2-18607)
- s1-18596
- (append
- s1-18596
- m2-18607)))))
- (cons (let ((m2-18615
- (car w2-18594)))
- (if (null? m2-18615)
- m1-18595
- (append
- m1-18595
- m2-18615)))
- (let ((m2-18623
- (cdr w2-18594)))
- (if (null? m2-18623)
- s1-18596
- (append
- s1-18596
- m2-18623))))))))
- (module-18587
- (vector-ref x-18568 3)))
- (vector
- 'syntax-object
- expression-18585
- wrap-18586
- module-18587))
- (if (null? x-18568)
- x-18568
- (vector
- 'syntax-object
- x-18568
- w-18569
- mod-18243)))))
- results-18562))))))
- (f-18375
- symnames-18372
- marks-18373
- results-18374))))
- (scan-vector-rib-18246
- (lambda (subst-18636
- symnames-18637
- marks-18638
- results-18639)
- (let ((n-18640 (vector-length symnames-18637)))
- (letrec*
- ((f-18641
- (lambda (i-18812 results-18813)
- (if (= i-18812 n-18640)
- (scan-18244 (cdr subst-18636) results-18813)
- (f-18641
- (#{1+}# i-18812)
- (cons (let ((x-18819
- (vector-ref symnames-18637 i-18812))
- (w-18820
- (let ((w-18824
- (cons (vector-ref
- marks-18638
- i-18812)
- subst-18636)))
- (cons (cons #f (car w-18824))
- (cons 'shift
- (cdr w-18824))))))
- (if (if (null? (car w-18820))
- (null? (cdr w-18820))
- #f)
- x-18819
- (if (if (vector? x-18819)
- (if (= (vector-length x-18819) 4)
- (eq? (vector-ref x-18819 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-18836
- (vector-ref x-18819 1))
- (wrap-18837
- (let ((w2-18845
- (vector-ref
- x-18819
- 2)))
- (let ((m1-18846
- (car w-18820))
- (s1-18847
- (cdr w-18820)))
- (if (null? m1-18846)
- (if (null? s1-18847)
- w2-18845
- (cons (car w2-18845)
- (let ((m2-18858
- (cdr w2-18845)))
- (if (null? m2-18858)
- s1-18847
- (append
- s1-18847
- m2-18858)))))
- (cons (let ((m2-18866
- (car w2-18845)))
- (if (null? m2-18866)
- m1-18846
- (append
- m1-18846
- m2-18866)))
- (let ((m2-18874
- (cdr w2-18845)))
- (if (null? m2-18874)
- s1-18847
- (append
- s1-18847
- m2-18874))))))))
- (module-18838
- (vector-ref x-18819 3)))
- (vector
- 'syntax-object
- expression-18836
- wrap-18837
- module-18838))
- (if (null? x-18819)
- x-18819
- (vector
- 'syntax-object
- x-18819
- w-18820
- mod-18243)))))
- results-18813))))))
- (f-18641 0 results-18639))))))
- (scan-18244 (cdr w-18242) '()))))
- (resolve-identifier-4368
- (lambda (id-18887
- w-18888
- r-18889
- mod-18890
- resolve-syntax-parameters?-18891)
- (let ((n-18895
- (id-var-name-4366 id-18887 w-18888 mod-18890)))
- (if (if (vector? n-18895)
- (if (= (vector-length n-18895) 4)
- (eq? (vector-ref n-18895 0) 'syntax-object)
- #f)
- #f)
- (resolve-identifier-4368
- n-18895
- w-18888
- r-18889
- mod-18890
- resolve-syntax-parameters?-18891)
- (if (symbol? n-18895)
- (let ((mod-18910
- (if (if (vector? id-18887)
- (if (= (vector-length id-18887) 4)
- (eq? (vector-ref id-18887 0) 'syntax-object)
- #f)
- #f)
- (vector-ref id-18887 3)
- mod-18890)))
- (let ((b-18911
- (let ((b-18914
- (let ((t-18915
- (begin
- (if (if (not mod-18910)
- (current-module)
- #f)
- (warn "module system is booted, we should have a module"
- n-18895))
- (let ((v-18964
- (module-variable
- (if mod-18910
- (resolve-module
- (cdr mod-18910))
- (current-module))
- n-18895)))
- (if v-18964
- (if (variable-bound? v-18964)
- (let ((val-18973
- (variable-ref
- v-18964)))
- (if (macro? val-18973)
- (if (macro-type val-18973)
- (cons (macro-type
- val-18973)
- (macro-binding
- val-18973))
- #f)
- #f))
- #f)
- #f)))))
- (if t-18915 t-18915 '(global)))))
- (if (if resolve-syntax-parameters?-18891
- (eq? (car b-18914) 'syntax-parameter)
- #f)
- (let ((t-18982 (assq-ref r-18889 (cdr b-18914))))
- (if t-18982
- t-18982
- (cons 'macro (car (cdr b-18914)))))
- b-18914))))
- (if (eq? (car b-18911) 'global)
- (values 'global n-18895 mod-18910)
- (values (car b-18911) (cdr b-18911) mod-18910))))
- (if (string? n-18895)
- (let ((mod-18988
- (if (if (vector? id-18887)
- (if (= (vector-length id-18887) 4)
- (eq? (vector-ref id-18887 0) 'syntax-object)
- #f)
- #f)
- (vector-ref id-18887 3)
- mod-18890)))
- (let ((b-18989
- (let ((b-18992
- (let ((t-18993 (assq-ref r-18889 n-18895)))
- (if t-18993
- t-18993
- '(displaced-lexical)))))
- (if (if resolve-syntax-parameters?-18891
- (eq? (car b-18992) 'syntax-parameter)
- #f)
- (let ((t-18994
- (assq-ref r-18889 (cdr b-18992))))
- (if t-18994
- t-18994
- (cons 'macro (car (cdr b-18992)))))
- b-18992))))
- (values (car b-18989) (cdr b-18989) mod-18988)))
- (error "unexpected id-var-name"
- id-18887
- w-18888
- n-18895)))))))
- (free-id=?-4371
- (lambda (i-19007 j-19008)
- (let ((mi-19009
- (if (if (vector? i-19007)
- (if (= (vector-length i-19007) 4)
- (eq? (vector-ref i-19007 0) 'syntax-object)
- #f)
- #f)
- (vector-ref i-19007 3)
- #f)))
- (let ((mj-19010
- (if (if (vector? j-19008)
- (if (= (vector-length j-19008) 4)
- (eq? (vector-ref j-19008 0) 'syntax-object)
- #f)
- #f)
- (vector-ref j-19008 3)
- #f)))
- (let ((ni-19011
- (id-var-name-4366 i-19007 '(()) mi-19009)))
- (let ((nj-19012
- (id-var-name-4366 j-19008 '(()) mj-19010)))
- (if (if (vector? ni-19011)
- (if (= (vector-length ni-19011) 4)
- (eq? (vector-ref ni-19011 0) 'syntax-object)
- #f)
- #f)
- (free-id=?-4371 ni-19011 j-19008)
- (if (if (vector? nj-19012)
- (if (= (vector-length nj-19012) 4)
- (eq? (vector-ref nj-19012 0) 'syntax-object)
- #f)
- #f)
- (free-id=?-4371 i-19007 nj-19012)
- (if (symbol? ni-19011)
- (if (eq? nj-19012
- (if (if (vector? j-19008)
- (if (= (vector-length j-19008) 4)
- (eq? (vector-ref j-19008 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref j-19008 1)
- j-19008))
- (if (let ((bi-19084
- (module-variable
- (if mi-19009
- (resolve-module (cdr mi-19009))
- (current-module))
- (if (if (vector? i-19007)
- (if (= (vector-length i-19007) 4)
- (eq? (vector-ref i-19007 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref i-19007 1)
- i-19007))))
- (if bi-19084
- (eq? bi-19084
- (module-variable
- (if mj-19010
- (resolve-module (cdr mj-19010))
- (current-module))
- (if (if (vector? j-19008)
- (if (= (vector-length j-19008) 4)
- (eq? (vector-ref j-19008 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref j-19008 1)
- j-19008)))
- (if (not (module-variable
- (if mj-19010
- (resolve-module (cdr mj-19010))
- (current-module))
- (if (if (vector? j-19008)
- (if (= (vector-length
- j-19008)
- 4)
- (eq? (vector-ref j-19008 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref j-19008 1)
- j-19008)))
- (eq? ni-19011 nj-19012)
- #f)))
- (eq? (module-variable
- (if mi-19009
- (resolve-module (cdr mi-19009))
- (current-module))
- (if (if (vector? i-19007)
- (if (= (vector-length i-19007) 4)
- (eq? (vector-ref i-19007 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref i-19007 1)
- i-19007))
- (module-variable
- (if mj-19010
- (resolve-module (cdr mj-19010))
- (current-module))
- (if (if (vector? j-19008)
- (if (= (vector-length j-19008) 4)
- (eq? (vector-ref j-19008 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref j-19008 1)
- j-19008)))
- #f)
- #f)
- (equal? ni-19011 nj-19012))))))))))
- (bound-id=?-4372
- (lambda (i-19277 j-19278)
- (if (if (if (vector? i-19277)
- (if (= (vector-length i-19277) 4)
- (eq? (vector-ref i-19277 0) 'syntax-object)
- #f)
- #f)
- (if (vector? j-19278)
- (if (= (vector-length j-19278) 4)
- (eq? (vector-ref j-19278 0) 'syntax-object)
- #f)
- #f)
- #f)
- (if (eq? (vector-ref i-19277 1)
- (vector-ref j-19278 1))
- (same-marks?-4365
- (car (vector-ref i-19277 2))
- (car (vector-ref j-19278 2)))
- #f)
- (eq? i-19277 j-19278))))
- (valid-bound-ids?-4373
- (lambda (ids-19447)
- (if (letrec*
- ((all-ids?-19448
- (lambda (ids-19645)
- (if (null? ids-19645)
- (null? ids-19645)
- (if (let ((x-19656 (car ids-19645)))
- (if (symbol? x-19656)
- #t
- (if (if (vector? x-19656)
- (if (= (vector-length x-19656) 4)
- (eq? (vector-ref x-19656 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-19656 1))
- #f)))
- (all-ids?-19448 (cdr ids-19645))
- #f)))))
- (all-ids?-19448 ids-19447))
- (distinct-bound-ids?-4374 ids-19447)
- #f)))
- (distinct-bound-ids?-4374
- (lambda (ids-19777)
+ ((id-module-binding
+ (lambda (id mod)
+ (module-variable
+ (if mod (resolve-module (cdr mod)) (current-module))
+ (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x))))))
+ (cond ((syntax-object? ni) (free-id=? ni j))
+ ((syntax-object? nj) (free-id=? i nj))
+ ((symbol? ni)
+ (and (eq? nj
+ (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
+ (let ((bi (id-module-binding i mi)))
+ (if bi
+ (eq? bi (id-module-binding j mj))
+ (and (not (id-module-binding j mj)) (eq? ni nj))))
+ (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (else (equal? ni nj)))))))
+ (bound-id=?
+ (lambda (i j)
+ (if (and (syntax-object? i) (syntax-object? j))
+ (and (eq? (syntax-object-expression i) (syntax-object-expression j))
+ (same-marks?
+ (car (syntax-object-wrap i))
+ (car (syntax-object-wrap j))))
+ (eq? i j))))
+ (valid-bound-ids?
+ (lambda (ids)
+ (and (let all-ids? ((ids ids))
+ (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids)))))
+ (distinct-bound-ids? ids))))
+ (distinct-bound-ids?
+ (lambda (ids)
+ (let distinct? ((ids ids))
+ (or (null? ids)
+ (and (not (bound-id-member? (car ids) (cdr ids)))
+ (distinct? (cdr ids)))))))
+ (bound-id-member?
+ (lambda (x list)
+ (and (not (null? list))
+ (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
+ (wrap (lambda (x w defmod)
+ (cond ((and (null? (car w)) (null? (cdr w))) x)
+ ((syntax-object? x)
+ (make-syntax-object
+ (syntax-object-expression x)
+ (join-wraps w (syntax-object-wrap x))
+ (syntax-object-module x)))
+ ((null? x) x)
+ (else (make-syntax-object x w defmod)))))
+ (source-wrap
+ (lambda (x w s defmod) (wrap (decorate-source x s) w defmod)))
+ (expand-sequence
+ (lambda (body r w s mod)
+ (build-sequence
+ s
+ (let dobody ((body body) (r r) (w w) (mod mod))
+ (if (null? body)
+ '()
+ (let ((first (expand (car body) r w mod)))
+ (cons first (dobody (cdr body) r w mod))))))))
+ (expand-top-sequence
+ (lambda (body r w s m esew mod)
+ (let* ((r (cons '("placeholder" placeholder) r))
+ (ribcage (make-ribcage '() '() '()))
+ (w (cons (car w) (cons ribcage (cdr w)))))
(letrec*
- ((distinct?-19778
- (lambda (ids-19883)
- (if (null? ids-19883)
- (null? ids-19883)
- (if (not (bound-id-member?-4375
- (car ids-19883)
- (cdr ids-19883)))
- (distinct?-19778 (cdr ids-19883))
- #f)))))
- (distinct?-19778 ids-19777))))
- (bound-id-member?-4375
- (lambda (x-19979 list-19980)
- (if (not (null? list-19980))
- (let ((t-19981
- (bound-id=?-4372 x-19979 (car list-19980))))
- (if t-19981
- t-19981
- (bound-id-member?-4375 x-19979 (cdr list-19980))))
- #f)))
- (source-wrap-4377
- (lambda (x-20159 w-20160 s-20161 defmod-20162)
- (let ((x-20166
- (begin
- (if (if s-20161
- (supports-source-properties? x-20159)
- #f)
- (set-source-properties! x-20159 s-20161))
- x-20159)))
- (if (if (null? (car w-20160))
- (null? (cdr w-20160))
- #f)
- x-20166
- (if (if (vector? x-20166)
- (if (= (vector-length x-20166) 4)
- (eq? (vector-ref x-20166 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-20198 (vector-ref x-20166 1))
- (wrap-20199
- (let ((w2-20207 (vector-ref x-20166 2)))
- (let ((m1-20208 (car w-20160))
- (s1-20209 (cdr w-20160)))
- (if (null? m1-20208)
- (if (null? s1-20209)
- w2-20207
- (cons (car w2-20207)
- (let ((m2-20224 (cdr w2-20207)))
- (if (null? m2-20224)
- s1-20209
- (append s1-20209 m2-20224)))))
- (cons (let ((m2-20232 (car w2-20207)))
- (if (null? m2-20232)
- m1-20208
- (append m1-20208 m2-20232)))
- (let ((m2-20240 (cdr w2-20207)))
- (if (null? m2-20240)
- s1-20209
- (append s1-20209 m2-20240))))))))
- (module-20200 (vector-ref x-20166 3)))
- (vector
- 'syntax-object
- expression-20198
- wrap-20199
- module-20200))
- (if (null? x-20166)
- x-20166
- (vector
- 'syntax-object
- x-20166
- w-20160
- defmod-20162)))))))
- (expand-sequence-4378
- (lambda (body-34633 r-34634 w-34635 s-34636 mod-34637)
- (build-sequence-4329
- s-34636
- (letrec*
- ((dobody-34772
- (lambda (body-35078 r-35079 w-35080 mod-35081)
- (if (null? body-35078)
- '()
- (let ((first-35082
- (let ((e-35086 (car body-35078)))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-35086
- r-35079
- w-35080
- (let ((props-35096
- (source-properties
- (if (if (vector? e-35086)
- (if (= (vector-length
- e-35086)
- 4)
- (eq? (vector-ref
- e-35086
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref e-35086 1)
- e-35086))))
- (if (pair? props-35096) props-35096 #f))
- #f
- mod-35081
- #f))
- (lambda (type-35119
- value-35120
- form-35121
- e-35122
- w-35123
- s-35124
- mod-35125)
- (expand-expr-4384
- type-35119
- value-35120
- form-35121
- e-35122
- r-35079
- w-35123
- s-35124
- mod-35125))))))
- (cons first-35082
- (dobody-34772
- (cdr body-35078)
- r-35079
- w-35080
- mod-35081)))))))
- (dobody-34772
- body-34633
- r-34634
- w-34635
- mod-34637)))))
- (expand-top-sequence-4379
- (lambda (body-20269
- r-20270
- w-20271
- s-20272
- m-20273
- esew-20274
- mod-20275)
- (let ((r-20276
- (cons '("placeholder" placeholder) r-20270)))
- (let ((ribcage-20277 (vector 'ribcage '() '() '())))
- (let ((w-20278
- (cons (car w-20271)
- (cons ribcage-20277 (cdr w-20271)))))
- (letrec*
- ((record-definition!-20279
- (lambda (id-23483 var-23484)
- (let ((mod-23485
- (cons 'hygiene (module-name (current-module)))))
- (let ((label-23491
- (cons (vector-ref id-23483 3)
- (if (if (vector? var-23484)
- (if (= (vector-length var-23484) 4)
- (eq? (vector-ref var-23484 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-23553
- (vector-ref var-23484 1))
- (wrap-23554
- (let ((w2-23564
- (vector-ref
- var-23484
- 2)))
- (cons (let ((m2-23571
- (car w2-23564)))
- (if (null? m2-23571)
- '(top)
- (append
- '(top)
- m2-23571)))
- (let ((m2-23580
- (cdr w2-23564)))
- (if (null? m2-23580)
- '()
- (append
- '()
- m2-23580))))))
- (module-23555
- (vector-ref var-23484 3)))
- (vector
- 'syntax-object
- expression-23553
- wrap-23554
- module-23555))
- (if (null? var-23484)
- var-23484
- (vector
- 'syntax-object
- var-23484
- '((top))
- mod-23485))))))
- (begin
- (let ((update-23494
- (cons (vector-ref id-23483 1)
- (vector-ref ribcage-20277 1))))
- (vector-set! ribcage-20277 1 update-23494))
- (let ((update-23509
- (cons (car (vector-ref id-23483 2))
- (vector-ref ribcage-20277 2))))
- (vector-set! ribcage-20277 2 update-23509))
- (let ((update-23524
- (cons label-23491
- (vector-ref ribcage-20277 3))))
- (vector-set! ribcage-20277 3 update-23524)))))))
- (parse-20282
- (lambda (body-20479
- r-20480
- w-20481
- s-20482
- m-20483
- esew-20484
- mod-20485)
- (letrec*
- ((lp-20486
- (lambda (body-20726 exps-20727)
- (if (null? body-20726)
- exps-20727
- (lp-20486
- (cdr body-20726)
- (append
- (parse1-20283
- (car body-20726)
- r-20480
- w-20481
- s-20482
- m-20483
- esew-20484
- mod-20485)
- exps-20727))))))
- (lp-20486 body-20479 '()))))
- (parse1-20283
- (lambda (x-20969
- r-20970
- w-20971
- s-20972
- m-20973
- esew-20974
- mod-20975)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- x-20969
- r-20970
- w-20971
- (let ((props-20982
- (source-properties
- (if (if (vector? x-20969)
- (if (= (vector-length x-20969) 4)
- (eq? (vector-ref x-20969 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-20969 1)
- x-20969))))
- (if (pair? props-20982) props-20982 #f))
- ribcage-20277
- mod-20975
- #f))
- (lambda (type-21005
- value-21006
- form-21007
- e-21008
- w-21009
- s-21010
- mod-21011)
- (if (eqv? type-21005 'define-form)
- (let ((id-21019
- (if (if (null? (car w-21009))
- (null? (cdr w-21009))
- #f)
- value-21006
- (if (if (vector? value-21006)
- (if (= (vector-length value-21006)
- 4)
- (eq? (vector-ref value-21006 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-21069
- (vector-ref value-21006 1))
- (wrap-21070
- (let ((w2-21080
- (vector-ref
- value-21006
- 2)))
- (let ((m1-21081
- (car w-21009))
- (s1-21082
- (cdr w-21009)))
- (if (null? m1-21081)
- (if (null? s1-21082)
- w2-21080
- (cons (car w2-21080)
- (let ((m2-21099
- (cdr w2-21080)))
- (if (null? m2-21099)
- s1-21082
- (append
- s1-21082
- m2-21099)))))
- (cons (let ((m2-21107
- (car w2-21080)))
- (if (null? m2-21107)
- m1-21081
- (append
- m1-21081
- m2-21107)))
- (let ((m2-21115
- (cdr w2-21080)))
- (if (null? m2-21115)
- s1-21082
- (append
- s1-21082
- m2-21115))))))))
- (module-21071
- (vector-ref value-21006 3)))
- (vector
- 'syntax-object
- expression-21069
- wrap-21070
- module-21071))
- (if (null? value-21006)
- value-21006
- (vector
- 'syntax-object
- value-21006
- w-21009
- mod-21011))))))
- (begin
- (string-append
- "l-"
- (session-id-4308)
- (symbol->string (gensym "-")))
- (let ((var-21021
- (if (not (equal?
- (car (vector-ref
- id-21019
- 2))
- '(top)))
- (symbol-append
- (vector-ref id-21019 1)
- '-
- (string->symbol
- (number->string
- (hash (syntax->datum x-20969)
- most-positive-fixnum)
- 16)))
- (vector-ref id-21019 1))))
- (begin
- (record-definition!-20279
- id-21019
- var-21021)
- (list (if (eq? m-20973 'c&e)
- (let ((x-21241
- (let ((exp-21251
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-21008
- r-20970
- w-21009
- (let ((props-21272
- (source-properties
- (if (if (vector?
- e-21008)
- (if (= (vector-length
- e-21008)
- 4)
- (eq? (vector-ref
- e-21008
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-21008
- 1)
- e-21008))))
- (if (pair? props-21272)
- props-21272
- #f))
- #f
- mod-21011
- #f))
- (lambda (type-21305
- value-21306
- form-21307
- e-21308
- w-21309
- s-21310
- mod-21311)
- (expand-expr-4384
- type-21305
- value-21306
- form-21307
- e-21308
- r-20970
- w-21309
- s-21310
- mod-21311)))))
- (begin
- (if (if (struct?
- exp-21251)
- (eq? (struct-vtable
- exp-21251)
- (vector-ref
- %expanded-vtables
- 14))
- #f)
- (let ((meta-21323
- (struct-ref
- exp-21251
- 1)))
- (if (not (assq 'name
- meta-21323))
- (let ((v-21330
- (cons (cons 'name
- var-21021)
- meta-21323)))
- (struct-set!
- exp-21251
- 1
- v-21330)))))
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 9)
- s-21010
- var-21021
- exp-21251)))))
- (begin
- (primitive-eval x-21241)
- (lambda () x-21241)))
- (lambda ()
- (let ((exp-21346
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-21008
- r-20970
- w-21009
- (let ((props-21367
- (source-properties
- (if (if (vector?
- e-21008)
- (if (= (vector-length
- e-21008)
- 4)
- (eq? (vector-ref
- e-21008
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-21008
- 1)
- e-21008))))
- (if (pair? props-21367)
- props-21367
- #f))
- #f
- mod-21011
- #f))
- (lambda (type-21400
- value-21401
- form-21402
- e-21403
- w-21404
- s-21405
- mod-21406)
- (expand-expr-4384
- type-21400
- value-21401
- form-21402
- e-21403
- r-20970
- w-21404
- s-21405
- mod-21406)))))
- (begin
- (if (if (struct? exp-21346)
- (eq? (struct-vtable
- exp-21346)
- (vector-ref
- %expanded-vtables
- 14))
- #f)
- (let ((meta-21418
- (struct-ref
- exp-21346
- 1)))
- (if (not (assq 'name
- meta-21418))
- (let ((v-21425
- (cons (cons 'name
- var-21021)
- meta-21418)))
- (struct-set!
- exp-21346
- 1
- v-21425)))))
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 9)
- s-21010
- var-21021
- exp-21346))))))))))
- (if (if (eqv? type-21005 'define-syntax-form)
- #t
- (eqv? type-21005
- 'define-syntax-parameter-form))
- (let ((id-21450
- (if (if (null? (car w-21009))
- (null? (cdr w-21009))
- #f)
- value-21006
- (if (if (vector? value-21006)
- (if (= (vector-length
- value-21006)
- 4)
- (eq? (vector-ref value-21006 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-21500
- (vector-ref value-21006 1))
- (wrap-21501
- (let ((w2-21511
- (vector-ref
- value-21006
- 2)))
- (let ((m1-21512
- (car w-21009))
- (s1-21513
- (cdr w-21009)))
- (if (null? m1-21512)
- (if (null? s1-21513)
- w2-21511
- (cons (car w2-21511)
- (let ((m2-21530
- (cdr w2-21511)))
- (if (null? m2-21530)
- s1-21513
- (append
- s1-21513
- m2-21530)))))
- (cons (let ((m2-21538
- (car w2-21511)))
- (if (null? m2-21538)
- m1-21512
- (append
- m1-21512
- m2-21538)))
- (let ((m2-21546
- (cdr w2-21511)))
- (if (null? m2-21546)
- s1-21513
- (append
- s1-21513
- m2-21546))))))))
- (module-21502
- (vector-ref value-21006 3)))
- (vector
- 'syntax-object
- expression-21500
- wrap-21501
- module-21502))
- (if (null? value-21006)
- value-21006
- (vector
- 'syntax-object
- value-21006
- w-21009
- mod-21011))))))
- (begin
- (string-append
- "l-"
- (session-id-4308)
- (symbol->string (gensym "-")))
- (let ((var-21452
- (if (not (equal?
- (car (vector-ref
- id-21450
- 2))
- '(top)))
- (symbol-append
- (vector-ref id-21450 1)
- '-
- (string->symbol
- (number->string
- (hash (syntax->datum x-20969)
- most-positive-fixnum)
- 16)))
- (vector-ref id-21450 1))))
- (begin
- (record-definition!-20279
- id-21450
- var-21452)
- (if (eqv? m-20973 'c)
- (if (memq 'compile esew-20974)
- (let ((e-21679
- (expand-install-global-4380
- var-21452
- type-21005
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-21008
- r-20970
- w-21009
- (let ((props-21939
- (source-properties
- (if (if (vector?
- e-21008)
- (if (= (vector-length
- e-21008)
- 4)
- (eq? (vector-ref
- e-21008
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-21008
- 1)
- e-21008))))
- (if (pair? props-21939)
- props-21939
- #f))
- #f
- mod-21011
- #f))
- (lambda (type-21972
- value-21973
- form-21974
- e-21975
- w-21976
- s-21977
- mod-21978)
- (expand-expr-4384
- type-21972
- value-21973
- form-21974
- e-21975
- r-20970
- w-21976
- s-21977
- mod-21978))))))
- (begin
- (top-level-eval-hook-4306
- e-21679
- mod-21011)
- (if (memq 'load esew-20974)
- (list (lambda () e-21679))
- '())))
- (if (memq 'load esew-20974)
- (list (lambda ()
- (expand-install-global-4380
- var-21452
- type-21005
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-21008
- r-20970
- w-21009
- (let ((props-22095
- (source-properties
- (if (if (vector?
- e-21008)
- (if (= (vector-length
- e-21008)
- 4)
- (eq? (vector-ref
- e-21008
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-21008
- 1)
- e-21008))))
- (if (pair? props-22095)
- props-22095
- #f))
- #f
- mod-21011
- #f))
- (lambda (type-22128
- value-22129
- form-22130
- e-22131
- w-22132
- s-22133
- mod-22134)
- (expand-expr-4384
- type-22128
- value-22129
- form-22130
- e-22131
- r-20970
- w-22132
- s-22133
- mod-22134))))))
- '()))
- (if (eqv? m-20973 'c&e)
- (let ((e-22144
- (expand-install-global-4380
- var-21452
- type-21005
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-21008
- r-20970
- w-21009
- (let ((props-22404
- (source-properties
- (if (if (vector?
- e-21008)
- (if (= (vector-length
- e-21008)
- 4)
- (eq? (vector-ref
- e-21008
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-21008
- 1)
- e-21008))))
- (if (pair? props-22404)
- props-22404
- #f))
- #f
- mod-21011
- #f))
- (lambda (type-22437
- value-22438
- form-22439
- e-22440
- w-22441
- s-22442
- mod-22443)
- (expand-expr-4384
- type-22437
- value-22438
- form-22439
- e-22440
- r-20970
- w-22441
- s-22442
- mod-22443))))))
- (begin
- (top-level-eval-hook-4306
- e-22144
- mod-21011)
- (list (lambda () e-22144))))
- (begin
- (if (memq 'eval esew-20974)
- (top-level-eval-hook-4306
- (expand-install-global-4380
- var-21452
- type-21005
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-21008
- r-20970
- w-21009
- (let ((props-22662
- (source-properties
- (if (if (vector?
- e-21008)
- (if (= (vector-length
- e-21008)
- 4)
- (eq? (vector-ref
- e-21008
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-21008
- 1)
- e-21008))))
- (if (pair? props-22662)
- props-22662
- #f))
- #f
- mod-21011
- #f))
- (lambda (type-22695
- value-22696
- form-22697
- e-22698
- w-22699
- s-22700
- mod-22701)
- (expand-expr-4384
- type-22695
- value-22696
- form-22697
- e-22698
- r-20970
- w-22699
- s-22700
- mod-22701))))
- mod-21011))
- '())))))))
- (if (eqv? type-21005 'begin-form)
- (let ((tmp-22715
- ($sc-dispatch
- e-21008
- '(_ . each-any))))
- (if tmp-22715
- (@apply
- (lambda (e1-22719)
- (parse-20282
- e1-22719
- r-20970
- w-21009
- s-21010
- m-20973
- esew-20974
- mod-21011))
- tmp-22715)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-21008)))
- (if (eqv? type-21005 'local-syntax-form)
- (expand-local-syntax-4388
- value-21006
- e-21008
- r-20970
- w-21009
- s-21010
- mod-21011
- (lambda (forms-22765
- r-22766
- w-22767
- s-22768
- mod-22769)
- (parse-20282
- forms-22765
- r-22766
- w-22767
- s-22768
- m-20973
- esew-20974
- mod-22769)))
- (if (eqv? type-21005 'eval-when-form)
- (let ((tmp-22808
- ($sc-dispatch
- e-21008
- '(_ each-any any . each-any))))
- (if tmp-22808
- (@apply
- (lambda (x-22812 e1-22813 e2-22814)
- (let ((when-list-22815
- (parse-when-list-4381
- e-21008
- x-22812))
- (body-22816
- (cons e1-22813 e2-22814)))
- (letrec*
- ((recurse-22817
- (lambda (m-23403 esew-23404)
- (parse-20282
- body-22816
- r-20970
- w-21009
- s-21010
- m-23403
- esew-23404
- mod-21011))))
- (if (eq? m-20973 'e)
- (if (memq 'eval
- when-list-22815)
- (recurse-22817
- (if (memq 'expand
- when-list-22815)
- 'c&e
- 'e)
- '(eval))
- (begin
- (if (memq 'expand
- when-list-22815)
- (let ((x-22924
- (expand-top-sequence-4379
- body-22816
- r-20970
- w-21009
- s-21010
- 'e
- '(eval)
- mod-21011)))
- (primitive-eval
- x-22924)))
- '()))
- (if (memq 'load
- when-list-22815)
- (if (let ((t-22952
- (memq 'compile
- when-list-22815)))
- (if t-22952
- t-22952
- (let ((t-23005
- (memq 'expand
- when-list-22815)))
- (if t-23005
- t-23005
- (if (eq? m-20973
- 'c&e)
- (memq 'eval
- when-list-22815)
- #f)))))
- (recurse-22817
- 'c&e
- '(compile load))
- (if (if (eq? m-20973 'c)
- #t
- (eq? m-20973 'c&e))
- (recurse-22817
- 'c
- '(load))
- '()))
- (if (let ((t-23214
- (memq 'compile
- when-list-22815)))
- (if t-23214
- t-23214
- (let ((t-23267
- (memq 'expand
- when-list-22815)))
- (if t-23267
- t-23267
- (if (eq? m-20973
- 'c&e)
- (memq 'eval
- when-list-22815)
- #f)))))
- (begin
- (let ((x-23401
- (expand-top-sequence-4379
- body-22816
- r-20970
- w-21009
- s-21010
- 'e
- '(eval)
- mod-21011)))
- (primitive-eval
- x-23401))
- '())
- '()))))))
- tmp-22808)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-21008)))
- (list (if (eq? m-20973 'c&e)
- (let ((x-23474
- (expand-expr-4384
- type-21005
- value-21006
- form-21007
- e-21008
- r-20970
- w-21009
- s-21010
- mod-21011)))
- (begin
- (primitive-eval x-23474)
- (lambda () x-23474)))
- (lambda ()
- (expand-expr-4384
- type-21005
- value-21006
- form-21007
- e-21008
- r-20970
- w-21009
- s-21010
- mod-21011))))))))))))))
- (let ((exps-20284
- (map (lambda (x-20408) (x-20408))
- (reverse
- (parse-20282
- body-20269
- r-20276
- w-20278
- s-20272
- m-20273
- esew-20274
- mod-20275)))))
- (if (null? exps-20284)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- s-20272)
- (build-sequence-4329 s-20272 exps-20284)))))))))
- (expand-install-global-4380
- (lambda (name-23602 type-23603 e-23604)
- (let ((exp-23610
- (let ((args-23621
- (if (eq? type-23603 'define-syntax-parameter-form)
- (list (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- name-23602)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
+ ((record-definition!
+ (lambda (id var)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ (extend-ribcage!
+ ribcage
+ id
+ (cons (syntax-object-module id) (wrap var '((top)) mod))))))
+ (macro-introduced-identifier?
+ (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top)))))
+ (fresh-derived-name
+ (lambda (id orig-form)
+ (symbol-append
+ (syntax-object-expression id)
+ '-
+ (string->symbol
+ (number->string
+ (hash (syntax->datum orig-form) most-positive-fixnum)
+ 16)))))
+ (parse (lambda (body r w s m esew mod)
+ (let lp ((body body) (exps '()))
+ (if (null? body)
+ exps
+ (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps))))))
+ (parse1
+ (lambda (x r w s m esew mod)
+ (call-with-values
+ (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (lambda (type value form e w s mod)
+ (let ((key type))
+ (cond ((memv key '(define-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda () (build-global-definition s var (expand e r w mod)))))))
+ ((memv key '(define-syntax-form define-syntax-parameter-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (let ((key m))
+ (cond ((memv key '(c))
+ (cond ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew) (list (lambda () e)) '())))
+ ((memq 'load esew)
+ (list (lambda () (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((memv key '(c&e))
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '())))))
+ ((memv key '(begin-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
+ (syntax-violation
#f
- 'syntax-parameter)
- (let ((args-23644 (list e-23604)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- #f
- 'list
- args-23644)))
- (list (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax
+ value
+ e
+ r
+ w
+ s
+ mod
+ (lambda (forms r w s mod) (parse forms r w s m esew mod))))
+ ((memv key '(eval-when-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
+ (if tmp
+ (apply (lambda (x e1 e2)
+ (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
+ (letrec*
+ ((recurse (lambda (m esew) (parse body r w s m esew mod))))
+ (cond ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
+ (begin
+ (if (memq 'expand when-list)
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (cond ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load)))
+ ((memq m '(c c&e)) (recurse 'c '(load)))
+ (else '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else '())))))
+ tmp)
+ (syntax-violation
#f
- name-23602)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
+ "source expression failed to match any pattern"
+ tmp-1))))
+ (else
+ (list (if (eq? m 'c&e)
+ (let ((x (expand-expr type value form e r w s mod)))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda () (expand-expr type value form e r w s mod))))))))))))
+ (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
+ (if (null? exps) (build-void s) (build-sequence s exps)))))))
+ (expand-install-global
+ (lambda (name type e)
+ (build-global-definition
+ #f
+ name
+ (build-primcall
+ #f
+ 'make-syntax-transformer
+ (if (eq? type 'define-syntax-parameter-form)
+ (list (build-data #f name)
+ (build-data #f 'syntax-parameter)
+ (build-primcall #f 'list (list e)))
+ (list (build-data #f name) (build-data #f 'macro) e))))))
+ (parse-when-list
+ (lambda (e when-list)
+ (let ((result (strip when-list '(()))))
+ (let lp ((l result))
+ (cond ((null? l) result)
+ ((memq (car l) '(compile load eval expand)) (lp (cdr l)))
+ (else (syntax-violation 'eval-when "invalid situation" e (car l))))))))
+ (syntax-type
+ (lambda (e r w s rib mod for-car?)
+ (cond ((symbol? e)
+ (call-with-values
+ (lambda () (resolve-identifier e w r mod #t))
+ (lambda (type value mod*)
+ (let ((key type))
+ (cond ((memv key '(macro))
+ (if for-car?
+ (values type value e e w s mod)
+ (syntax-type
+ (expand-macro value e r w s rib mod)
+ r
+ '(())
+ s
+ rib
+ mod
+ #f)))
+ ((memv key '(global)) (values type value e value w s mod*))
+ (else (values type value e e w s mod)))))))
+ ((pair? e)
+ (let ((first (car e)))
+ (call-with-values
+ (lambda () (syntax-type first r w s rib mod #t))
+ (lambda (ftype fval fform fe fw fs fmod)
+ (let ((key ftype))
+ (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod))
+ ((memv key '(global))
+ (values 'global-call (make-syntax-object fval w fmod) e e w s mod))
+ ((memv key '(macro))
+ (syntax-type
+ (expand-macro fval e r w s rib mod)
+ r
+ '(())
+ s
+ rib
+ mod
+ for-car?))
+ ((memv key '(module-ref))
+ (call-with-values
+ (lambda () (fval e r w))
+ (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?))))
+ ((memv key '(core)) (values 'core-form fval e e w s mod))
+ ((memv key '(local-syntax))
+ (values 'local-syntax-form fval e e w s mod))
+ ((memv key '(begin)) (values 'begin-form #f e e w s mod))
+ ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod))
+ ((memv key '(define))
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
+ (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1))
+ (apply (lambda (name val) (values 'define-form name e val w s mod))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any))))
+ (if (and tmp-1
+ (apply (lambda (name args e1 e2)
+ (and (id? name) (valid-bound-ids? (lambda-var-list args))))
+ tmp-1))
+ (apply (lambda (name args e1 e2)
+ (values
+ 'define-form
+ (wrap name w mod)
+ (wrap e w mod)
+ (decorate-source
+ (cons '#(syntax-object lambda ((top)) (hygiene guile))
+ (wrap (cons args (cons e1 e2)) w mod))
+ s)
+ '(())
+ s
+ mod))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any))))
+ (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1))
+ (apply (lambda (name)
+ (values
+ 'define-form
+ (wrap name w mod)
+ (wrap e w mod)
+ '(#(syntax-object if ((top)) (hygiene guile)) #f #f)
+ '(())
+ s
+ mod))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))
+ ((memv key '(define-syntax))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
+ (if (and tmp (apply (lambda (name val) (id? name)) tmp))
+ (apply (lambda (name val) (values 'define-syntax-form name e val w s mod))
+ tmp)
+ (syntax-violation
#f
- 'macro)
- e-23604))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- #f
- 'make-syntax-transformer
- args-23621))))
- (begin
- (if (if (struct? exp-23610)
- (eq? (struct-vtable exp-23610)
- (vector-ref %expanded-vtables 14))
- #f)
- (let ((meta-23671 (struct-ref exp-23610 1)))
- (if (not (assq 'name meta-23671))
- (let ((v-23678
- (cons (cons 'name name-23602) meta-23671)))
- (struct-set! exp-23610 1 v-23678)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 9)
- #f
- name-23602
- exp-23610)))))
- (parse-when-list-4381
- (lambda (e-23689 when-list-23690)
- (let ((result-23691 (strip-4396 when-list-23690 '(()))))
- (letrec*
- ((lp-23692
- (lambda (l-23758)
- (if (null? l-23758)
- result-23691
- (if (let ((t-23760 (car l-23758)))
- (if (eq? t-23760 'compile)
- #t
- (if (eq? t-23760 'load)
- #t
- (if (eq? t-23760 'eval)
- #t
- (eq? t-23760 'expand)))))
- (lp-23692 (cdr l-23758))
- (syntax-violation
- 'eval-when
- "invalid situation"
- e-23689
- (car l-23758)))))))
- (lp-23692 result-23691)))))
- (syntax-type-4382
- (lambda (e-23762
- r-23763
- w-23764
- s-23765
- rib-23766
- mod-23767
- for-car?-23768)
- (if (symbol? e-23762)
- (call-with-values
- (lambda ()
- (resolve-identifier-4368
- e-23762
- w-23764
- r-23763
- mod-23767
- #t))
- (lambda (type-23771 value-23772 mod*-23773)
- (if (eqv? type-23771 'macro)
- (if for-car?-23768
- (values
- type-23771
- value-23772
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)
- (syntax-type-4382
- (expand-macro-4386
- value-23772
- e-23762
- r-23763
- w-23764
- s-23765
- rib-23766
- mod-23767)
- r-23763
- '(())
- s-23765
- rib-23766
- mod-23767
- #f))
- (if (eqv? type-23771 'global)
- (values
- type-23771
- value-23772
- e-23762
- value-23772
- w-23764
- s-23765
- mod*-23773)
- (values
- type-23771
- value-23772
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)))))
- (if (pair? e-23762)
- (let ((first-23789 (car e-23762)))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- first-23789
- r-23763
- w-23764
- s-23765
- rib-23766
- mod-23767
- #t))
- (lambda (ftype-23791
- fval-23792
- fform-23793
- fe-23794
- fw-23795
- fs-23796
- fmod-23797)
- (if (eqv? ftype-23791 'lexical)
- (values
- 'lexical-call
- fval-23792
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)
- (if (eqv? ftype-23791 'global)
- (values
- 'global-call
- (vector
- 'syntax-object
- fval-23792
- w-23764
- fmod-23797)
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)
- (if (eqv? ftype-23791 'macro)
- (syntax-type-4382
- (expand-macro-4386
- fval-23792
- e-23762
- r-23763
- w-23764
- s-23765
- rib-23766
- mod-23767)
- r-23763
- '(())
- s-23765
- rib-23766
- mod-23767
- for-car?-23768)
- (if (eqv? ftype-23791 'module-ref)
- (call-with-values
- (lambda () (fval-23792 e-23762 r-23763 w-23764))
- (lambda (e-23831
- r-23832
- w-23833
- s-23834
- mod-23835)
- (syntax-type-4382
- e-23831
- r-23832
- w-23833
- s-23834
- rib-23766
- mod-23835
- for-car?-23768)))
- (if (eqv? ftype-23791 'core)
- (values
- 'core-form
- fval-23792
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)
- (if (eqv? ftype-23791 'local-syntax)
- (values
- 'local-syntax-form
- fval-23792
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)
- (if (eqv? ftype-23791 'begin)
- (values
- 'begin-form
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key '(define-syntax-parameter))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
+ (if (and tmp (apply (lambda (name val) (id? name)) tmp))
+ (apply (lambda (name val)
+ (values 'define-syntax-parameter-form name e val w s mod))
+ tmp)
+ (syntax-violation
#f
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)
- (if (eqv? ftype-23791 'eval-when)
- (values
- 'eval-when-form
- #f
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)
- (if (eqv? ftype-23791 'define)
- (let ((tmp-23867
- ($sc-dispatch
- e-23762
- '(_ any any))))
- (if (if tmp-23867
- (@apply
- (lambda (name-23871 val-23872)
- (if (symbol? name-23871)
- #t
- (if (if (vector? name-23871)
- (if (= (vector-length
- name-23871)
- 4)
- (eq? (vector-ref
- name-23871
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-23871
- 1))
- #f)))
- tmp-23867)
- #f)
- (@apply
- (lambda (name-23899 val-23900)
- (values
- 'define-form
- name-23899
- e-23762
- val-23900
- w-23764
- s-23765
- mod-23767))
- tmp-23867)
- (let ((tmp-23901
- ($sc-dispatch
- e-23762
- '(_ (any . any)
- any
- .
- each-any))))
- (if (if tmp-23901
- (@apply
- (lambda (name-23905
- args-23906
- e1-23907
- e2-23908)
- (if (if (symbol?
- name-23905)
- #t
- (if (if (vector?
- name-23905)
- (if (= (vector-length
- name-23905)
- 4)
- (eq? (vector-ref
- name-23905
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-23905
- 1))
- #f))
- (valid-bound-ids?-4373
- (lambda-var-list-4398
- args-23906))
- #f))
- tmp-23901)
- #f)
- (@apply
- (lambda (name-24371
- args-24372
- e1-24373
- e2-24374)
- (values
- 'define-form
- (if (if (null? (car w-23764))
- (null? (cdr w-23764))
- #f)
- name-24371
- (if (if (vector?
- name-24371)
- (if (= (vector-length
- name-24371)
- 4)
- (eq? (vector-ref
- name-24371
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-24404
- (vector-ref
- name-24371
- 1))
- (wrap-24405
- (let ((w2-24415
- (vector-ref
- name-24371
- 2)))
- (let ((m1-24416
- (car w-23764))
- (s1-24417
- (cdr w-23764)))
- (if (null? m1-24416)
- (if (null? s1-24417)
- w2-24415
- (cons (car w2-24415)
- (let ((m2-24434
- (cdr w2-24415)))
- (if (null? m2-24434)
- s1-24417
- (append
- s1-24417
- m2-24434)))))
- (cons (let ((m2-24442
- (car w2-24415)))
- (if (null? m2-24442)
- m1-24416
- (append
- m1-24416
- m2-24442)))
- (let ((m2-24450
- (cdr w2-24415)))
- (if (null? m2-24450)
- s1-24417
- (append
- s1-24417
- m2-24450))))))))
- (module-24406
- (vector-ref
- name-24371
- 3)))
- (vector
- 'syntax-object
- expression-24404
- wrap-24405
- module-24406))
- (if (null? name-24371)
- name-24371
- (vector
- 'syntax-object
- name-24371
- w-23764
- mod-23767))))
- (if (if (null? (car w-23764))
- (null? (cdr w-23764))
- #f)
- e-23762
- (if (if (vector? e-23762)
- (if (= (vector-length
- e-23762)
- 4)
- (eq? (vector-ref
- e-23762
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-24502
- (vector-ref
- e-23762
- 1))
- (wrap-24503
- (let ((w2-24513
- (vector-ref
- e-23762
- 2)))
- (let ((m1-24514
- (car w-23764))
- (s1-24515
- (cdr w-23764)))
- (if (null? m1-24514)
- (if (null? s1-24515)
- w2-24513
- (cons (car w2-24513)
- (let ((m2-24532
- (cdr w2-24513)))
- (if (null? m2-24532)
- s1-24515
- (append
- s1-24515
- m2-24532)))))
- (cons (let ((m2-24540
- (car w2-24513)))
- (if (null? m2-24540)
- m1-24514
- (append
- m1-24514
- m2-24540)))
- (let ((m2-24548
- (cdr w2-24513)))
- (if (null? m2-24548)
- s1-24515
- (append
- s1-24515
- m2-24548))))))))
- (module-24504
- (vector-ref
- e-23762
- 3)))
- (vector
- 'syntax-object
- expression-24502
- wrap-24503
- module-24504))
- (if (null? e-23762)
- e-23762
- (vector
- 'syntax-object
- e-23762
- w-23764
- mod-23767))))
- (let ((e-24574
- (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(name
- args
- e1
- e2)
- #((top)
- (top)
- (top)
- (top))
- #("l-*-1960"
- "l-*-1961"
- "l-*-1962"
- "l-*-1963"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(key)
- #((m-*-1925
- top))
- #("l-*-1926"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(ftype
- fval
- fform
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1918"
- "l-*-1919"
- "l-*-1920"
- "l-*-1921"
- "l-*-1922"
- "l-*-1923"
- "l-*-1924"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(first)
- #((top))
- #("l-*-1909"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1891"
- "l-*-1892"
- "l-*-1893"
- "l-*-1894"
- "l-*-1895"
- "l-*-1896"
- "l-*-1897"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45"))
- #(ribcage
- ()
- ()
- ()))
- (hygiene
- guile))
- (let ((x-24580
- (cons args-24372
- (cons e1-24373
- e2-24374))))
- (if (if (null? (car w-23764))
- (null? (cdr w-23764))
- #f)
- x-24580
- (if (if (vector?
- x-24580)
- (if (= (vector-length
- x-24580)
- 4)
- (eq? (vector-ref
- x-24580
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-24598
- (vector-ref
- x-24580
- 1))
- (wrap-24599
- (let ((w2-24607
- (vector-ref
- x-24580
- 2)))
- (let ((m1-24608
- (car w-23764))
- (s1-24609
- (cdr w-23764)))
- (if (null? m1-24608)
- (if (null? s1-24609)
- w2-24607
- (cons (car w2-24607)
- (let ((m2-24624
- (cdr w2-24607)))
- (if (null? m2-24624)
- s1-24609
- (append
- s1-24609
- m2-24624)))))
- (cons (let ((m2-24632
- (car w2-24607)))
- (if (null? m2-24632)
- m1-24608
- (append
- m1-24608
- m2-24632)))
- (let ((m2-24640
- (cdr w2-24607)))
- (if (null? m2-24640)
- s1-24609
- (append
- s1-24609
- m2-24640))))))))
- (module-24600
- (vector-ref
- x-24580
- 3)))
- (vector
- 'syntax-object
- expression-24598
- wrap-24599
- module-24600))
- (if (null? x-24580)
- x-24580
- (vector
- 'syntax-object
- x-24580
- w-23764
- mod-23767))))))))
- (begin
- (if (if s-23765
- (supports-source-properties?
- e-24574)
- #f)
- (set-source-properties!
- e-24574
- s-23765))
- e-24574))
- '(())
- s-23765
- mod-23767))
- tmp-23901)
- (let ((tmp-24657
- ($sc-dispatch
- e-23762
- '(_ any))))
- (if (if tmp-24657
- (@apply
- (lambda (name-24661)
- (if (symbol?
- name-24661)
- #t
- (if (if (vector?
- name-24661)
- (if (= (vector-length
- name-24661)
- 4)
- (eq? (vector-ref
- name-24661
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-24661
- 1))
- #f)))
- tmp-24657)
- #f)
- (@apply
- (lambda (name-24688)
- (values
- 'define-form
- (if (if (null? (car w-23764))
- (null? (cdr w-23764))
- #f)
- name-24688
- (if (if (vector?
- name-24688)
- (if (= (vector-length
- name-24688)
- 4)
- (eq? (vector-ref
- name-24688
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-24718
- (vector-ref
- name-24688
- 1))
- (wrap-24719
- (let ((w2-24729
- (vector-ref
- name-24688
- 2)))
- (let ((m1-24730
- (car w-23764))
- (s1-24731
- (cdr w-23764)))
- (if (null? m1-24730)
- (if (null? s1-24731)
- w2-24729
- (cons (car w2-24729)
- (let ((m2-24748
- (cdr w2-24729)))
- (if (null? m2-24748)
- s1-24731
- (append
- s1-24731
- m2-24748)))))
- (cons (let ((m2-24756
- (car w2-24729)))
- (if (null? m2-24756)
- m1-24730
- (append
- m1-24730
- m2-24756)))
- (let ((m2-24764
- (cdr w2-24729)))
- (if (null? m2-24764)
- s1-24731
- (append
- s1-24731
- m2-24764))))))))
- (module-24720
- (vector-ref
- name-24688
- 3)))
- (vector
- 'syntax-object
- expression-24718
- wrap-24719
- module-24720))
- (if (null? name-24688)
- name-24688
- (vector
- 'syntax-object
- name-24688
- w-23764
- mod-23767))))
- (if (if (null? (car w-23764))
- (null? (cdr w-23764))
- #f)
- e-23762
- (if (if (vector?
- e-23762)
- (if (= (vector-length
- e-23762)
- 4)
- (eq? (vector-ref
- e-23762
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-24816
- (vector-ref
- e-23762
- 1))
- (wrap-24817
- (let ((w2-24827
- (vector-ref
- e-23762
- 2)))
- (let ((m1-24828
- (car w-23764))
- (s1-24829
- (cdr w-23764)))
- (if (null? m1-24828)
- (if (null? s1-24829)
- w2-24827
- (cons (car w2-24827)
- (let ((m2-24846
- (cdr w2-24827)))
- (if (null? m2-24846)
- s1-24829
- (append
- s1-24829
- m2-24846)))))
- (cons (let ((m2-24854
- (car w2-24827)))
- (if (null? m2-24854)
- m1-24828
- (append
- m1-24828
- m2-24854)))
- (let ((m2-24862
- (cdr w2-24827)))
- (if (null? m2-24862)
- s1-24829
- (append
- s1-24829
- m2-24862))))))))
- (module-24818
- (vector-ref
- e-23762
- 3)))
- (vector
- 'syntax-object
- expression-24816
- wrap-24817
- module-24818))
- (if (null? e-23762)
- e-23762
- (vector
- 'syntax-object
- e-23762
- w-23764
- mod-23767))))
- '(#(syntax-object
- if
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("l-*-1973"))
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-1925 top))
- #("l-*-1926"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fform
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1918"
- "l-*-1919"
- "l-*-1920"
- "l-*-1921"
- "l-*-1922"
- "l-*-1923"
- "l-*-1924"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("l-*-1909"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1891"
- "l-*-1892"
- "l-*-1893"
- "l-*-1894"
- "l-*-1895"
- "l-*-1896"
- "l-*-1897"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45"))
- #(ribcage
- ()
- ()
- ()))
- (hygiene guile))
- #(syntax-object
- #f
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("l-*-1973"))
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-1925 top))
- #("l-*-1926"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fform
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1918"
- "l-*-1919"
- "l-*-1920"
- "l-*-1921"
- "l-*-1922"
- "l-*-1923"
- "l-*-1924"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("l-*-1909"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1891"
- "l-*-1892"
- "l-*-1893"
- "l-*-1894"
- "l-*-1895"
- "l-*-1896"
- "l-*-1897"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45"))
- #(ribcage
- ()
- ()
- ()))
- (hygiene guile))
- #(syntax-object
- #f
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("l-*-1973"))
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-1925 top))
- #("l-*-1926"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fform
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1918"
- "l-*-1919"
- "l-*-1920"
- "l-*-1921"
- "l-*-1922"
- "l-*-1923"
- "l-*-1924"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("l-*-1909"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1891"
- "l-*-1892"
- "l-*-1893"
- "l-*-1894"
- "l-*-1895"
- "l-*-1896"
- "l-*-1897"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45"))
- #(ribcage
- ()
- ()
- ()))
- (hygiene guile)))
- '(())
- s-23765
- mod-23767))
- tmp-24657)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-23762)))))))
- (if (eqv? ftype-23791 'define-syntax)
- (let ((tmp-24904
- ($sc-dispatch
- e-23762
- '(_ any any))))
- (if (if tmp-24904
- (@apply
- (lambda (name-24908 val-24909)
- (if (symbol? name-24908)
- #t
- (if (if (vector?
- name-24908)
- (if (= (vector-length
- name-24908)
- 4)
- (eq? (vector-ref
- name-24908
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-24908
- 1))
- #f)))
- tmp-24904)
- #f)
- (@apply
- (lambda (name-24936 val-24937)
- (values
- 'define-syntax-form
- name-24936
- e-23762
- val-24937
- w-23764
- s-23765
- mod-23767))
- tmp-24904)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-23762)))
- (if (eqv? ftype-23791
- 'define-syntax-parameter)
- (let ((tmp-24951
- ($sc-dispatch
- e-23762
- '(_ any any))))
- (if (if tmp-24951
- (@apply
- (lambda (name-24955
- val-24956)
- (if (symbol? name-24955)
- #t
- (if (if (vector?
- name-24955)
- (if (= (vector-length
- name-24955)
- 4)
- (eq? (vector-ref
- name-24955
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-24955
- 1))
- #f)))
- tmp-24951)
- #f)
- (@apply
- (lambda (name-24983 val-24984)
- (values
- 'define-syntax-parameter-form
- name-24983
- e-23762
- val-24984
- w-23764
- s-23765
- mod-23767))
- tmp-24951)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-23762)))
- (values
- 'call
- #f
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)))))))))))))))
- (if (if (vector? e-23762)
- (if (= (vector-length e-23762) 4)
- (eq? (vector-ref e-23762 0) 'syntax-object)
- #f)
- #f)
- (syntax-type-4382
- (vector-ref e-23762 1)
- r-23763
- (let ((w2-25009 (vector-ref e-23762 2)))
- (let ((m1-25010 (car w-23764))
- (s1-25011 (cdr w-23764)))
- (if (null? m1-25010)
- (if (null? s1-25011)
- w2-25009
- (cons (car w2-25009)
- (let ((m2-25022 (cdr w2-25009)))
- (if (null? m2-25022)
- s1-25011
- (append s1-25011 m2-25022)))))
- (cons (let ((m2-25030 (car w2-25009)))
- (if (null? m2-25030)
- m1-25010
- (append m1-25010 m2-25030)))
- (let ((m2-25038 (cdr w2-25009)))
- (if (null? m2-25038)
- s1-25011
- (append s1-25011 m2-25038)))))))
- (let ((t-25043
- (let ((props-25075
- (source-properties
- (if (if (vector? e-23762)
- (if (= (vector-length e-23762) 4)
- (eq? (vector-ref e-23762 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref e-23762 1)
- e-23762))))
- (if (pair? props-25075) props-25075 #f))))
- (if t-25043 t-25043 s-23765))
- rib-23766
- (let ((t-25098 (vector-ref e-23762 3)))
- (if t-25098 t-25098 mod-23767))
- for-car?-23768)
- (if (self-evaluating? e-23762)
- (values
- 'constant
- #f
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)
- (values
- 'other
- #f
- e-23762
- e-23762
- w-23764
- s-23765
- mod-23767)))))))
- (expand-4383
- (lambda (e-25107 r-25108 w-25109 mod-25110)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-25107
- r-25108
- w-25109
- (let ((props-25117
- (source-properties
- (if (if (vector? e-25107)
- (if (= (vector-length e-25107) 4)
- (eq? (vector-ref e-25107 0) 'syntax-object)
- #f)
- #f)
- (vector-ref e-25107 1)
- e-25107))))
- (if (pair? props-25117) props-25117 #f))
- #f
- mod-25110
- #f))
- (lambda (type-25140
- value-25141
- form-25142
- e-25143
- w-25144
- s-25145
- mod-25146)
- (expand-expr-4384
- type-25140
- value-25141
- form-25142
- e-25143
- r-25108
- w-25144
- s-25145
- mod-25146)))))
- (expand-expr-4384
- (lambda (type-25149
- value-25150
- form-25151
- e-25152
- r-25153
- w-25154
- s-25155
- mod-25156)
- (if (eqv? type-25149 'lexical)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- s-25155
- e-25152
- value-25150)
- (if (if (eqv? type-25149 'core)
- #t
- (eqv? type-25149 'core-form))
- (value-25150
- e-25152
- r-25153
- w-25154
- s-25155
- mod-25156)
- (if (eqv? type-25149 'module-ref)
- (call-with-values
- (lambda () (value-25150 e-25152 r-25153 w-25154))
- (lambda (e-25192 r-25193 w-25194 s-25195 mod-25196)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-25192
- r-25193
- w-25194
- (let ((props-25212
- (source-properties
- (if (if (vector? e-25192)
- (if (= (vector-length e-25192) 4)
- (eq? (vector-ref e-25192 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref e-25192 1)
- e-25192))))
- (if (pair? props-25212) props-25212 #f))
- #f
- mod-25196
- #f))
- (lambda (type-25245
- value-25246
- form-25247
- e-25248
- w-25249
- s-25250
- mod-25251)
- (expand-expr-4384
- type-25245
- value-25246
- form-25247
- e-25248
- r-25193
- w-25249
- s-25250
- mod-25251)))))
- (if (eqv? type-25149 'lexical-call)
- (let ((x-25263
- (let ((id-25284 (car e-25152)))
- (let ((source-25288
- (let ((props-25298
- (source-properties
- (if (if (vector? id-25284)
- (if (= (vector-length
- id-25284)
- 4)
- (eq? (vector-ref
- id-25284
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-25284 1)
- id-25284))))
- (if (pair? props-25298) props-25298 #f)))
- (name-25289
- (if (if (vector? id-25284)
- (if (= (vector-length id-25284) 4)
- (eq? (vector-ref id-25284 0)
- 'syntax-object)
- #f)
- #f)
- (syntax->datum id-25284)
- id-25284)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- source-25288
- name-25289
- value-25150)))))
- (let ((tmp-25270
- ($sc-dispatch e-25152 '(any . each-any))))
- (if tmp-25270
- (@apply
- (lambda (e0-25273 e1-25274)
- (let ((arg-exps-25279
- (map (lambda (e-25330)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-25330
- r-25153
- w-25154
- (let ((props-25345
- (source-properties
- (if (if (vector?
- e-25330)
- (if (= (vector-length
- e-25330)
- 4)
- (eq? (vector-ref
- e-25330
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-25330
- 1)
- e-25330))))
- (if (pair? props-25345)
- props-25345
- #f))
- #f
- mod-25156
- #f))
- (lambda (type-25378
- value-25379
- form-25380
- e-25381
- w-25382
- s-25383
- mod-25384)
- (expand-expr-4384
- type-25378
- value-25379
- form-25380
- e-25381
- r-25153
- w-25382
- s-25383
- mod-25384))))
- e1-25274)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- s-25155
- x-25263
- arg-exps-25279)))
- tmp-25270)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-25152))))
- (if (eqv? type-25149 'global-call)
- (let ((x-25400
- (let ((source-25423
- (let ((x-25461 (car e-25152)))
- (let ((props-25462
- (source-properties
- (if (if (vector? x-25461)
- (if (= (vector-length
- x-25461)
- 4)
- (eq? (vector-ref
- x-25461
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-25461 1)
- x-25461))))
- (if (pair? props-25462)
- props-25462
- #f))))
- (var-25424
- (if (if (vector? value-25150)
- (if (= (vector-length value-25150) 4)
- (eq? (vector-ref value-25150 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref value-25150 1)
- value-25150))
- (mod-25425
- (if (if (vector? value-25150)
- (if (= (vector-length value-25150) 4)
- (eq? (vector-ref value-25150 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref value-25150 3)
- mod-25156)))
- (analyze-variable-4319
- mod-25425
- var-25424
- (lambda (mod-25451 var-25452 public?-25453)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- source-25423
- mod-25451
- var-25452
- public?-25453))
- (lambda (var-25475)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- source-25423
- var-25475))))))
- (let ((tmp-25407
- ($sc-dispatch e-25152 '(any . each-any))))
- (if tmp-25407
- (@apply
- (lambda (e0-25410 e1-25411)
- (let ((arg-exps-25416
- (map (lambda (e-25479)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-25479
- r-25153
- w-25154
- (let ((props-25494
- (source-properties
- (if (if (vector?
- e-25479)
- (if (= (vector-length
- e-25479)
- 4)
- (eq? (vector-ref
- e-25479
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-25479
- 1)
- e-25479))))
- (if (pair? props-25494)
- props-25494
- #f))
- #f
- mod-25156
- #f))
- (lambda (type-25527
- value-25528
- form-25529
- e-25530
- w-25531
- s-25532
- mod-25533)
- (expand-expr-4384
- type-25527
- value-25528
- form-25529
- e-25530
- r-25153
- w-25531
- s-25532
- mod-25533))))
- e1-25411)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- s-25155
- x-25400
- arg-exps-25416)))
- tmp-25407)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-25152))))
- (if (eqv? type-25149 'constant)
- (let ((exp-25550
- (strip-4396
- (let ((x-25563
- (begin
- (if (if s-25155
- (supports-source-properties?
- e-25152)
- #f)
- (set-source-properties!
- e-25152
- s-25155))
- e-25152)))
- (if (if (null? (car w-25154))
- (null? (cdr w-25154))
- #f)
- x-25563
- (if (if (vector? x-25563)
- (if (= (vector-length x-25563) 4)
- (eq? (vector-ref x-25563 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-25595
- (vector-ref x-25563 1))
- (wrap-25596
- (let ((w2-25604
- (vector-ref x-25563 2)))
- (let ((m1-25605 (car w-25154))
- (s1-25606 (cdr w-25154)))
- (if (null? m1-25605)
- (if (null? s1-25606)
- w2-25604
- (cons (car w2-25604)
- (let ((m2-25621
- (cdr w2-25604)))
- (if (null? m2-25621)
- s1-25606
- (append
- s1-25606
- m2-25621)))))
- (cons (let ((m2-25629
- (car w2-25604)))
- (if (null? m2-25629)
- m1-25605
- (append
- m1-25605
- m2-25629)))
- (let ((m2-25637
- (cdr w2-25604)))
- (if (null? m2-25637)
- s1-25606
- (append
- s1-25606
- m2-25637))))))))
- (module-25597
- (vector-ref x-25563 3)))
- (vector
- 'syntax-object
- expression-25595
- wrap-25596
- module-25597))
- (if (null? x-25563)
- x-25563
- (vector
- 'syntax-object
- x-25563
- w-25154
- mod-25156)))))
- '(()))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- s-25155
- exp-25550))
- (if (eqv? type-25149 'global)
- (analyze-variable-4319
- mod-25156
- value-25150
- (lambda (mod-25665 var-25666 public?-25667)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- s-25155
- mod-25665
- var-25666
- public?-25667))
- (lambda (var-25675)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- s-25155
- var-25675)))
- (if (eqv? type-25149 'call)
- (let ((x-25690
- (let ((e-25713 (car e-25152)))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-25713
- r-25153
- w-25154
- (let ((props-25723
- (source-properties
- (if (if (vector? e-25713)
- (if (= (vector-length
- e-25713)
- 4)
- (eq? (vector-ref
- e-25713
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref e-25713 1)
- e-25713))))
- (if (pair? props-25723)
- props-25723
- #f))
- #f
- mod-25156
- #f))
- (lambda (type-25746
- value-25747
- form-25748
- e-25749
- w-25750
- s-25751
- mod-25752)
- (expand-expr-4384
- type-25746
- value-25747
- form-25748
- e-25749
- r-25153
- w-25750
- s-25751
- mod-25752))))))
- (let ((tmp-25697
- ($sc-dispatch e-25152 '(any . each-any))))
- (if tmp-25697
- (@apply
- (lambda (e0-25700 e1-25701)
- (let ((arg-exps-25706
- (map (lambda (e-25755)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-25755
- r-25153
- w-25154
- (let ((props-25770
- (source-properties
- (if (if (vector?
- e-25755)
- (if (= (vector-length
- e-25755)
- 4)
- (eq? (vector-ref
- e-25755
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-25755
- 1)
- e-25755))))
- (if (pair? props-25770)
- props-25770
- #f))
- #f
- mod-25156
- #f))
- (lambda (type-25803
- value-25804
- form-25805
- e-25806
- w-25807
- s-25808
- mod-25809)
- (expand-expr-4384
- type-25803
- value-25804
- form-25805
- e-25806
- r-25153
- w-25807
- s-25808
- mod-25809))))
- e1-25701)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- s-25155
- x-25690
- arg-exps-25706)))
- tmp-25697)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-25152))))
- (if (eqv? type-25149 'begin-form)
- (let ((tmp-25823
- ($sc-dispatch e-25152 '(_ any . each-any))))
- (if tmp-25823
- (@apply
- (lambda (e1-25827 e2-25828)
- (expand-sequence-4378
- (cons e1-25827 e2-25828)
- r-25153
- w-25154
- s-25155
- mod-25156))
- tmp-25823)
- (let ((tmp-25968 ($sc-dispatch e-25152 '(_))))
- (if tmp-25968
- (@apply
- (lambda ()
- (syntax-violation
- #f
- "sequence of zero expressions"
- (let ((x-25981
- (begin
- (if (if s-25155
- (supports-source-properties?
- e-25152)
- #f)
- (set-source-properties!
- e-25152
- s-25155))
- e-25152)))
- (if (if (null? (car w-25154))
- (null? (cdr w-25154))
- #f)
- x-25981
- (if (if (vector? x-25981)
- (if (= (vector-length
- x-25981)
- 4)
- (eq? (vector-ref
- x-25981
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-26013
- (vector-ref x-25981 1))
- (wrap-26014
- (let ((w2-26022
- (vector-ref
- x-25981
- 2)))
- (let ((m1-26023
- (car w-25154))
- (s1-26024
- (cdr w-25154)))
- (if (null? m1-26023)
- (if (null? s1-26024)
- w2-26022
- (cons (car w2-26022)
- (let ((m2-26039
- (cdr w2-26022)))
- (if (null? m2-26039)
- s1-26024
- (append
- s1-26024
- m2-26039)))))
- (cons (let ((m2-26047
- (car w2-26022)))
- (if (null? m2-26047)
- m1-26023
- (append
- m1-26023
- m2-26047)))
- (let ((m2-26055
- (cdr w2-26022)))
- (if (null? m2-26055)
- s1-26024
- (append
- s1-26024
- m2-26055))))))))
- (module-26015
- (vector-ref x-25981 3)))
- (vector
- 'syntax-object
- expression-26013
- wrap-26014
- module-26015))
- (if (null? x-25981)
- x-25981
- (vector
- 'syntax-object
- x-25981
- w-25154
- mod-25156)))))))
- tmp-25968)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-25152)))))
- (if (eqv? type-25149 'local-syntax-form)
- (expand-local-syntax-4388
- value-25150
- e-25152
- r-25153
- w-25154
- s-25155
- mod-25156
- expand-sequence-4378)
- (if (eqv? type-25149 'eval-when-form)
- (let ((tmp-26155
- ($sc-dispatch
- e-25152
- '(_ each-any any . each-any))))
- (if tmp-26155
- (@apply
- (lambda (x-26159 e1-26160 e2-26161)
- (let ((when-list-26162
- (parse-when-list-4381
- e-25152
- x-26159)))
- (if (memq 'eval when-list-26162)
- (expand-sequence-4378
- (cons e1-26160 e2-26161)
- r-25153
- w-25154
- s-25155
- mod-25156)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f))))
- tmp-26155)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-25152)))
- (if (if (eqv? type-25149 'define-form)
- #t
- (if (eqv? type-25149 'define-syntax-form)
- #t
- (eqv? type-25149
- 'define-syntax-parameter-form)))
+ "source expression failed to match any pattern"
+ tmp-1))))
+ (else (values 'call #f e e w s mod))))))))
+ ((syntax-object? e)
+ (syntax-type
+ (syntax-object-expression e)
+ r
+ (join-wraps w (syntax-object-wrap e))
+ (or (source-annotation e) s)
+ rib
+ (or (syntax-object-module e) mod)
+ for-car?))
+ ((self-evaluating? e) (values 'constant #f e e w s mod))
+ (else (values 'other #f e e w s mod)))))
+ (expand
+ (lambda (e r w mod)
+ (call-with-values
+ (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+ (lambda (type value form e w s mod)
+ (expand-expr type value form e r w s mod)))))
+ (expand-expr
+ (lambda (type value form e r w s mod)
+ (let ((key type))
+ (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value))
+ ((memv key '(core core-form)) (value e r w s mod))
+ ((memv key '(module-ref))
+ (call-with-values
+ (lambda () (value e r w))
+ (lambda (e r w s mod) (expand e r w mod))))
+ ((memv key '(lexical-call))
+ (expand-call
+ (let ((id (car e)))
+ (build-lexical-reference
+ 'fun
+ (source-annotation id)
+ (if (syntax-object? id) (syntax->datum id) id)
+ value))
+ e
+ r
+ w
+ s
+ mod))
+ ((memv key '(global-call))
+ (expand-call
+ (build-global-reference
+ (source-annotation (car e))
+ (if (syntax-object? value) (syntax-object-expression value) value)
+ (if (syntax-object? value) (syntax-object-module value) mod))
+ e
+ r
+ w
+ s
+ mod))
+ ((memv key '(constant))
+ (build-data s (strip (source-wrap e w s mod) '(()))))
+ ((memv key '(global)) (build-global-reference s value mod))
+ ((memv key '(call))
+ (expand-call (expand (car e) r w mod) e r w s mod))
+ ((memv key '(begin-form))
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_))))
+ (if tmp-1
+ (apply (lambda ()
(syntax-violation
#f
- "definition in expression context, where definitions are not allowed,"
- (let ((x-26396
- (begin
- (if (if s-25155
- (supports-source-properties?
- form-25151)
- #f)
- (set-source-properties!
- form-25151
- s-25155))
- form-25151)))
- (if (if (null? (car w-25154))
- (null? (cdr w-25154))
- #f)
- x-26396
- (if (if (vector? x-26396)
- (if (= (vector-length x-26396) 4)
- (eq? (vector-ref x-26396 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-26428
- (vector-ref x-26396 1))
- (wrap-26429
- (let ((w2-26437
- (vector-ref
- x-26396
- 2)))
- (let ((m1-26438
- (car w-25154))
- (s1-26439
- (cdr w-25154)))
- (if (null? m1-26438)
- (if (null? s1-26439)
- w2-26437
- (cons (car w2-26437)
- (let ((m2-26454
- (cdr w2-26437)))
- (if (null? m2-26454)
- s1-26439
- (append
- s1-26439
- m2-26454)))))
- (cons (let ((m2-26462
- (car w2-26437)))
- (if (null? m2-26462)
- m1-26438
- (append
- m1-26438
- m2-26462)))
- (let ((m2-26470
- (cdr w2-26437)))
- (if (null? m2-26470)
- s1-26439
- (append
- s1-26439
- m2-26470))))))))
- (module-26430
- (vector-ref x-26396 3)))
- (vector
- 'syntax-object
- expression-26428
- wrap-26429
- module-26430))
- (if (null? x-26396)
- x-26396
- (vector
- 'syntax-object
- x-26396
- w-25154
- mod-25156))))))
- (if (eqv? type-25149 'syntax)
- (syntax-violation
- #f
- "reference to pattern variable outside syntax form"
- (let ((x-26500
- (begin
- (if (if s-25155
- (supports-source-properties?
- e-25152)
- #f)
- (set-source-properties!
- e-25152
- s-25155))
- e-25152)))
- (if (if (null? (car w-25154))
- (null? (cdr w-25154))
- #f)
- x-26500
- (if (if (vector? x-26500)
- (if (= (vector-length x-26500)
- 4)
- (eq? (vector-ref x-26500 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-26532
- (vector-ref x-26500 1))
- (wrap-26533
- (let ((w2-26541
- (vector-ref
- x-26500
- 2)))
- (let ((m1-26542
- (car w-25154))
- (s1-26543
- (cdr w-25154)))
- (if (null? m1-26542)
- (if (null? s1-26543)
- w2-26541
- (cons (car w2-26541)
- (let ((m2-26558
- (cdr w2-26541)))
- (if (null? m2-26558)
- s1-26543
- (append
- s1-26543
- m2-26558)))))
- (cons (let ((m2-26566
- (car w2-26541)))
- (if (null? m2-26566)
- m1-26542
- (append
- m1-26542
- m2-26566)))
- (let ((m2-26574
- (cdr w2-26541)))
- (if (null? m2-26574)
- s1-26543
- (append
- s1-26543
- m2-26574))))))))
- (module-26534
- (vector-ref x-26500 3)))
- (vector
- 'syntax-object
- expression-26532
- wrap-26533
- module-26534))
- (if (null? x-26500)
- x-26500
- (vector
- 'syntax-object
- x-26500
- w-25154
- mod-25156))))))
- (if (eqv? type-25149 'displaced-lexical)
- (syntax-violation
- #f
- "reference to identifier outside its scope"
- (let ((x-26604
- (begin
- (if (if s-25155
- (supports-source-properties?
- e-25152)
- #f)
- (set-source-properties!
- e-25152
- s-25155))
- e-25152)))
- (if (if (null? (car w-25154))
- (null? (cdr w-25154))
- #f)
- x-26604
- (if (if (vector? x-26604)
- (if (= (vector-length x-26604)
- 4)
- (eq? (vector-ref x-26604 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-26636
- (vector-ref x-26604 1))
- (wrap-26637
- (let ((w2-26645
- (vector-ref
- x-26604
- 2)))
- (let ((m1-26646
- (car w-25154))
- (s1-26647
- (cdr w-25154)))
- (if (null? m1-26646)
- (if (null? s1-26647)
- w2-26645
- (cons (car w2-26645)
- (let ((m2-26662
- (cdr w2-26645)))
- (if (null? m2-26662)
- s1-26647
- (append
- s1-26647
- m2-26662)))))
- (cons (let ((m2-26670
- (car w2-26645)))
- (if (null? m2-26670)
- m1-26646
- (append
- m1-26646
- m2-26670)))
- (let ((m2-26678
- (cdr w2-26645)))
- (if (null? m2-26678)
- s1-26647
- (append
- s1-26647
- m2-26678))))))))
- (module-26638
- (vector-ref x-26604 3)))
- (vector
- 'syntax-object
- expression-26636
- wrap-26637
- module-26638))
- (if (null? x-26604)
- x-26604
- (vector
- 'syntax-object
- x-26604
- w-25154
- mod-25156))))))
- (syntax-violation
- #f
- "unexpected syntax"
- (let ((x-26702
- (begin
- (if (if s-25155
- (supports-source-properties?
- e-25152)
- #f)
- (set-source-properties!
- e-25152
- s-25155))
- e-25152)))
- (if (if (null? (car w-25154))
- (null? (cdr w-25154))
- #f)
- x-26702
- (if (if (vector? x-26702)
- (if (= (vector-length x-26702)
- 4)
- (eq? (vector-ref x-26702 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-26734
- (vector-ref x-26702 1))
- (wrap-26735
- (let ((w2-26743
- (vector-ref
- x-26702
- 2)))
- (let ((m1-26744
- (car w-25154))
- (s1-26745
- (cdr w-25154)))
- (if (null? m1-26744)
- (if (null? s1-26745)
- w2-26743
- (cons (car w2-26743)
- (let ((m2-26760
- (cdr w2-26743)))
- (if (null? m2-26760)
- s1-26745
- (append
- s1-26745
- m2-26760)))))
- (cons (let ((m2-26768
- (car w2-26743)))
- (if (null? m2-26768)
- m1-26744
- (append
- m1-26744
- m2-26768)))
- (let ((m2-26776
- (cdr w2-26743)))
- (if (null? m2-26776)
- s1-26745
- (append
- s1-26745
- m2-26776))))))))
- (module-26736
- (vector-ref x-26702 3)))
- (vector
- 'syntax-object
- expression-26734
- wrap-26735
- module-26736))
- (if (null? x-26702)
- x-26702
- (vector
- 'syntax-object
- x-26702
- w-25154
- mod-25156))))))))))))))))))))))
- (expand-macro-4386
- (lambda (p-26791
- e-26792
- r-26793
- w-26794
- s-26795
- rib-26796
- mod-26797)
- (letrec*
- ((rebuild-macro-output-26798
- (lambda (x-26907 m-26908)
- (if (pair? x-26907)
- (let ((e-26912
- (cons (rebuild-macro-output-26798
- (car x-26907)
- m-26908)
- (rebuild-macro-output-26798
- (cdr x-26907)
- m-26908))))
- (begin
- (if (if s-26795
- (supports-source-properties? e-26912)
- #f)
- (set-source-properties! e-26912 s-26795))
- e-26912))
- (if (if (vector? x-26907)
- (if (= (vector-length x-26907) 4)
- (eq? (vector-ref x-26907 0) 'syntax-object)
- #f)
- #f)
- (let ((w-26928 (vector-ref x-26907 2)))
- (let ((ms-26929 (car w-26928))
- (ss-26930 (cdr w-26928)))
- (if (if (pair? ms-26929) (eq? (car ms-26929) #f) #f)
- (let ((expression-26938 (vector-ref x-26907 1))
- (wrap-26939
- (cons (cdr ms-26929)
- (if rib-26796
- (cons rib-26796 (cdr ss-26930))
- (cdr ss-26930))))
- (module-26940 (vector-ref x-26907 3)))
- (vector
- 'syntax-object
- expression-26938
- wrap-26939
- module-26940))
- (let ((expression-26950
- (let ((e-26955 (vector-ref x-26907 1)))
- (begin
- (if (if s-26795
- (supports-source-properties?
- e-26955)
- #f)
- (set-source-properties!
- e-26955
- s-26795))
- e-26955)))
- (wrap-26951
- (cons (cons m-26908 ms-26929)
- (if rib-26796
- (cons rib-26796
- (cons 'shift ss-26930))
- (cons 'shift ss-26930))))
- (module-26952 (vector-ref x-26907 3)))
- (vector
- 'syntax-object
- expression-26950
- wrap-26951
- module-26952)))))
- (if (vector? x-26907)
- (let ((n-26967 (vector-length x-26907)))
- (let ((v-26968
- (let ((e-27033 (make-vector n-26967)))
- (begin
- (if (if s-26795
- (supports-source-properties? e-27033)
- #f)
- (set-source-properties! e-27033 s-26795))
- e-27033))))
- (letrec*
- ((loop-26969
- (lambda (i-27029)
- (if (= i-27029 n-26967)
- v-26968
- (begin
- (vector-set!
- v-26968
- i-27029
- (rebuild-macro-output-26798
- (vector-ref x-26907 i-27029)
- m-26908))
- (loop-26969 (#{1+}# i-27029)))))))
- (loop-26969 0))))
- (if (symbol? x-26907)
- (syntax-violation
- #f
- "encountered raw symbol in macro output"
- (let ((s-27044 (cdr w-26794)))
- (let ((x-27048
- (begin
- (if (if s-27044
- (supports-source-properties?
- e-26792)
- #f)
- (set-source-properties!
- e-26792
- s-27044))
- e-26792)))
- (if (if (null? (car w-26794))
- (null? (cdr w-26794))
- #f)
- x-27048
- (if (if (vector? x-27048)
- (if (= (vector-length x-27048) 4)
- (eq? (vector-ref x-27048 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-27080
- (vector-ref x-27048 1))
- (wrap-27081
- (let ((w2-27089
- (vector-ref x-27048 2)))
- (let ((m1-27090 (car w-26794))
- (s1-27091 (cdr w-26794)))
- (if (null? m1-27090)
- (if (null? s1-27091)
- w2-27089
- (cons (car w2-27089)
- (let ((m2-27106
- (cdr w2-27089)))
- (if (null? m2-27106)
- s1-27091
- (append
- s1-27091
- m2-27106)))))
- (cons (let ((m2-27114
- (car w2-27089)))
- (if (null? m2-27114)
- m1-27090
- (append
- m1-27090
- m2-27114)))
- (let ((m2-27122
- (cdr w2-27089)))
- (if (null? m2-27122)
- s1-27091
- (append
- s1-27091
- m2-27122))))))))
- (module-27082 (vector-ref x-27048 3)))
- (vector
- 'syntax-object
- expression-27080
- wrap-27081
- module-27082))
- (if (null? x-27048)
- x-27048
- (vector
- 'syntax-object
- x-27048
- w-26794
- mod-26797))))))
- x-26907)
- (begin
- (if (if s-26795
- (supports-source-properties? x-26907)
- #f)
- (set-source-properties! x-26907 s-26795))
- x-26907))))))))
- (with-fluids
- ((transformer-environment-4369
- (lambda (k-26799)
- (k-26799
- e-26792
- r-26793
- w-26794
- s-26795
- rib-26796
- mod-26797))))
- (rebuild-macro-output-26798
- (p-26791
- (let ((w-26806
- (cons (cons #f (car w-26794))
- (cons 'shift (cdr w-26794)))))
- (let ((x-26811
- (begin
- (if (if s-26795
- (supports-source-properties? e-26792)
- #f)
- (set-source-properties! e-26792 s-26795))
- e-26792)))
- (if (if (null? (car w-26806))
- (null? (cdr w-26806))
- #f)
- x-26811
- (if (if (vector? x-26811)
- (if (= (vector-length x-26811) 4)
- (eq? (vector-ref x-26811 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-26850 (vector-ref x-26811 1))
- (wrap-26851
- (let ((w2-26859 (vector-ref x-26811 2)))
- (let ((m1-26860 (car w-26806))
- (s1-26861 (cdr w-26806)))
- (if (null? m1-26860)
- (if (null? s1-26861)
- w2-26859
- (cons (car w2-26859)
- (let ((m2-26876 (cdr w2-26859)))
- (if (null? m2-26876)
- s1-26861
- (append
- s1-26861
- m2-26876)))))
- (cons (let ((m2-26884 (car w2-26859)))
- (if (null? m2-26884)
- m1-26860
- (append m1-26860 m2-26884)))
- (let ((m2-26892 (cdr w2-26859)))
- (if (null? m2-26892)
- s1-26861
- (append
- s1-26861
- m2-26892))))))))
- (module-26852 (vector-ref x-26811 3)))
- (vector
- 'syntax-object
- expression-26850
- wrap-26851
- module-26852))
- (if (null? x-26811)
- x-26811
- (vector
- 'syntax-object
- x-26811
- w-26806
- mod-26797)))))))
- (gensym
- (string-append "m-" (session-id-4308) "-")))))))
- (expand-body-4387
- (lambda (body-27152
- outer-form-27153
- r-27154
- w-27155
- mod-27156)
- (let ((r-27157
- (cons '("placeholder" placeholder) r-27154)))
- (let ((ribcage-27158 (vector 'ribcage '() '() '())))
- (let ((w-27159
- (cons (car w-27155)
- (cons ribcage-27158 (cdr w-27155)))))
- (letrec*
- ((parse-27160
- (lambda (body-27268
- ids-27269
- labels-27270
- var-ids-27271
- vars-27272
- vals-27273
- bindings-27274)
- (if (null? body-27268)
- (syntax-violation
- #f
- "no expressions in body"
- outer-form-27153)
- (let ((e-27275 (cdr (car body-27268)))
- (er-27276 (car (car body-27268))))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-27275
- er-27276
- '(())
- (let ((props-27285
- (source-properties
- (if (if (vector? er-27276)
- (if (= (vector-length er-27276)
- 4)
- (eq? (vector-ref er-27276 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref er-27276 1)
- er-27276))))
- (if (pair? props-27285) props-27285 #f))
- ribcage-27158
- mod-27156
- #f))
- (lambda (type-27308
- value-27309
- form-27310
- e-27311
- w-27312
- s-27313
- mod-27314)
- (if (eqv? type-27308 'define-form)
- (let ((id-27322
- (if (if (null? (car w-27312))
- (null? (cdr w-27312))
- #f)
- value-27309
- (if (if (vector? value-27309)
- (if (= (vector-length
- value-27309)
- 4)
- (eq? (vector-ref
- value-27309
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-27367
- (vector-ref value-27309 1))
- (wrap-27368
- (let ((w2-27378
- (vector-ref
- value-27309
- 2)))
- (let ((m1-27379
- (car w-27312))
- (s1-27380
- (cdr w-27312)))
- (if (null? m1-27379)
- (if (null? s1-27380)
- w2-27378
- (cons (car w2-27378)
- (let ((m2-27397
- (cdr w2-27378)))
- (if (null? m2-27397)
- s1-27380
- (append
- s1-27380
- m2-27397)))))
- (cons (let ((m2-27405
- (car w2-27378)))
- (if (null? m2-27405)
- m1-27379
- (append
- m1-27379
- m2-27405)))
- (let ((m2-27413
- (cdr w2-27378)))
- (if (null? m2-27413)
- s1-27380
- (append
- s1-27380
- m2-27413))))))))
- (module-27369
- (vector-ref
- value-27309
- 3)))
- (vector
- 'syntax-object
- expression-27367
- wrap-27368
- module-27369))
- (if (null? value-27309)
- value-27309
- (vector
- 'syntax-object
- value-27309
- w-27312
- mod-27314)))))
- (label-27323
- (string-append
- "l-"
- (session-id-4308)
- (symbol->string (gensym "-")))))
- (let ((var-27324
- (let ((id-27474
- (if (if (vector? id-27322)
- (if (= (vector-length
- id-27322)
- 4)
- (eq? (vector-ref
- id-27322
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-27322 1)
- id-27322)))
- (gensym
- (string-append
- (symbol->string id-27474)
- "-")))))
- (begin
- (begin
- (let ((update-27333
- (cons (vector-ref id-27322 1)
- (vector-ref
- ribcage-27158
- 1))))
- (vector-set!
- ribcage-27158
- 1
- update-27333))
- (let ((update-27445
- (cons (car (vector-ref
- id-27322
- 2))
- (vector-ref
- ribcage-27158
- 2))))
- (vector-set!
- ribcage-27158
- 2
- update-27445))
- (let ((update-27460
- (cons label-27323
- (vector-ref
- ribcage-27158
- 3))))
- (vector-set!
- ribcage-27158
- 3
- update-27460)))
- (parse-27160
- (cdr body-27268)
- (cons id-27322 ids-27269)
- (cons label-27323 labels-27270)
- (cons id-27322 var-ids-27271)
- (cons var-27324 vars-27272)
- (cons (cons er-27276
- (if (if (null? (car w-27312))
- (null? (cdr w-27312))
- #f)
- e-27311
- (if (if (vector? e-27311)
- (if (= (vector-length
- e-27311)
- 4)
- (eq? (vector-ref
- e-27311
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-27526
- (vector-ref
- e-27311
- 1))
- (wrap-27527
- (let ((w2-27537
- (vector-ref
- e-27311
- 2)))
- (let ((m1-27538
- (car w-27312))
- (s1-27539
- (cdr w-27312)))
- (if (null? m1-27538)
- (if (null? s1-27539)
- w2-27537
- (cons (car w2-27537)
- (let ((m2-27556
- (cdr w2-27537)))
- (if (null? m2-27556)
- s1-27539
- (append
- s1-27539
- m2-27556)))))
- (cons (let ((m2-27564
- (car w2-27537)))
- (if (null? m2-27564)
- m1-27538
- (append
- m1-27538
- m2-27564)))
- (let ((m2-27572
- (cdr w2-27537)))
- (if (null? m2-27572)
- s1-27539
- (append
- s1-27539
- m2-27572))))))))
- (module-27528
- (vector-ref
- e-27311
- 3)))
- (vector
- 'syntax-object
- expression-27526
- wrap-27527
- module-27528))
- (if (null? e-27311)
- e-27311
- (vector
- 'syntax-object
- e-27311
- w-27312
- mod-27314)))))
- vals-27273)
- (cons (cons 'lexical var-27324)
- bindings-27274)))))
- (if (if (eqv? type-27308 'define-syntax-form)
- #t
- (eqv? type-27308
- 'define-syntax-parameter-form))
- (let ((id-27606
- (if (if (null? (car w-27312))
- (null? (cdr w-27312))
- #f)
- value-27309
- (if (if (vector? value-27309)
- (if (= (vector-length
- value-27309)
- 4)
- (eq? (vector-ref
- value-27309
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-27650
- (vector-ref
- value-27309
- 1))
- (wrap-27651
- (let ((w2-27661
- (vector-ref
- value-27309
- 2)))
- (let ((m1-27662
- (car w-27312))
- (s1-27663
- (cdr w-27312)))
- (if (null? m1-27662)
- (if (null? s1-27663)
- w2-27661
- (cons (car w2-27661)
- (let ((m2-27680
- (cdr w2-27661)))
- (if (null? m2-27680)
- s1-27663
- (append
- s1-27663
- m2-27680)))))
- (cons (let ((m2-27688
- (car w2-27661)))
- (if (null? m2-27688)
- m1-27662
- (append
- m1-27662
- m2-27688)))
- (let ((m2-27696
- (cdr w2-27661)))
- (if (null? m2-27696)
- s1-27663
- (append
- s1-27663
- m2-27696))))))))
- (module-27652
- (vector-ref
- value-27309
- 3)))
- (vector
- 'syntax-object
- expression-27650
- wrap-27651
- module-27652))
- (if (null? value-27309)
- value-27309
- (vector
- 'syntax-object
- value-27309
- w-27312
- mod-27314)))))
- (label-27607
- (string-append
- "l-"
- (session-id-4308)
- (symbol->string (gensym "-")))))
- (begin
- (begin
- (let ((update-27616
- (cons (vector-ref id-27606 1)
- (vector-ref
- ribcage-27158
- 1))))
- (vector-set!
- ribcage-27158
- 1
- update-27616))
- (let ((update-27728
- (cons (car (vector-ref
- id-27606
- 2))
- (vector-ref
- ribcage-27158
- 2))))
- (vector-set!
- ribcage-27158
- 2
- update-27728))
- (let ((update-27743
- (cons label-27607
- (vector-ref
- ribcage-27158
- 3))))
- (vector-set!
- ribcage-27158
- 3
- update-27743)))
- (parse-27160
- (cdr body-27268)
- (cons id-27606 ids-27269)
- (cons label-27607 labels-27270)
- var-ids-27271
- vars-27272
- vals-27273
- (cons (cons (if (eq? type-27308
- 'define-syntax-parameter-form)
- 'syntax-parameter
- 'macro)
- (cons er-27276
- (if (if (null? (car w-27312))
- (null? (cdr w-27312))
- #f)
- e-27311
- (if (if (vector?
- e-27311)
- (if (= (vector-length
- e-27311)
- 4)
- (eq? (vector-ref
- e-27311
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-27782
- (vector-ref
- e-27311
- 1))
- (wrap-27783
- (let ((w2-27793
- (vector-ref
- e-27311
- 2)))
- (let ((m1-27794
- (car w-27312))
- (s1-27795
- (cdr w-27312)))
- (if (null? m1-27794)
- (if (null? s1-27795)
- w2-27793
- (cons (car w2-27793)
- (let ((m2-27812
- (cdr w2-27793)))
- (if (null? m2-27812)
- s1-27795
- (append
- s1-27795
- m2-27812)))))
- (cons (let ((m2-27820
- (car w2-27793)))
- (if (null? m2-27820)
- m1-27794
- (append
- m1-27794
- m2-27820)))
- (let ((m2-27828
- (cdr w2-27793)))
- (if (null? m2-27828)
- s1-27795
- (append
- s1-27795
- m2-27828))))))))
- (module-27784
- (vector-ref
- e-27311
- 3)))
- (vector
- 'syntax-object
- expression-27782
- wrap-27783
- module-27784))
- (if (null? e-27311)
- e-27311
- (vector
- 'syntax-object
- e-27311
- w-27312
- mod-27314))))))
- bindings-27274))))
- (if (eqv? type-27308 'begin-form)
- (let ((tmp-27858
- ($sc-dispatch
- e-27311
- '(_ . each-any))))
- (if tmp-27858
- (@apply
- (lambda (e1-27862)
- (parse-27160
- (letrec*
- ((f-27863
- (lambda (forms-28064)
- (if (null? forms-28064)
- (cdr body-27268)
- (cons (cons er-27276
- (let ((x-28068
- (car forms-28064)))
- (if (if (null? (car w-27312))
- (null? (cdr w-27312))
- #f)
- x-28068
- (if (if (vector?
- x-28068)
- (if (= (vector-length
- x-28068)
- 4)
- (eq? (vector-ref
- x-28068
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-28086
- (vector-ref
- x-28068
- 1))
- (wrap-28087
- (let ((w2-28095
- (vector-ref
- x-28068
- 2)))
- (let ((m1-28096
- (car w-27312))
- (s1-28097
- (cdr w-27312)))
- (if (null? m1-28096)
- (if (null? s1-28097)
- w2-28095
- (cons (car w2-28095)
- (let ((m2-28112
- (cdr w2-28095)))
- (if (null? m2-28112)
- s1-28097
- (append
- s1-28097
- m2-28112)))))
- (cons (let ((m2-28120
- (car w2-28095)))
- (if (null? m2-28120)
- m1-28096
- (append
- m1-28096
- m2-28120)))
- (let ((m2-28128
- (cdr w2-28095)))
- (if (null? m2-28128)
- s1-28097
- (append
- s1-28097
- m2-28128))))))))
- (module-28088
- (vector-ref
- x-28068
- 3)))
- (vector
- 'syntax-object
- expression-28086
- wrap-28087
- module-28088))
- (if (null? x-28068)
- x-28068
- (vector
- 'syntax-object
- x-28068
- w-27312
- mod-27314))))))
- (f-27863
- (cdr forms-28064)))))))
- (f-27863 e1-27862))
- ids-27269
- labels-27270
- var-ids-27271
- vars-27272
- vals-27273
- bindings-27274))
- tmp-27858)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-27311)))
- (if (eqv? type-27308 'local-syntax-form)
- (expand-local-syntax-4388
- value-27309
- e-27311
- er-27276
- w-27312
- s-27313
- mod-27314
- (lambda (forms-28157
- er-28158
- w-28159
- s-28160
- mod-28161)
- (parse-27160
- (letrec*
- ((f-28162
- (lambda (forms-28363)
- (if (null? forms-28363)
- (cdr body-27268)
- (cons (cons er-28158
- (let ((x-28367
- (car forms-28363)))
- (if (if (null? (car w-28159))
- (null? (cdr w-28159))
- #f)
- x-28367
- (if (if (vector?
- x-28367)
- (if (= (vector-length
- x-28367)
- 4)
- (eq? (vector-ref
- x-28367
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-28385
- (vector-ref
- x-28367
- 1))
- (wrap-28386
- (let ((w2-28394
- (vector-ref
- x-28367
- 2)))
- (let ((m1-28395
- (car w-28159))
- (s1-28396
- (cdr w-28159)))
- (if (null? m1-28395)
- (if (null? s1-28396)
- w2-28394
- (cons (car w2-28394)
- (let ((m2-28411
- (cdr w2-28394)))
- (if (null? m2-28411)
- s1-28396
- (append
- s1-28396
- m2-28411)))))
- (cons (let ((m2-28419
- (car w2-28394)))
- (if (null? m2-28419)
- m1-28395
- (append
- m1-28395
- m2-28419)))
- (let ((m2-28427
- (cdr w2-28394)))
- (if (null? m2-28427)
- s1-28396
- (append
- s1-28396
- m2-28427))))))))
- (module-28387
- (vector-ref
- x-28367
- 3)))
- (vector
- 'syntax-object
- expression-28385
- wrap-28386
- module-28387))
- (if (null? x-28367)
- x-28367
- (vector
- 'syntax-object
- x-28367
- w-28159
- mod-28161))))))
- (f-28162
- (cdr forms-28363)))))))
- (f-28162 forms-28157))
- ids-27269
- labels-27270
- var-ids-27271
- vars-27272
- vals-27273
- bindings-27274)))
- (if (null? ids-27269)
- (build-sequence-4329
- #f
- (map (lambda (x-28620)
- (let ((e-28624 (cdr x-28620))
- (r-28625 (car x-28620)))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-28624
- r-28625
- '(())
- (let ((props-28632
- (source-properties
- (if (if (vector?
- e-28624)
- (if (= (vector-length
- e-28624)
- 4)
- (eq? (vector-ref
- e-28624
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-28624
- 1)
- e-28624))))
- (if (pair? props-28632)
- props-28632
- #f))
- #f
- mod-27314
- #f))
- (lambda (type-28655
- value-28656
- form-28657
- e-28658
- w-28659
- s-28660
- mod-28661)
- (expand-expr-4384
- type-28655
- value-28656
- form-28657
- e-28658
- r-28625
- w-28659
- s-28660
- mod-28661)))))
- (cons (cons er-27276
- (let ((x-28672
- (begin
- (if (if s-27313
- (supports-source-properties?
- e-27311)
- #f)
- (set-source-properties!
- e-27311
- s-27313))
- e-27311)))
- (if (if (null? (car w-27312))
- (null? (cdr w-27312))
- #f)
- x-28672
- (if (if (vector?
- x-28672)
- (if (= (vector-length
- x-28672)
- 4)
- (eq? (vector-ref
- x-28672
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-28704
- (vector-ref
- x-28672
- 1))
- (wrap-28705
- (let ((w2-28713
- (vector-ref
- x-28672
- 2)))
- (let ((m1-28714
- (car w-27312))
- (s1-28715
- (cdr w-27312)))
- (if (null? m1-28714)
- (if (null? s1-28715)
- w2-28713
- (cons (car w2-28713)
- (let ((m2-28730
- (cdr w2-28713)))
- (if (null? m2-28730)
- s1-28715
- (append
- s1-28715
- m2-28730)))))
- (cons (let ((m2-28738
- (car w2-28713)))
- (if (null? m2-28738)
- m1-28714
- (append
- m1-28714
- m2-28738)))
- (let ((m2-28746
- (cdr w2-28713)))
- (if (null? m2-28746)
- s1-28715
- (append
- s1-28715
- m2-28746))))))))
- (module-28706
- (vector-ref
- x-28672
- 3)))
- (vector
- 'syntax-object
- expression-28704
- wrap-28705
- module-28706))
- (if (null? x-28672)
- x-28672
- (vector
- 'syntax-object
- x-28672
- w-27312
- mod-27314))))))
- (cdr body-27268))))
- (begin
- (if (not (valid-bound-ids?-4373
- ids-27269))
- (syntax-violation
- #f
- "invalid or duplicate identifier in definition"
- outer-form-27153))
- (letrec*
- ((loop-28845
- (lambda (bs-28848
- er-cache-28849
- r-cache-28850)
- (if (not (null? bs-28848))
- (let ((b-28851
- (car bs-28848)))
- (if (let ((t-28854
- (car b-28851)))
- (if (eq? t-28854
- 'macro)
- #t
- (eq? t-28854
- 'syntax-parameter)))
- (let ((er-28856
- (car (cdr b-28851))))
- (let ((r-cache-28857
- (if (eq? er-28856
- er-cache-28849)
- r-cache-28850
- (macros-only-env-4344
- er-28856))))
- (begin
- (set-cdr!
- b-28851
- (eval-local-transformer-4389
- (let ((e-28906
- (cdr (cdr b-28851))))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-28906
- r-cache-28857
- '(())
- (let ((props-28916
- (source-properties
- (if (if (vector?
- e-28906)
- (if (= (vector-length
- e-28906)
- 4)
- (eq? (vector-ref
- e-28906
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-28906
- 1)
- e-28906))))
- (if (pair? props-28916)
- props-28916
- #f))
- #f
- mod-27314
- #f))
- (lambda (type-28939
- value-28940
- form-28941
- e-28942
- w-28943
- s-28944
- mod-28945)
- (expand-expr-4384
- type-28939
- value-28940
- form-28941
- e-28942
- r-cache-28857
- w-28943
- s-28944
- mod-28945))))
- mod-27314))
- (if (eq? (car b-28851)
- 'syntax-parameter)
- (set-cdr!
- b-28851
- (list (cdr b-28851))))
- (loop-28845
- (cdr bs-28848)
- er-28856
- r-cache-28857))))
- (loop-28845
- (cdr bs-28848)
- er-cache-28849
- r-cache-28850)))))))
- (loop-28845 bindings-27274 #f #f))
- (set-cdr!
- r-27157
- (extend-env-4342
- labels-27270
- bindings-27274
- (cdr r-27157)))
- (build-letrec-4332
- #f
- #t
- (reverse
- (map syntax->datum
- var-ids-27271))
- (reverse vars-27272)
- (map (lambda (x-29360)
- (let ((e-29364
- (cdr x-29360))
- (r-29365
- (car x-29360)))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-29364
- r-29365
- '(())
- (let ((props-29372
- (source-properties
- (if (if (vector?
- e-29364)
- (if (= (vector-length
- e-29364)
- 4)
- (eq? (vector-ref
- e-29364
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-29364
- 1)
- e-29364))))
- (if (pair? props-29372)
- props-29372
- #f))
- #f
- mod-27314
- #f))
- (lambda (type-29395
- value-29396
- form-29397
- e-29398
- w-29399
- s-29400
- mod-29401)
- (expand-expr-4384
- type-29395
- value-29396
- form-29397
- e-29398
- r-29365
- w-29399
- s-29400
- mod-29401)))))
- (reverse vals-27273))
- (build-sequence-4329
- #f
- (map (lambda (x-29581)
- (let ((e-29585
- (cdr x-29581))
- (r-29586
- (car x-29581)))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-29585
- r-29586
- '(())
- (let ((props-29593
- (source-properties
- (if (if (vector?
- e-29585)
- (if (= (vector-length
- e-29585)
- 4)
- (eq? (vector-ref
- e-29585
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-29585
- 1)
- e-29585))))
- (if (pair? props-29593)
- props-29593
- #f))
- #f
- mod-27314
- #f))
- (lambda (type-29616
- value-29617
- form-29618
- e-29619
- w-29620
- s-29621
- mod-29622)
- (expand-expr-4384
- type-29616
- value-29617
- form-29618
- e-29619
- r-29586
- w-29620
- s-29621
- mod-29622)))))
- (cons (cons er-27276
- (let ((x-29633
- (begin
- (if (if s-27313
- (supports-source-properties?
- e-27311)
- #f)
- (set-source-properties!
- e-27311
- s-27313))
- e-27311)))
- (if (if (null? (car w-27312))
- (null? (cdr w-27312))
- #f)
- x-29633
- (if (if (vector?
- x-29633)
- (if (= (vector-length
- x-29633)
- 4)
- (eq? (vector-ref
- x-29633
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-29665
- (vector-ref
- x-29633
- 1))
- (wrap-29666
- (let ((w2-29674
- (vector-ref
- x-29633
- 2)))
- (let ((m1-29675
- (car w-27312))
- (s1-29676
- (cdr w-27312)))
- (if (null? m1-29675)
- (if (null? s1-29676)
- w2-29674
- (cons (car w2-29674)
- (let ((m2-29691
- (cdr w2-29674)))
- (if (null? m2-29691)
- s1-29676
- (append
- s1-29676
- m2-29691)))))
- (cons (let ((m2-29699
- (car w2-29674)))
- (if (null? m2-29699)
- m1-29675
- (append
- m1-29675
- m2-29699)))
- (let ((m2-29707
- (cdr w2-29674)))
- (if (null? m2-29707)
- s1-29676
- (append
- s1-29676
- m2-29707))))))))
- (module-29667
- (vector-ref
- x-29633
- 3)))
- (vector
- 'syntax-object
- expression-29665
- wrap-29666
- module-29667))
- (if (null? x-29633)
- x-29633
- (vector
- 'syntax-object
- x-29633
- w-27312
- mod-27314))))))
- (cdr body-27268))))))))))))))))))
- (parse-27160
- (map (lambda (x-27163)
- (cons r-27157
- (if (if (null? (car w-27159))
- (null? (cdr w-27159))
- #f)
- x-27163
- (if (if (vector? x-27163)
- (if (= (vector-length x-27163) 4)
- (eq? (vector-ref x-27163 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-27199
- (vector-ref x-27163 1))
- (wrap-27200
- (let ((w2-27210
- (vector-ref x-27163 2)))
- (let ((m1-27211 (car w-27159))
- (s1-27212 (cdr w-27159)))
- (if (null? m1-27211)
- (if (null? s1-27212)
- w2-27210
- (cons (car w2-27210)
- (let ((m2-27229
- (cdr w2-27210)))
- (if (null? m2-27229)
- s1-27212
- (append
- s1-27212
- m2-27229)))))
- (cons (let ((m2-27237
- (car w2-27210)))
- (if (null? m2-27237)
- m1-27211
- (append
- m1-27211
- m2-27237)))
- (let ((m2-27245
- (cdr w2-27210)))
- (if (null? m2-27245)
- s1-27212
- (append
- s1-27212
- m2-27245))))))))
- (module-27201
- (vector-ref x-27163 3)))
- (vector
- 'syntax-object
- expression-27199
- wrap-27200
- module-27201))
- (if (null? x-27163)
- x-27163
- (vector
- 'syntax-object
- x-27163
- w-27159
- mod-27156))))))
- body-27152)
- '()
- '()
- '()
- '()
- '()
- '())))))))
- (expand-local-syntax-4388
- (lambda (rec?-29722
- e-29723
- r-29724
- w-29725
- s-29726
- mod-29727
- k-29728)
- (let ((tmp-29730
- ($sc-dispatch
- e-29723
- '(_ #(each (any any)) any . each-any))))
- (if tmp-29730
- (@apply
- (lambda (id-29734 val-29735 e1-29736 e2-29737)
- (if (not (valid-bound-ids?-4373 id-29734))
- (syntax-violation
- #f
- "duplicate bound keyword"
- e-29723)
- (let ((labels-29834 (gen-labels-4350 id-29734)))
- (let ((new-w-29835
- (make-binding-wrap-4361
- id-29734
- labels-29834
- w-29725)))
- (k-29728
- (cons e1-29736 e2-29737)
- (extend-env-4342
- labels-29834
- (let ((trans-r-29873
- (macros-only-env-4344 r-29724)))
- (begin
- (if rec?-29722 new-w-29835 w-29725)
- (map (lambda (x-29874)
- (cons 'macro
- (eval-local-transformer-4389
- (call-with-values
- (lambda ()
- (syntax-type-4382
- x-29874
- trans-r-29873
- (values
- (if rec?-29722
- new-w-29835
- w-29725))
- (let ((props-29940
- (source-properties
- (if (if (vector?
- x-29874)
- (if (= (vector-length
- x-29874)
- 4)
- (eq? (vector-ref
- x-29874
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- x-29874
- 1)
- x-29874))))
- (if (pair? props-29940)
- props-29940
- #f))
- #f
- mod-29727
- #f))
- (lambda (type-29973
- value-29974
- form-29975
- e-29976
- w-29977
- s-29978
- mod-29979)
- (expand-expr-4384
- type-29973
- value-29974
- form-29975
- e-29976
- trans-r-29873
- w-29977
- s-29978
- mod-29979)))
- mod-29727)))
- val-29735)))
- r-29724)
- new-w-29835
- s-29726
- mod-29727)))))
- tmp-29730)
- (syntax-violation
- #f
- "bad local syntax definition"
- (let ((x-30161
- (begin
- (if (if s-29726
- (supports-source-properties? e-29723)
- #f)
- (set-source-properties! e-29723 s-29726))
- e-29723)))
- (if (if (null? (car w-29725))
- (null? (cdr w-29725))
- #f)
- x-30161
- (if (if (vector? x-30161)
- (if (= (vector-length x-30161) 4)
- (eq? (vector-ref x-30161 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-30193 (vector-ref x-30161 1))
- (wrap-30194
- (let ((w2-30202 (vector-ref x-30161 2)))
- (let ((m1-30203 (car w-29725))
- (s1-30204 (cdr w-29725)))
- (if (null? m1-30203)
- (if (null? s1-30204)
- w2-30202
- (cons (car w2-30202)
- (let ((m2-30219 (cdr w2-30202)))
- (if (null? m2-30219)
- s1-30204
- (append s1-30204 m2-30219)))))
- (cons (let ((m2-30227 (car w2-30202)))
- (if (null? m2-30227)
- m1-30203
- (append m1-30203 m2-30227)))
- (let ((m2-30235 (cdr w2-30202)))
- (if (null? m2-30235)
- s1-30204
- (append s1-30204 m2-30235))))))))
- (module-30195 (vector-ref x-30161 3)))
- (vector
- 'syntax-object
- expression-30193
- wrap-30194
- module-30195))
- (if (null? x-30161)
- x-30161
- (vector
- 'syntax-object
- x-30161
- w-29725
- mod-29727))))))))))
- (eval-local-transformer-4389
- (lambda (expanded-30253 mod-30254)
- (let ((p-30255 (primitive-eval expanded-30253)))
- (if (procedure? p-30255)
- p-30255
- (syntax-violation
- #f
- "nonprocedure transformer"
- p-30255)))))
- (ellipsis?-4391
- (lambda (x-5924)
- (if (if (if (vector? x-5924)
- (if (= (vector-length x-5924) 4)
- (eq? (vector-ref x-5924 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-5924 1))
- #f)
- (free-id=?-4371
- x-5924
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-2325"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile)))
- #f)))
- (lambda-formals-4392
- (lambda (orig-args-30260)
- (letrec*
- ((req-30261
- (lambda (args-30265 rreq-30266)
- (let ((tmp-30268 ($sc-dispatch args-30265 '())))
- (if tmp-30268
- (@apply
- (lambda () (check-30262 (reverse rreq-30266) #f))
- tmp-30268)
- (let ((tmp-30384
- ($sc-dispatch args-30265 '(any . any))))
- (if (if tmp-30384
- (@apply
- (lambda (a-30388 b-30389)
- (if (symbol? a-30388)
- #t
- (if (if (vector? a-30388)
- (if (= (vector-length a-30388) 4)
- (eq? (vector-ref a-30388 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-30388 1))
- #f)))
- tmp-30384)
- #f)
- (@apply
- (lambda (a-30416 b-30417)
- (req-30261 b-30417 (cons a-30416 rreq-30266)))
- tmp-30384)
- (let ((tmp-30418 (list args-30265)))
- (if (@apply
- (lambda (r-30420)
- (if (symbol? r-30420)
- #t
- (if (if (vector? r-30420)
- (if (= (vector-length r-30420) 4)
- (eq? (vector-ref r-30420 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref r-30420 1))
- #f)))
- tmp-30418)
- (@apply
- (lambda (r-30450)
- (check-30262 (reverse rreq-30266) r-30450))
- tmp-30418)
- (syntax-violation
- 'lambda
- "invalid argument list"
- orig-args-30260
- args-30265)))))))))
- (check-30262
- (lambda (req-30574 rest-30575)
- (if (distinct-bound-ids?-4374
- (if rest-30575
- (cons rest-30575 req-30574)
- req-30574))
- (values req-30574 #f rest-30575 #f)
- (syntax-violation
- 'lambda
- "duplicate identifier in argument list"
- orig-args-30260)))))
- (req-30261 orig-args-30260 '()))))
- (expand-simple-lambda-4393
- (lambda (e-30684
- r-30685
- w-30686
- s-30687
- mod-30688
- req-30689
- rest-30690
- meta-30691
- body-30692)
- (let ((ids-30693
- (if rest-30690
- (append req-30689 (list rest-30690))
- req-30689)))
- (let ((vars-30694 (map gen-var-4397 ids-30693)))
- (let ((labels-30695 (gen-labels-4350 ids-30693)))
- (build-simple-lambda-4323
- s-30687
- (map syntax->datum req-30689)
- (if rest-30690 (syntax->datum rest-30690) #f)
- vars-30694
- meta-30691
- (expand-body-4387
- body-30692
- (let ((x-30878
- (begin
- (if (if s-30687
- (supports-source-properties? e-30684)
- #f)
- (set-source-properties! e-30684 s-30687))
- e-30684)))
- (if (if (null? (car w-30686))
- (null? (cdr w-30686))
- #f)
- x-30878
- (if (if (vector? x-30878)
- (if (= (vector-length x-30878) 4)
- (eq? (vector-ref x-30878 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-30910 (vector-ref x-30878 1))
- (wrap-30911
- (let ((w2-30919 (vector-ref x-30878 2)))
- (let ((m1-30920 (car w-30686))
- (s1-30921 (cdr w-30686)))
- (if (null? m1-30920)
- (if (null? s1-30921)
- w2-30919
- (cons (car w2-30919)
- (let ((m2-30936 (cdr w2-30919)))
- (if (null? m2-30936)
- s1-30921
- (append
- s1-30921
- m2-30936)))))
- (cons (let ((m2-30944 (car w2-30919)))
- (if (null? m2-30944)
- m1-30920
- (append m1-30920 m2-30944)))
- (let ((m2-30952 (cdr w2-30919)))
- (if (null? m2-30952)
- s1-30921
- (append
- s1-30921
- m2-30952))))))))
- (module-30912 (vector-ref x-30878 3)))
- (vector
- 'syntax-object
- expression-30910
- wrap-30911
- module-30912))
- (if (null? x-30878)
- x-30878
- (vector
- 'syntax-object
- x-30878
- w-30686
- mod-30688)))))
- (extend-var-env-4343
- labels-30695
- vars-30694
- r-30685)
- (make-binding-wrap-4361
- ids-30693
- labels-30695
- w-30686)
- mod-30688)))))))
- (lambda*-formals-4394
- (lambda (orig-args-31161)
- (letrec*
- ((req-31162
- (lambda (args-31169 rreq-31170)
- (let ((tmp-31172 ($sc-dispatch args-31169 '())))
- (if tmp-31172
- (@apply
- (lambda ()
- (check-31166 (reverse rreq-31170) '() #f '()))
- tmp-31172)
- (let ((tmp-31291
- ($sc-dispatch args-31169 '(any . any))))
- (if (if tmp-31291
- (@apply
- (lambda (a-31295 b-31296)
- (if (symbol? a-31295)
- #t
- (if (if (vector? a-31295)
- (if (= (vector-length a-31295) 4)
- (eq? (vector-ref a-31295 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-31295 1))
- #f)))
- tmp-31291)
- #f)
- (@apply
- (lambda (a-31323 b-31324)
- (req-31162 b-31324 (cons a-31323 rreq-31170)))
- tmp-31291)
- (let ((tmp-31325
- ($sc-dispatch args-31169 '(any . any))))
- (if (if tmp-31325
- (@apply
- (lambda (a-31329 b-31330)
- (eq? (syntax->datum a-31329) #:optional))
- tmp-31325)
- #f)
- (@apply
- (lambda (a-31331 b-31332)
- (opt-31163 b-31332 (reverse rreq-31170) '()))
- tmp-31325)
- (let ((tmp-31335
- ($sc-dispatch args-31169 '(any . any))))
- (if (if tmp-31335
- (@apply
- (lambda (a-31339 b-31340)
- (eq? (syntax->datum a-31339) #:key))
- tmp-31335)
- #f)
- (@apply
- (lambda (a-31341 b-31342)
- (key-31164
- b-31342
- (reverse rreq-31170)
- '()
- '()))
- tmp-31335)
- (let ((tmp-31345
- ($sc-dispatch args-31169 '(any any))))
- (if (if tmp-31345
- (@apply
- (lambda (a-31349 b-31350)
- (eq? (syntax->datum a-31349)
- #:rest))
- tmp-31345)
- #f)
- (@apply
- (lambda (a-31351 b-31352)
- (rest-31165
- b-31352
- (reverse rreq-31170)
- '()
- '()))
- tmp-31345)
- (let ((tmp-31355 (list args-31169)))
- (if (@apply
- (lambda (r-31357)
- (if (symbol? r-31357)
- #t
- (if (if (vector? r-31357)
- (if (= (vector-length
- r-31357)
- 4)
- (eq? (vector-ref
- r-31357
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref r-31357 1))
- #f)))
- tmp-31355)
- (@apply
- (lambda (r-31387)
- (rest-31165
- r-31387
- (reverse rreq-31170)
- '()
- '()))
- tmp-31355)
- (syntax-violation
- 'lambda*
- "invalid argument list"
- orig-args-31161
- args-31169)))))))))))))))
- (opt-31163
- (lambda (args-31406 req-31407 ropt-31408)
- (let ((tmp-31410 ($sc-dispatch args-31406 '())))
- (if tmp-31410
- (@apply
- (lambda ()
- (check-31166
- req-31407
- (reverse ropt-31408)
- #f
- '()))
- tmp-31410)
- (let ((tmp-31531
- ($sc-dispatch args-31406 '(any . any))))
- (if (if tmp-31531
- (@apply
- (lambda (a-31535 b-31536)
- (if (symbol? a-31535)
- #t
- (if (if (vector? a-31535)
- (if (= (vector-length a-31535) 4)
- (eq? (vector-ref a-31535 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-31535 1))
- #f)))
- tmp-31531)
- #f)
- (@apply
- (lambda (a-31563 b-31564)
- (opt-31163
- b-31564
- req-31407
- (cons (cons a-31563
- '(#(syntax-object
- #f
- ((top)
- #(ribcage
- #(a b)
- #((top) (top))
- #("l-*-2462" "l-*-2463"))
- #(ribcage () () ())
- #(ribcage
- #(args req ropt)
- #((top) (top) (top))
- #("l-*-2452"
- "l-*-2453"
- "l-*-2454"))
- #(ribcage
- (check rest key opt req)
- ((top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-2398"
- "l-*-2396"
- "l-*-2394"
- "l-*-2392"
- "l-*-2390"))
- #(ribcage
- #(orig-args)
- #((top))
- #("l-*-2389"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile))))
- ropt-31408)))
- tmp-31531)
- (let ((tmp-31565
- ($sc-dispatch args-31406 '((any any) . any))))
- (if (if tmp-31565
- (@apply
- (lambda (a-31569 init-31570 b-31571)
- (if (symbol? a-31569)
- #t
- (if (if (vector? a-31569)
- (if (= (vector-length a-31569) 4)
- (eq? (vector-ref a-31569 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-31569 1))
- #f)))
- tmp-31565)
- #f)
- (@apply
- (lambda (a-31598 init-31599 b-31600)
- (opt-31163
- b-31600
- req-31407
- (cons (list a-31598 init-31599) ropt-31408)))
- tmp-31565)
- (let ((tmp-31601
- ($sc-dispatch args-31406 '(any . any))))
- (if (if tmp-31601
- (@apply
- (lambda (a-31605 b-31606)
- (eq? (syntax->datum a-31605) #:key))
- tmp-31601)
- #f)
- (@apply
- (lambda (a-31607 b-31608)
- (key-31164
- b-31608
- req-31407
- (reverse ropt-31408)
- '()))
- tmp-31601)
- (let ((tmp-31611
- ($sc-dispatch args-31406 '(any any))))
- (if (if tmp-31611
- (@apply
- (lambda (a-31615 b-31616)
- (eq? (syntax->datum a-31615)
- #:rest))
- tmp-31611)
- #f)
- (@apply
- (lambda (a-31617 b-31618)
- (rest-31165
- b-31618
- req-31407
- (reverse ropt-31408)
- '()))
- tmp-31611)
- (let ((tmp-31621 (list args-31406)))
- (if (@apply
- (lambda (r-31623)
- (if (symbol? r-31623)
- #t
- (if (if (vector? r-31623)
- (if (= (vector-length
- r-31623)
- 4)
- (eq? (vector-ref
- r-31623
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref r-31623 1))
- #f)))
- tmp-31621)
- (@apply
- (lambda (r-31653)
- (rest-31165
- r-31653
- req-31407
- (reverse ropt-31408)
- '()))
- tmp-31621)
- (syntax-violation
- 'lambda*
- "invalid optional argument list"
- orig-args-31161
- args-31406)))))))))))))))
- (key-31164
- (lambda (args-31672 req-31673 opt-31674 rkey-31675)
- (let ((tmp-31677 ($sc-dispatch args-31672 '())))
- (if tmp-31677
- (@apply
- (lambda ()
- (check-31166
- req-31673
- opt-31674
- #f
- (cons #f (reverse rkey-31675))))
- tmp-31677)
- (let ((tmp-31799
- ($sc-dispatch args-31672 '(any . any))))
- (if (if tmp-31799
- (@apply
- (lambda (a-31803 b-31804)
- (if (symbol? a-31803)
- #t
- (if (if (vector? a-31803)
- (if (= (vector-length a-31803) 4)
- (eq? (vector-ref a-31803 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-31803 1))
- #f)))
- tmp-31799)
- #f)
- (@apply
- (lambda (a-31831 b-31832)
- (let ((tmp-31833
- (symbol->keyword (syntax->datum a-31831))))
- (key-31164
- b-31832
- req-31673
- opt-31674
- (cons (cons tmp-31833
- (cons a-31831
- '(#(syntax-object
- #f
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(k)
- #((top))
- #("l-*-2525"))
- #(ribcage
- #(a b)
- #((top) (top))
- #("l-*-2519"
- "l-*-2520"))
- #(ribcage () () ())
- #(ribcage
- #(args req opt rkey)
- #((top)
- (top)
- (top)
- (top))
- #("l-*-2508"
- "l-*-2509"
- "l-*-2510"
- "l-*-2511"))
- #(ribcage
- (check rest
- key
- opt
- req)
- ((top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-2398"
- "l-*-2396"
- "l-*-2394"
- "l-*-2392"
- "l-*-2390"))
- #(ribcage
- #(orig-args)
- #((top))
- #("l-*-2389"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile)))))
- rkey-31675))))
- tmp-31799)
- (let ((tmp-31836
- ($sc-dispatch args-31672 '((any any) . any))))
- (if (if tmp-31836
- (@apply
- (lambda (a-31840 init-31841 b-31842)
- (if (symbol? a-31840)
- #t
- (if (if (vector? a-31840)
- (if (= (vector-length a-31840) 4)
- (eq? (vector-ref a-31840 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-31840 1))
- #f)))
- tmp-31836)
- #f)
- (@apply
- (lambda (a-31869 init-31870 b-31871)
- (let ((tmp-31872
- (symbol->keyword
- (syntax->datum a-31869))))
- (key-31164
- b-31871
- req-31673
- opt-31674
- (cons (list tmp-31872 a-31869 init-31870)
- rkey-31675))))
- tmp-31836)
- (let ((tmp-31875
- ($sc-dispatch
- args-31672
- '((any any any) . any))))
- (if (if tmp-31875
- (@apply
- (lambda (a-31879
- init-31880
- k-31881
- b-31882)
- (if (if (symbol? a-31879)
- #t
- (if (if (vector? a-31879)
- (if (= (vector-length
- a-31879)
- 4)
- (eq? (vector-ref
- a-31879
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref a-31879 1))
- #f))
- (keyword? (syntax->datum k-31881))
- #f))
- tmp-31875)
- #f)
- (@apply
- (lambda (a-31909 init-31910 k-31911 b-31912)
- (key-31164
- b-31912
- req-31673
- opt-31674
- (cons (list k-31911 a-31909 init-31910)
- rkey-31675)))
- tmp-31875)
- (let ((tmp-31913
- ($sc-dispatch args-31672 '(any))))
- (if (if tmp-31913
- (@apply
- (lambda (aok-31917)
- (eq? (syntax->datum aok-31917)
- #:allow-other-keys))
- tmp-31913)
- #f)
- (@apply
- (lambda (aok-31918)
- (check-31166
- req-31673
- opt-31674
- #f
- (cons #t (reverse rkey-31675))))
- tmp-31913)
- (let ((tmp-32037
- ($sc-dispatch
- args-31672
- '(any any any))))
- (if (if tmp-32037
- (@apply
- (lambda (aok-32041
- a-32042
- b-32043)
- (if (eq? (syntax->datum
- aok-32041)
- #:allow-other-keys)
- (eq? (syntax->datum a-32042)
- #:rest)
- #f))
- tmp-32037)
- #f)
- (@apply
- (lambda (aok-32044 a-32045 b-32046)
- (rest-31165
- b-32046
- req-31673
- opt-31674
- (cons #t (reverse rkey-31675))))
- tmp-32037)
- (let ((tmp-32049
- ($sc-dispatch
- args-31672
- '(any . any))))
- (if (if tmp-32049
- (@apply
- (lambda (aok-32053 r-32054)
- (if (eq? (syntax->datum
- aok-32053)
- #:allow-other-keys)
- (if (symbol? r-32054)
- #t
- (if (if (vector?
- r-32054)
- (if (= (vector-length
- r-32054)
- 4)
- (eq? (vector-ref
- r-32054
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- r-32054
- 1))
- #f))
- #f))
- tmp-32049)
- #f)
- (@apply
- (lambda (aok-32081 r-32082)
- (rest-31165
- r-32082
- req-31673
- opt-31674
- (cons #t
- (reverse rkey-31675))))
- tmp-32049)
- (let ((tmp-32085
- ($sc-dispatch
- args-31672
- '(any any))))
- (if (if tmp-32085
- (@apply
- (lambda (a-32089 b-32090)
- (eq? (syntax->datum
- a-32089)
- #:rest))
- tmp-32085)
- #f)
- (@apply
- (lambda (a-32091 b-32092)
- (rest-31165
- b-32092
- req-31673
- opt-31674
- (cons #f
- (reverse
- rkey-31675))))
- tmp-32085)
- (let ((tmp-32095
- (list args-31672)))
- (if (@apply
- (lambda (r-32097)
- (if (symbol? r-32097)
- #t
- (if (if (vector?
- r-32097)
- (if (= (vector-length
- r-32097)
- 4)
- (eq? (vector-ref
- r-32097
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- r-32097
- 1))
- #f)))
- tmp-32095)
- (@apply
- (lambda (r-32127)
- (rest-31165
- r-32127
- req-31673
- opt-31674
- (cons #f
- (reverse
- rkey-31675))))
- tmp-32095)
- (syntax-violation
- 'lambda*
- "invalid keyword argument list"
- orig-args-31161
- args-31672)))))))))))))))))))))
- (rest-31165
- (lambda (args-32155 req-32156 opt-32157 kw-32158)
- (let ((tmp-32160 (list args-32155)))
- (if (@apply
- (lambda (r-32162)
- (if (symbol? r-32162)
- #t
- (if (if (vector? r-32162)
- (if (= (vector-length r-32162) 4)
- (eq? (vector-ref r-32162 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref r-32162 1))
- #f)))
- tmp-32160)
- (@apply
- (lambda (r-32192)
- (check-31166
- req-32156
- opt-32157
- r-32192
- kw-32158))
- tmp-32160)
- (syntax-violation
- 'lambda*
- "invalid rest argument"
- orig-args-31161
- args-32155)))))
- (check-31166
- (lambda (req-32320 opt-32321 rest-32322 kw-32323)
- (if (distinct-bound-ids?-4374
- (append
- req-32320
- (map car opt-32321)
- (if rest-32322 (list rest-32322) '())
- (if (pair? kw-32323)
- (map cadr (cdr kw-32323))
- '())))
- (values req-32320 opt-32321 rest-32322 kw-32323)
- (syntax-violation
- 'lambda*
- "duplicate identifier in argument list"
- orig-args-31161)))))
- (req-31162 orig-args-31161 '()))))
- (expand-lambda-case-4395
- (lambda (e-32432
- r-32433
- w-32434
- s-32435
- mod-32436
- get-formals-32437
- clauses-32438)
- (letrec*
- ((parse-req-32439
- (lambda (req-32572
- opt-32573
- rest-32574
- kw-32575
- body-32576)
- (let ((vars-32577 (map gen-var-4397 req-32572))
- (labels-32578 (gen-labels-4350 req-32572)))
- (let ((r*-32579
- (extend-var-env-4343
- labels-32578
- vars-32577
- r-32433))
- (w*-32580
- (make-binding-wrap-4361
- req-32572
- labels-32578
- w-32434)))
- (parse-opt-32440
- (map syntax->datum req-32572)
- opt-32573
- rest-32574
- kw-32575
- body-32576
- (reverse vars-32577)
- r*-32579
- w*-32580
- '()
- '())))))
- (parse-opt-32440
- (lambda (req-32777
- opt-32778
- rest-32779
- kw-32780
- body-32781
- vars-32782
- r*-32783
- w*-32784
- out-32785
- inits-32786)
- (if (pair? opt-32778)
- (let ((tmp-32787 (car opt-32778)))
- (let ((tmp-32788 ($sc-dispatch tmp-32787 '(any any))))
- (if tmp-32788
- (@apply
- (lambda (id-32790 i-32791)
- (let ((v-32792
- (let ((id-32800
- (if (if (vector? id-32790)
- (if (= (vector-length
- id-32790)
- 4)
- (eq? (vector-ref
- id-32790
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-32790 1)
- id-32790)))
- (gensym
- (string-append
- (symbol->string id-32800)
- "-")))))
- (let ((l-32793 (gen-labels-4350 (list v-32792))))
- (let ((r**-32794
- (extend-var-env-4343
- l-32793
- (list v-32792)
- r*-32783)))
- (let ((w**-32795
- (make-binding-wrap-4361
- (list id-32790)
- l-32793
- w*-32784)))
- (parse-opt-32440
- req-32777
- (cdr opt-32778)
- rest-32779
- kw-32780
- body-32781
- (cons v-32792 vars-32782)
- r**-32794
- w**-32795
- (cons (syntax->datum id-32790) out-32785)
- (cons (call-with-values
- (lambda ()
- (syntax-type-4382
- i-32791
- r*-32783
- w*-32784
- (let ((props-32877
- (source-properties
- (if (if (vector?
- i-32791)
- (if (= (vector-length
- i-32791)
- 4)
- (eq? (vector-ref
- i-32791
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- i-32791
- 1)
- i-32791))))
- (if (pair? props-32877)
- props-32877
- #f))
- #f
- mod-32436
- #f))
- (lambda (type-32910
- value-32911
- form-32912
- e-32913
- w-32914
- s-32915
- mod-32916)
- (expand-expr-4384
- type-32910
- value-32911
- form-32912
- e-32913
- r*-32783
- w-32914
- s-32915
- mod-32916)))
- inits-32786)))))))
- tmp-32788)
+ "sequence of zero expressions"
+ (source-wrap e w s mod)))
+ tmp-1)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-32787))))
- (if rest-32779
- (let ((v-33039
- (let ((id-33049
- (if (if (vector? rest-32779)
- (if (= (vector-length rest-32779) 4)
- (eq? (vector-ref rest-32779 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref rest-32779 1)
- rest-32779)))
- (gensym
- (string-append
- (symbol->string id-33049)
- "-")))))
- (let ((l-33040 (gen-labels-4350 (list v-33039))))
- (let ((r*-33041
- (extend-var-env-4343
- l-33040
- (list v-33039)
- r*-32783)))
- (let ((w*-33042
- (make-binding-wrap-4361
- (list rest-32779)
- l-33040
- w*-32784)))
- (parse-kw-32441
- req-32777
- (if (pair? out-32785) (reverse out-32785) #f)
- (syntax->datum rest-32779)
- (if (pair? kw-32780) (cdr kw-32780) kw-32780)
- body-32781
- (cons v-33039 vars-32782)
- r*-33041
- w*-33042
- (if (pair? kw-32780) (car kw-32780) #f)
- '()
- inits-32786)))))
- (parse-kw-32441
- req-32777
- (if (pair? out-32785) (reverse out-32785) #f)
+ tmp))))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax value e r w s mod expand-sequence))
+ ((memv key '(eval-when-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
+ (if tmp
+ (apply (lambda (x e1 e2)
+ (let ((when-list (parse-when-list e x)))
+ (if (memq 'eval when-list)
+ (expand-sequence (cons e1 e2) r w s mod)
+ (expand-void))))
+ tmp)
+ (syntax-violation
#f
- (if (pair? kw-32780) (cdr kw-32780) kw-32780)
- body-32781
- vars-32782
- r*-32783
- w*-32784
- (if (pair? kw-32780) (car kw-32780) #f)
- '()
- inits-32786)))))
- (parse-kw-32441
- (lambda (req-33232
- opt-33233
- rest-33234
- kw-33235
- body-33236
- vars-33237
- r*-33238
- w*-33239
- aok-33240
- out-33241
- inits-33242)
- (if (pair? kw-33235)
- (let ((tmp-33243 (car kw-33235)))
- (let ((tmp-33244
- ($sc-dispatch tmp-33243 '(any any any))))
- (if tmp-33244
- (@apply
- (lambda (k-33246 id-33247 i-33248)
- (let ((v-33249
- (let ((id-33257
- (if (if (vector? id-33247)
- (if (= (vector-length
- id-33247)
- 4)
- (eq? (vector-ref
- id-33247
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-33247 1)
- id-33247)))
- (gensym
- (string-append
- (symbol->string id-33257)
- "-")))))
- (let ((l-33250 (gen-labels-4350 (list v-33249))))
- (let ((r**-33251
- (extend-var-env-4343
- l-33250
- (list v-33249)
- r*-33238)))
- (let ((w**-33252
- (make-binding-wrap-4361
- (list id-33247)
- l-33250
- w*-33239)))
- (parse-kw-32441
- req-33232
- opt-33233
- rest-33234
- (cdr kw-33235)
- body-33236
- (cons v-33249 vars-33237)
- r**-33251
- w**-33252
- aok-33240
- (cons (list (syntax->datum k-33246)
- (syntax->datum id-33247)
- v-33249)
- out-33241)
- (cons (call-with-values
- (lambda ()
- (syntax-type-4382
- i-33248
- r*-33238
- w*-33239
- (let ((props-33334
- (source-properties
- (if (if (vector?
- i-33248)
- (if (= (vector-length
- i-33248)
- 4)
- (eq? (vector-ref
- i-33248
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- i-33248
- 1)
- i-33248))))
- (if (pair? props-33334)
- props-33334
- #f))
- #f
- mod-32436
- #f))
- (lambda (type-33367
- value-33368
- form-33369
- e-33370
- w-33371
- s-33372
- mod-33373)
- (expand-expr-4384
- type-33367
- value-33368
- form-33369
- e-33370
- r*-33238
- w-33371
- s-33372
- mod-33373)))
- inits-33242)))))))
- tmp-33244)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-33243))))
- (parse-body-32442
- req-33232
- opt-33233
- rest-33234
- (if (if aok-33240 aok-33240 (pair? out-33241))
- (cons aok-33240 (reverse out-33241))
- #f)
- body-33236
- (reverse vars-33237)
- r*-33238
- w*-33239
- (reverse inits-33242)
- '()))))
- (parse-body-32442
- (lambda (req-33505
- opt-33506
- rest-33507
- kw-33508
- body-33509
- vars-33510
- r*-33511
- w*-33512
- inits-33513
- meta-33514)
- (let ((tmp-33516
- ($sc-dispatch body-33509 '(any any . each-any))))
- (if (if tmp-33516
- (@apply
- (lambda (docstring-33520 e1-33521 e2-33522)
- (string? (syntax->datum docstring-33520)))
- tmp-33516)
- #f)
- (@apply
- (lambda (docstring-33523 e1-33524 e2-33525)
- (parse-body-32442
- req-33505
- opt-33506
- rest-33507
- kw-33508
- (cons e1-33524 e2-33525)
- vars-33510
- r*-33511
- w*-33512
- inits-33513
- (append
- meta-33514
- (list (cons 'documentation
- (syntax->datum docstring-33523))))))
- tmp-33516)
- (let ((tmp-33526
- ($sc-dispatch
- body-33509
- '(#(vector #(each (any . any)))
- any
- .
- each-any))))
- (if tmp-33526
- (@apply
- (lambda (k-33530 v-33531 e1-33532 e2-33533)
- (parse-body-32442
- req-33505
- opt-33506
- rest-33507
- kw-33508
- (cons e1-33532 e2-33533)
- vars-33510
- r*-33511
- w*-33512
- inits-33513
- (append
- meta-33514
- (syntax->datum (map cons k-33530 v-33531)))))
- tmp-33526)
- (let ((tmp-33534
- ($sc-dispatch body-33509 '(any . each-any))))
- (if tmp-33534
- (@apply
- (lambda (e1-33538 e2-33539)
- (values
- meta-33514
- req-33505
- opt-33506
- rest-33507
- kw-33508
- inits-33513
- vars-33510
- (expand-body-4387
- (cons e1-33538 e2-33539)
- (let ((x-33551
- (begin
- (if (if s-32435
- (supports-source-properties?
- e-32432)
- #f)
- (set-source-properties!
- e-32432
- s-32435))
- e-32432)))
- (if (if (null? (car w-32434))
- (null? (cdr w-32434))
- #f)
- x-33551
- (if (if (vector? x-33551)
- (if (= (vector-length x-33551) 4)
- (eq? (vector-ref x-33551 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-33583
- (vector-ref x-33551 1))
- (wrap-33584
- (let ((w2-33592
- (vector-ref
- x-33551
- 2)))
- (let ((m1-33593
- (car w-32434))
- (s1-33594
- (cdr w-32434)))
- (if (null? m1-33593)
- (if (null? s1-33594)
- w2-33592
- (cons (car w2-33592)
- (let ((m2-33609
- (cdr w2-33592)))
- (if (null? m2-33609)
- s1-33594
- (append
- s1-33594
- m2-33609)))))
- (cons (let ((m2-33617
- (car w2-33592)))
- (if (null? m2-33617)
- m1-33593
- (append
- m1-33593
- m2-33617)))
- (let ((m2-33625
- (cdr w2-33592)))
- (if (null? m2-33625)
- s1-33594
- (append
- s1-33594
- m2-33625))))))))
- (module-33585
- (vector-ref x-33551 3)))
- (vector
- 'syntax-object
- expression-33583
- wrap-33584
- module-33585))
- (if (null? x-33551)
- x-33551
- (vector
- 'syntax-object
- x-33551
- w-32434
- mod-32436)))))
- r*-33511
- w*-33512
- mod-32436)))
- tmp-33534)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- body-33509))))))))))
- (let ((tmp-32444 ($sc-dispatch clauses-32438 '())))
- (if tmp-32444
- (@apply (lambda () (values '() #f)) tmp-32444)
- (let ((tmp-32448
- ($sc-dispatch
- clauses-32438
- '((any any . each-any)
- .
- #(each (any any . each-any))))))
- (if tmp-32448
- (@apply
- (lambda (args-32452
- e1-32453
- e2-32454
- args*-32455
- e1*-32456
- e2*-32457)
- (call-with-values
- (lambda () (get-formals-32437 args-32452))
- (lambda (req-32458 opt-32459 rest-32460 kw-32461)
- (call-with-values
- (lambda ()
- (parse-req-32439
- req-32458
- opt-32459
- rest-32460
- kw-32461
- (cons e1-32453 e2-32454)))
- (lambda (meta-32528
- req-32529
- opt-32530
- rest-32531
- kw-32532
- inits-32533
- vars-32534
- body-32535)
- (call-with-values
- (lambda ()
- (expand-lambda-case-4395
- e-32432
- r-32433
- w-32434
- s-32435
- mod-32436
- get-formals-32437
- (map (lambda (tmp-2860-32536
- tmp-2859-32537
- tmp-2858-32538)
- (cons tmp-2858-32538
- (cons tmp-2859-32537
- tmp-2860-32536)))
- e2*-32457
- e1*-32456
- args*-32455)))
- (lambda (meta*-32539 else*-32540)
- (values
- (append meta-32528 meta*-32539)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 15)
- s-32435
- req-32529
- opt-32530
- rest-32531
- kw-32532
- inits-32533
- vars-32534
- body-32535
- else*-32540)))))))))
- tmp-32448)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- clauses-32438))))))))
- (strip-4396
- (lambda (x-33652 w-33653)
- (if (memq 'top (car w-33653))
- x-33652
- (letrec*
- ((f-33654
- (lambda (x-33657)
- (if (if (vector? x-33657)
- (if (= (vector-length x-33657) 4)
- (eq? (vector-ref x-33657 0) 'syntax-object)
- #f)
- #f)
- (strip-4396
- (vector-ref x-33657 1)
- (vector-ref x-33657 2))
- (if (pair? x-33657)
- (let ((a-33676 (f-33654 (car x-33657)))
- (d-33677 (f-33654 (cdr x-33657))))
- (if (if (eq? a-33676 (car x-33657))
- (eq? d-33677 (cdr x-33657))
- #f)
- x-33657
- (cons a-33676 d-33677)))
- (if (vector? x-33657)
- (let ((old-33680 (vector->list x-33657)))
- (let ((new-33681 (map f-33654 old-33680)))
- (letrec*
- ((lp-33682
- (lambda (l1-33779 l2-33780)
- (if (null? l1-33779)
- x-33657
- (if (eq? (car l1-33779) (car l2-33780))
- (lp-33682 (cdr l1-33779) (cdr l2-33780))
- (list->vector new-33681))))))
- (lp-33682 old-33680 new-33681))))
- x-33657))))))
- (f-33654 x-33652)))))
- (gen-var-4397
- (lambda (id-32584)
- (let ((id-32585
- (if (if (vector? id-32584)
- (if (= (vector-length id-32584) 4)
- (eq? (vector-ref id-32584 0) 'syntax-object)
- #f)
- #f)
- (vector-ref id-32584 1)
- id-32584)))
- (gensym
- (string-append (symbol->string id-32585) "-")))))
- (lambda-var-list-4398
- (lambda (vars-33781)
- (letrec*
- ((lvl-33782
- (lambda (vars-33785 ls-33786 w-33787)
- (if (pair? vars-33785)
- (lvl-33782
- (cdr vars-33785)
- (cons (let ((x-33791 (car vars-33785)))
- (if (if (null? (car w-33787))
- (null? (cdr w-33787))
- #f)
- x-33791
- (if (if (vector? x-33791)
- (if (= (vector-length x-33791) 4)
- (eq? (vector-ref x-33791 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-33809 (vector-ref x-33791 1))
- (wrap-33810
- (let ((w2-33818
- (vector-ref x-33791 2)))
- (let ((m1-33819 (car w-33787))
- (s1-33820 (cdr w-33787)))
- (if (null? m1-33819)
- (if (null? s1-33820)
- w2-33818
- (cons (car w2-33818)
- (let ((m2-33835
- (cdr w2-33818)))
- (if (null? m2-33835)
- s1-33820
- (append
- s1-33820
- m2-33835)))))
- (cons (let ((m2-33843
- (car w2-33818)))
- (if (null? m2-33843)
- m1-33819
- (append
- m1-33819
- m2-33843)))
- (let ((m2-33851
- (cdr w2-33818)))
- (if (null? m2-33851)
- s1-33820
- (append
- s1-33820
- m2-33851))))))))
- (module-33811 (vector-ref x-33791 3)))
- (vector
- 'syntax-object
- expression-33809
- wrap-33810
- module-33811))
- (if (null? x-33791)
- x-33791
- (vector
- 'syntax-object
- x-33791
- w-33787
- #f)))))
- ls-33786)
- w-33787)
- (if (if (symbol? vars-33785)
- #t
- (if (if (vector? vars-33785)
- (if (= (vector-length vars-33785) 4)
- (eq? (vector-ref vars-33785 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref vars-33785 1))
- #f))
- (cons (if (if (null? (car w-33787))
- (null? (cdr w-33787))
- #f)
- vars-33785
- (if (if (vector? vars-33785)
- (if (= (vector-length vars-33785) 4)
- (eq? (vector-ref vars-33785 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-33921
- (vector-ref vars-33785 1))
- (wrap-33922
- (let ((w2-33932
- (vector-ref vars-33785 2)))
- (let ((m1-33933 (car w-33787))
- (s1-33934 (cdr w-33787)))
- (if (null? m1-33933)
- (if (null? s1-33934)
- w2-33932
- (cons (car w2-33932)
- (let ((m2-33951
- (cdr w2-33932)))
- (if (null? m2-33951)
- s1-33934
- (append
- s1-33934
- m2-33951)))))
- (cons (let ((m2-33959
- (car w2-33932)))
- (if (null? m2-33959)
- m1-33933
- (append
- m1-33933
- m2-33959)))
- (let ((m2-33967
- (cdr w2-33932)))
- (if (null? m2-33967)
- s1-33934
- (append
- s1-33934
- m2-33967))))))))
- (module-33923 (vector-ref vars-33785 3)))
- (vector
- 'syntax-object
- expression-33921
- wrap-33922
- module-33923))
- (if (null? vars-33785)
- vars-33785
- (vector
- 'syntax-object
- vars-33785
- w-33787
- #f))))
- ls-33786)
- (if (null? vars-33785)
- ls-33786
- (if (if (vector? vars-33785)
- (if (= (vector-length vars-33785) 4)
- (eq? (vector-ref vars-33785 0) 'syntax-object)
- #f)
- #f)
- (lvl-33782
- (vector-ref vars-33785 1)
- ls-33786
- (let ((w2-34008 (vector-ref vars-33785 2)))
- (let ((m1-34009 (car w-33787))
- (s1-34010 (cdr w-33787)))
- (if (null? m1-34009)
- (if (null? s1-34010)
- w2-34008
- (cons (car w2-34008)
- (let ((m2-34021 (cdr w2-34008)))
- (if (null? m2-34021)
- s1-34010
- (append s1-34010 m2-34021)))))
- (cons (let ((m2-34029 (car w2-34008)))
- (if (null? m2-34029)
- m1-34009
- (append m1-34009 m2-34029)))
- (let ((m2-34037 (cdr w2-34008)))
- (if (null? m2-34037)
- s1-34010
- (append s1-34010 m2-34037))))))))
- (cons vars-33785 ls-33786))))))))
- (lvl-33782 vars-33781 '() '(()))))))
- (begin
- (lambda (x-17960) (vector-ref x-17960 3))
- (set! session-id-4308
- (let ((v-17746
- (module-variable
- (current-module)
- 'syntax-session-id)))
- (lambda () ((variable-ref v-17746)))))
- (set! transformer-environment-4369
- (make-fluid
- (lambda (k-16379)
- (error "called outside the dynamic extent of a syntax transformer"))))
- (module-define!
- (current-module)
- 'letrec-syntax
- (make-syntax-transformer
- 'letrec-syntax
- 'local-syntax
- #t))
- (module-define!
- (current-module)
- 'let-syntax
- (make-syntax-transformer
- 'let-syntax
- 'local-syntax
- #f))
- (global-extend-4345
- 'core
- 'syntax-parameterize
- (lambda (e-4525 r-4526 w-4527 s-4528 mod-4529)
- (let ((tmp-4531
- ($sc-dispatch
- e-4525
- '(_ #(each (any any)) any . each-any))))
- (if (if tmp-4531
- (@apply
- (lambda (var-4535 val-4536 e1-4537 e2-4538)
- (valid-bound-ids?-4373 var-4535))
- tmp-4531)
- #f)
- (@apply
- (lambda (var-4623 val-4624 e1-4625 e2-4626)
- (let ((names-4627
- (map (lambda (x-4971)
- (call-with-values
- (lambda ()
- (resolve-identifier-4368
- x-4971
- w-4527
- r-4526
- mod-4529
- #f))
- (lambda (type-4974 value-4975 mod-4976)
- (if (eqv? type-4974 'displaced-lexical)
- (syntax-violation
- 'syntax-parameterize
- "identifier out of context"
- e-4525
- (let ((x-4993
- (begin
- (if (if s-4528
- (supports-source-properties?
- x-4971)
- #f)
- (set-source-properties!
- x-4971
- s-4528))
- x-4971)))
- (if (if (null? (car w-4527))
- (null? (cdr w-4527))
- #f)
- x-4993
- (if (if (vector? x-4993)
- (if (= (vector-length
- x-4993)
- 4)
- (eq? (vector-ref x-4993 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-5025
- (vector-ref x-4993 1))
- (wrap-5026
- (let ((w2-5034
- (vector-ref
- x-4993
- 2)))
- (let ((m1-5035
- (car w-4527))
- (s1-5036
- (cdr w-4527)))
- (if (null? m1-5035)
- (if (null? s1-5036)
- w2-5034
- (cons (car w2-5034)
- (let ((m2-5051
- (cdr w2-5034)))
- (if (null? m2-5051)
- s1-5036
- (append
- s1-5036
- m2-5051)))))
- (cons (let ((m2-5059
- (car w2-5034)))
- (if (null? m2-5059)
- m1-5035
- (append
- m1-5035
- m2-5059)))
- (let ((m2-5067
- (cdr w2-5034)))
- (if (null? m2-5067)
- s1-5036
- (append
- s1-5036
- m2-5067))))))))
- (module-5027
- (vector-ref x-4993 3)))
- (vector
- 'syntax-object
- expression-5025
- wrap-5026
- module-5027))
- (if (null? x-4993)
- x-4993
- (vector
- 'syntax-object
- x-4993
- w-4527
- mod-4976))))))
- (if (eqv? type-4974 'syntax-parameter)
- value-4975
- (syntax-violation
- 'syntax-parameterize
- "invalid syntax parameter"
- e-4525
- (let ((x-5097
- (begin
- (if (if s-4528
- (supports-source-properties?
- x-4971)
- #f)
- (set-source-properties!
- x-4971
- s-4528))
- x-4971)))
- (if (if (null? (car w-4527))
- (null? (cdr w-4527))
- #f)
- x-5097
- (if (if (vector? x-5097)
- (if (= (vector-length
- x-5097)
- 4)
- (eq? (vector-ref
- x-5097
- 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-5129
- (vector-ref x-5097 1))
- (wrap-5130
- (let ((w2-5138
- (vector-ref
- x-5097
- 2)))
- (let ((m1-5139
- (car w-4527))
- (s1-5140
- (cdr w-4527)))
- (if (null? m1-5139)
- (if (null? s1-5140)
- w2-5138
- (cons (car w2-5138)
- (let ((m2-5155
- (cdr w2-5138)))
- (if (null? m2-5155)
- s1-5140
- (append
- s1-5140
- m2-5155)))))
- (cons (let ((m2-5163
- (car w2-5138)))
- (if (null? m2-5163)
- m1-5139
- (append
- m1-5139
- m2-5163)))
- (let ((m2-5171
- (cdr w2-5138)))
- (if (null? m2-5171)
- s1-5140
- (append
- s1-5140
- m2-5171))))))))
- (module-5131
- (vector-ref
- x-5097
- 3)))
- (vector
- 'syntax-object
- expression-5129
- wrap-5130
- module-5131))
- (if (null? x-5097)
- x-5097
- (vector
- 'syntax-object
- x-5097
- w-4527
- mod-4976)))))))))))
- var-4623))
- (bindings-4628
- (let ((trans-r-5186 (macros-only-env-4344 r-4526)))
- (map (lambda (x-5187)
- (cons 'macro
- (eval-local-transformer-4389
- (call-with-values
- (lambda ()
- (syntax-type-4382
- x-5187
- trans-r-5186
- w-4527
- (let ((props-5250
- (source-properties
- (if (if (vector?
- x-5187)
- (if (= (vector-length
- x-5187)
- 4)
- (eq? (vector-ref
- x-5187
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- x-5187
- 1)
- x-5187))))
- (if (pair? props-5250)
- props-5250
- #f))
- #f
- mod-4529
- #f))
- (lambda (type-5283
- value-5284
- form-5285
- e-5286
- w-5287
- s-5288
- mod-5289)
- (expand-expr-4384
- type-5283
- value-5284
- form-5285
- e-5286
- trans-r-5186
- w-5287
- s-5288
- mod-5289)))
- mod-4529)))
- val-4624))))
- (expand-body-4387
- (cons e1-4625 e2-4626)
- (let ((x-4640
- (begin
- (if (if s-4528
- (supports-source-properties? e-4525)
- #f)
- (set-source-properties! e-4525 s-4528))
- e-4525)))
- (if (if (null? (car w-4527)) (null? (cdr w-4527)) #f)
- x-4640
- (if (if (vector? x-4640)
- (if (= (vector-length x-4640) 4)
- (eq? (vector-ref x-4640 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-4672 (vector-ref x-4640 1))
- (wrap-4673
- (let ((w2-4681 (vector-ref x-4640 2)))
- (let ((m1-4682 (car w-4527))
- (s1-4683 (cdr w-4527)))
- (if (null? m1-4682)
- (if (null? s1-4683)
- w2-4681
- (cons (car w2-4681)
- (let ((m2-4698
- (cdr w2-4681)))
- (if (null? m2-4698)
- s1-4683
- (append
- s1-4683
- m2-4698)))))
- (cons (let ((m2-4706 (car w2-4681)))
- (if (null? m2-4706)
- m1-4682
- (append m1-4682 m2-4706)))
- (let ((m2-4714 (cdr w2-4681)))
- (if (null? m2-4714)
- s1-4683
- (append
- s1-4683
- m2-4714))))))))
- (module-4674 (vector-ref x-4640 3)))
- (vector
- 'syntax-object
- expression-4672
- wrap-4673
- module-4674))
- (if (null? x-4640)
- x-4640
- (vector
- 'syntax-object
- x-4640
- w-4527
- mod-4529)))))
- (extend-env-4342 names-4627 bindings-4628 r-4526)
- w-4527
- mod-4529)))
- tmp-4531)
- (syntax-violation
- 'syntax-parameterize
- "bad syntax"
- (let ((x-5388
- (begin
- (if (if s-4528
- (supports-source-properties? e-4525)
- #f)
- (set-source-properties! e-4525 s-4528))
- e-4525)))
- (if (if (null? (car w-4527)) (null? (cdr w-4527)) #f)
- x-5388
- (if (if (vector? x-5388)
- (if (= (vector-length x-5388) 4)
- (eq? (vector-ref x-5388 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-5420 (vector-ref x-5388 1))
- (wrap-5421
- (let ((w2-5429 (vector-ref x-5388 2)))
- (let ((m1-5430 (car w-4527))
- (s1-5431 (cdr w-4527)))
- (if (null? m1-5430)
- (if (null? s1-5431)
- w2-5429
- (cons (car w2-5429)
- (let ((m2-5446 (cdr w2-5429)))
- (if (null? m2-5446)
- s1-5431
- (append s1-5431 m2-5446)))))
- (cons (let ((m2-5454 (car w2-5429)))
- (if (null? m2-5454)
- m1-5430
- (append m1-5430 m2-5454)))
- (let ((m2-5462 (cdr w2-5429)))
- (if (null? m2-5462)
- s1-5431
- (append s1-5431 m2-5462))))))))
- (module-5422 (vector-ref x-5388 3)))
- (vector
- 'syntax-object
- expression-5420
- wrap-5421
- module-5422))
- (if (null? x-5388)
- x-5388
- (vector 'syntax-object x-5388 w-4527 mod-4529))))))))))
- (module-define!
- (current-module)
- 'quote
- (make-syntax-transformer
- 'quote
- 'core
- (lambda (e-5490 r-5491 w-5492 s-5493 mod-5494)
- (let ((tmp-5496 ($sc-dispatch e-5490 '(_ any))))
- (if tmp-5496
- (@apply
- (lambda (e-5499)
- (let ((exp-5503 (strip-4396 e-5499 w-5492)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- s-5493
- exp-5503)))
- tmp-5496)
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key
+ '(define-form define-syntax-form define-syntax-parameter-form))
(syntax-violation
- 'quote
- "bad syntax"
- (let ((x-5517
- (begin
- (if (if s-5493
- (supports-source-properties? e-5490)
- #f)
- (set-source-properties! e-5490 s-5493))
- e-5490)))
- (if (if (null? (car w-5492)) (null? (cdr w-5492)) #f)
- x-5517
- (if (if (vector? x-5517)
- (if (= (vector-length x-5517) 4)
- (eq? (vector-ref x-5517 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-5549 (vector-ref x-5517 1))
- (wrap-5550
- (let ((w2-5558 (vector-ref x-5517 2)))
- (let ((m1-5559 (car w-5492))
- (s1-5560 (cdr w-5492)))
- (if (null? m1-5559)
- (if (null? s1-5560)
- w2-5558
- (cons (car w2-5558)
- (let ((m2-5575 (cdr w2-5558)))
- (if (null? m2-5575)
- s1-5560
- (append s1-5560 m2-5575)))))
- (cons (let ((m2-5583 (car w2-5558)))
- (if (null? m2-5583)
- m1-5559
- (append m1-5559 m2-5583)))
- (let ((m2-5591 (cdr w2-5558)))
- (if (null? m2-5591)
- s1-5560
- (append s1-5560 m2-5591))))))))
- (module-5551 (vector-ref x-5517 3)))
- (vector
- 'syntax-object
- expression-5549
- wrap-5550
- module-5551))
- (if (null? x-5517)
- x-5517
- (vector
- 'syntax-object
- x-5517
- w-5492
- mod-5494)))))))))))
- (global-extend-4345
- 'core
- 'syntax
- (letrec*
- ((gen-syntax-5810
- (lambda (src-6241
- e-6242
- r-6243
- maps-6244
- ellipsis?-6245
- mod-6246)
- (if (if (symbol? e-6242)
- #t
- (if (if (vector? e-6242)
- (if (= (vector-length e-6242) 4)
- (eq? (vector-ref e-6242 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref e-6242 1))
- #f))
- (call-with-values
- (lambda ()
- (resolve-identifier-4368
- e-6242
- '(())
- r-6243
- mod-6246
- #f))
- (lambda (type-6275 value-6276 mod-6277)
- (if (eqv? type-6275 'syntax)
- (call-with-values
- (lambda ()
- (gen-ref-5811
- src-6241
- (car value-6276)
- (cdr value-6276)
- maps-6244))
- (lambda (var-6285 maps-6286)
- (values (list 'ref var-6285) maps-6286)))
- (if (ellipsis?-6245 e-6242)
- (syntax-violation
- 'syntax
- "misplaced ellipsis"
- src-6241)
- (values (list 'quote e-6242) maps-6244)))))
- (let ((tmp-6288 ($sc-dispatch e-6242 '(any any))))
- (if (if tmp-6288
- (@apply
- (lambda (dots-6292 e-6293)
- (ellipsis?-6245 dots-6292))
- tmp-6288)
- #f)
- (@apply
- (lambda (dots-6294 e-6295)
- (gen-syntax-5810
- src-6241
- e-6295
- r-6243
- maps-6244
- (lambda (x-6296) #f)
- mod-6246))
- tmp-6288)
- (let ((tmp-6297 ($sc-dispatch e-6242 '(any any . any))))
- (if (if tmp-6297
- (@apply
- (lambda (x-6301 dots-6302 y-6303)
- (ellipsis?-6245 dots-6302))
- tmp-6297)
- #f)
- (@apply
- (lambda (x-6304 dots-6305 y-6306)
- (letrec*
- ((f-6307
- (lambda (y-6315 k-6316)
- (let ((tmp-6318
- ($sc-dispatch
- y-6315
- '(any . any))))
- (if (if tmp-6318
- (@apply
- (lambda (dots-6322 y-6323)
- (ellipsis?-6245 dots-6322))
- tmp-6318)
- #f)
- (@apply
- (lambda (dots-6324 y-6325)
- (f-6307
- y-6325
- (lambda (maps-6326)
- (call-with-values
- (lambda ()
- (k-6316
- (cons '() maps-6326)))
- (lambda (x-6327 maps-6328)
- (if (null? (car maps-6328))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- src-6241)
- (values
- (let ((map-env-6332
- (car maps-6328)))
- (list 'apply
- '(primitive
- append)
- (gen-map-5813
- x-6327
- map-env-6332)))
- (cdr maps-6328))))))))
- tmp-6318)
- (call-with-values
- (lambda ()
- (gen-syntax-5810
- src-6241
- y-6315
- r-6243
- maps-6244
- ellipsis?-6245
- mod-6246))
- (lambda (y-6335 maps-6336)
- (call-with-values
- (lambda () (k-6316 maps-6336))
- (lambda (x-6337 maps-6338)
- (values
- (if (equal? y-6335 ''())
- x-6337
- (list 'append
- x-6337
- y-6335))
- maps-6338))))))))))
- (f-6307
- y-6306
- (lambda (maps-6310)
- (call-with-values
- (lambda ()
- (gen-syntax-5810
- src-6241
- x-6304
- r-6243
- (cons '() maps-6310)
- ellipsis?-6245
- mod-6246))
- (lambda (x-6311 maps-6312)
- (if (null? (car maps-6312))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- src-6241)
- (values
- (gen-map-5813
- x-6311
- (car maps-6312))
- (cdr maps-6312)))))))))
- tmp-6297)
- (let ((tmp-6354 ($sc-dispatch e-6242 '(any . any))))
- (if tmp-6354
- (@apply
- (lambda (x-6358 y-6359)
- (call-with-values
- (lambda ()
- (gen-syntax-5810
- src-6241
- x-6358
- r-6243
- maps-6244
- ellipsis?-6245
- mod-6246))
- (lambda (x-6360 maps-6361)
- (call-with-values
- (lambda ()
- (gen-syntax-5810
- src-6241
- y-6359
- r-6243
- maps-6361
- ellipsis?-6245
- mod-6246))
- (lambda (y-6362 maps-6363)
- (values
- (let ((key-6368 (car y-6362)))
- (if (eqv? key-6368 'quote)
- (if (eq? (car x-6360) 'quote)
- (list 'quote
- (cons (car (cdr x-6360))
- (car (cdr y-6362))))
- (if (eq? (car (cdr y-6362))
- '())
- (list 'list x-6360)
- (list 'cons x-6360 y-6362)))
- (if (eqv? key-6368 'list)
- (cons 'list
- (cons x-6360
- (cdr y-6362)))
- (list 'cons x-6360 y-6362))))
- maps-6363))))))
- tmp-6354)
- (let ((tmp-6397
- ($sc-dispatch
- e-6242
- '#(vector (any . each-any)))))
- (if tmp-6397
- (@apply
- (lambda (e1-6401 e2-6402)
- (call-with-values
- (lambda ()
- (gen-syntax-5810
- src-6241
- (cons e1-6401 e2-6402)
- r-6243
- maps-6244
- ellipsis?-6245
- mod-6246))
- (lambda (e-6403 maps-6404)
- (values
- (if (eq? (car e-6403) 'list)
- (cons 'vector (cdr e-6403))
- (if (eq? (car e-6403) 'quote)
- (list 'quote
- (list->vector
- (car (cdr e-6403))))
- (list 'list->vector e-6403)))
- maps-6404))))
- tmp-6397)
- (values
- (list 'quote e-6242)
- maps-6244))))))))))))
- (gen-ref-5811
- (lambda (src-6431 var-6432 level-6433 maps-6434)
- (if (= level-6433 0)
- (values var-6432 maps-6434)
- (if (null? maps-6434)
- (syntax-violation
- 'syntax
- "missing ellipsis"
- src-6431)
- (call-with-values
- (lambda ()
- (gen-ref-5811
- src-6431
- var-6432
- (#{1-}# level-6433)
- (cdr maps-6434)))
- (lambda (outer-var-6435 outer-maps-6436)
- (let ((b-6437 (assq outer-var-6435 (car maps-6434))))
- (if b-6437
- (values (cdr b-6437) maps-6434)
- (let ((inner-var-6439
- (gensym
- (string-append
- (symbol->string 'tmp)
- "-"))))
- (values
- inner-var-6439
- (cons (cons (cons outer-var-6435 inner-var-6439)
- (car maps-6434))
- outer-maps-6436)))))))))))
- (gen-map-5813
- (lambda (e-6453 map-env-6454)
- (let ((formals-6455 (map cdr map-env-6454))
- (actuals-6456
- (map (lambda (x-6458) (list 'ref (car x-6458)))
- map-env-6454)))
- (if (eq? (car e-6453) 'ref)
- (car actuals-6456)
- (if (and-map
- (lambda (x-6459)
- (if (eq? (car x-6459) 'ref)
- (memq (car (cdr x-6459)) formals-6455)
- #f))
- (cdr e-6453))
- (cons 'map
- (cons (list 'primitive (car e-6453))
- (map (let ((r-6461
- (map cons
- formals-6455
- actuals-6456)))
- (lambda (x-6462)
- (cdr (assq (car (cdr x-6462))
- r-6461))))
- (cdr e-6453))))
- (cons 'map
- (cons (list 'lambda formals-6455 e-6453)
- actuals-6456)))))))
- (regen-5817
- (lambda (x-6464)
- (let ((key-6465 (car x-6464)))
- (if (eqv? key-6465 'ref)
- (let ((name-6475 (car (cdr x-6464)))
- (var-6476 (car (cdr x-6464))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
+ #f
+ "definition in expression context, where definitions are not allowed,"
+ (source-wrap form w s mod)))
+ ((memv key '(syntax))
+ (syntax-violation
+ #f
+ "reference to pattern variable outside syntax form"
+ (source-wrap e w s mod)))
+ ((memv key '(displaced-lexical))
+ (syntax-violation
+ #f
+ "reference to identifier outside its scope"
+ (source-wrap e w s mod)))
+ (else
+ (syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))))
+ (expand-call
+ (lambda (x e r w s mod)
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
+ (if tmp
+ (apply (lambda (e0 e1)
+ (build-call s x (map (lambda (e) (expand e r w mod)) e1)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ (expand-macro
+ (lambda (p e r w s rib mod)
+ (letrec*
+ ((rebuild-macro-output
+ (lambda (x m)
+ (cond ((pair? x)
+ (decorate-source
+ (cons (rebuild-macro-output (car x) m)
+ (rebuild-macro-output (cdr x) m))
+ s))
+ ((syntax-object? x)
+ (let ((w (syntax-object-wrap x)))
+ (let ((ms (car w)) (ss (cdr w)))
+ (if (and (pair? ms) (eq? (car ms) #f))
+ (make-syntax-object
+ (syntax-object-expression x)
+ (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
+ (syntax-object-module x))
+ (make-syntax-object
+ (decorate-source (syntax-object-expression x) s)
+ (cons (cons m ms)
+ (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
+ (syntax-object-module x))))))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
+ (let loop ((i 0))
+ (if (= i n)
+ (begin (if #f #f) v)
+ (begin
+ (vector-set! v i (rebuild-macro-output (vector-ref x i) m))
+ (loop (+ i 1)))))))
+ ((symbol? x)
+ (syntax-violation
#f
- name-6475
- var-6476))
- (if (eqv? key-6465 'primitive)
- (let ((name-6487 (car (cdr x-6464))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 2)
- #f
- name-6487))
- (if (eqv? key-6465 'quote)
- (let ((exp-6498 (car (cdr x-6464))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
+ "encountered raw symbol in macro output"
+ (source-wrap e w (cdr w) mod)
+ x))
+ (else (decorate-source x s))))))
+ (with-fluids
+ ((transformer-environment (lambda (k) (k e r w s rib mod))))
+ (rebuild-macro-output
+ (p (source-wrap e (anti-mark w) s mod))
+ (gensym (string-append "m-" (session-id) "-")))))))
+ (expand-body
+ (lambda (body outer-form r w mod)
+ (let* ((r (cons '("placeholder" placeholder) r))
+ (ribcage (make-ribcage '() '() '()))
+ (w (cons (car w) (cons ribcage (cdr w)))))
+ (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
+ (ids '())
+ (labels '())
+ (var-ids '())
+ (vars '())
+ (vals '())
+ (bindings '()))
+ (if (null? body)
+ (syntax-violation #f "no expressions in body" outer-form)
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda ()
+ (syntax-type e er '(()) (source-annotation er) ribcage mod #f))
+ (lambda (type value form e w s mod)
+ (let ((key type))
+ (cond ((memv key '(define-form))
+ (let ((id (wrap value w mod)) (label (gen-label)))
+ (let ((var (gen-var id)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids)
+ (cons label labels)
+ (cons id var-ids)
+ (cons var vars)
+ (cons (cons er (wrap e w mod)) vals)
+ (cons (cons 'lexical var) bindings)))))
+ ((memv key '(define-syntax-form define-syntax-parameter-form))
+ (let ((id (wrap value w mod)) (label (gen-label)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids)
+ (cons label labels)
+ var-ids
+ vars
+ vals
+ (cons (cons (if (eq? type 'define-syntax-parameter-form)
+ 'syntax-parameter
+ 'macro)
+ (cons er (wrap e w mod)))
+ bindings))))
+ ((memv key '(begin-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e1)
+ (parse (let f ((forms e1))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
+ ids
+ labels
+ var-ids
+ vars
+ vals
+ bindings))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax
+ value
+ e
+ er
+ w
+ s
+ mod
+ (lambda (forms er w s mod)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
+ ids
+ labels
+ var-ids
+ vars
+ vals
+ bindings))))
+ ((null? ids)
+ (build-sequence
+ #f
+ (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
+ (cons (cons er (source-wrap e w s mod)) (cdr body)))))
+ (else
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation
+ #f
+ "invalid or duplicate identifier in definition"
+ outer-form))
+ (let loop ((bs bindings) (er-cache #f) (r-cache #f))
+ (if (not (null? bs))
+ (let ((b (car bs)))
+ (if (memq (car b) '(macro syntax-parameter))
+ (let* ((er (cadr b))
+ (r-cache (if (eq? er er-cache) r-cache (macros-only-env er))))
+ (set-cdr!
+ b
+ (eval-local-transformer (expand (cddr b) r-cache '(()) mod) mod))
+ (if (eq? (car b) 'syntax-parameter) (set-cdr! b (list (cdr b))))
+ (loop (cdr bs) er r-cache))
+ (loop (cdr bs) er-cache r-cache)))))
+ (set-cdr! r (extend-env labels bindings (cdr r)))
+ (build-letrec
+ #f
+ #t
+ (reverse (map syntax->datum var-ids))
+ (reverse vars)
+ (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals))
+ (build-sequence
+ #f
+ (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
+ (cons (cons er (source-wrap e w s mod)) (cdr body))))))))))))))))
+ (expand-local-syntax
+ (lambda (rec? e r w s mod k)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if tmp
+ (apply (lambda (id val e1 e2)
+ (let ((ids id))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation #f "duplicate bound keyword" e)
+ (let* ((labels (gen-labels ids)) (new-w (make-binding-wrap ids labels w)))
+ (k (cons e1 e2)
+ (extend-env
+ labels
+ (let ((w (if rec? new-w w)) (trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
+ val))
+ r)
+ new-w
+ s
+ mod)))))
+ tmp)
+ (syntax-violation
+ #f
+ "bad local syntax definition"
+ (source-wrap e w s mod))))))
+ (eval-local-transformer
+ (lambda (expanded mod)
+ (let ((p (local-eval-hook expanded mod)))
+ (if (procedure? p)
+ p
+ (syntax-violation #f "nonprocedure transformer" p)))))
+ (expand-void (lambda () (build-void #f)))
+ (ellipsis?
+ (lambda (x)
+ (and (nonsymbol-id? x)
+ (free-id=? x '#(syntax-object ... ((top)) (hygiene guile))))))
+ (lambda-formals
+ (lambda (orig-args)
+ (letrec*
+ ((req (lambda (args rreq)
+ (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (check (reverse rreq) #f)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+ (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+ (apply (lambda (r) (check (reverse rreq) r)) tmp-1)
+ (let ((else tmp))
+ (syntax-violation 'lambda "invalid argument list" orig-args args))))))))))
+ (check (lambda (req rest)
+ (if (distinct-bound-ids? (if rest (cons rest req) req))
+ (values req #f rest #f)
+ (syntax-violation
+ 'lambda
+ "duplicate identifier in argument list"
+ orig-args)))))
+ (req orig-args '()))))
+ (expand-simple-lambda
+ (lambda (e r w s mod req rest meta body)
+ (let* ((ids (if rest (append req (list rest)) req))
+ (vars (map gen-var ids))
+ (labels (gen-labels ids)))
+ (build-simple-lambda
+ s
+ (map syntax->datum req)
+ (and rest (syntax->datum rest))
+ vars
+ meta
+ (expand-body
+ body
+ (source-wrap e w s mod)
+ (extend-var-env labels vars r)
+ (make-binding-wrap ids labels w)
+ mod)))))
+ (lambda*-formals
+ (lambda (orig-args)
+ (letrec*
+ ((req (lambda (args rreq)
+ (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+ (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1))
+ (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
+ (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
+ (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+ (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1)
+ (let ((else tmp))
+ (syntax-violation
+ 'lambda*
+ "invalid argument list"
+ orig-args
+ args))))))))))))))))
+ (opt (lambda (args req ropt)
+ (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (check req (reverse ropt) #f '())) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+ (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
+ (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
+ (apply (lambda (a init b) (opt b req (cons (list a init) ropt)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
+ (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
+ (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+ (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1)
+ (let ((else tmp))
+ (syntax-violation
+ 'lambda*
+ "invalid optional argument list"
+ orig-args
+ args))))))))))))))))
+ (key (lambda (args req opt rkey)
+ (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+ (apply (lambda (a b)
+ (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
+ (key b req opt (cons (cons k (cons a '(#f))) rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
+ (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
+ (apply (lambda (a init b)
+ (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
+ (key b req opt (cons (list k a init) rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any))))
+ (if (and tmp-1
+ (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k))))
+ tmp-1))
+ (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any))))
+ (if (and tmp-1
+ (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys))
+ tmp-1))
+ (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any any))))
+ (if (and tmp-1
+ (apply (lambda (aok a b)
+ (and (eq? (syntax->datum aok) #:allow-other-keys)
+ (eq? (syntax->datum a) #:rest)))
+ tmp-1))
+ (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1
+ (apply (lambda (aok r)
+ (and (eq? (syntax->datum aok) #:allow-other-keys) (id? r)))
+ tmp-1))
+ (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
+ (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey))))
+ tmp-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+ (apply (lambda (r) (rest r req opt (cons #f (reverse rkey))))
+ tmp-1)
+ (let ((else tmp))
+ (syntax-violation
+ 'lambda*
+ "invalid keyword argument list"
+ orig-args
+ args))))))))))))))))))))))
+ (rest (lambda (args req opt kw)
+ (let* ((tmp-1 args) (tmp (list tmp-1)))
+ (if (and tmp (apply (lambda (r) (id? r)) tmp))
+ (apply (lambda (r) (check req opt r kw)) tmp)
+ (let ((else tmp-1))
+ (syntax-violation 'lambda* "invalid rest argument" orig-args args))))))
+ (check (lambda (req opt rest kw)
+ (if (distinct-bound-ids?
+ (append
+ req
+ (map car opt)
+ (if rest (list rest) '())
+ (if (pair? kw) (map cadr (cdr kw)) '())))
+ (values req opt rest kw)
+ (syntax-violation
+ 'lambda*
+ "duplicate identifier in argument list"
+ orig-args)))))
+ (req orig-args '()))))
+ (expand-lambda-case
+ (lambda (e r w s mod get-formals clauses)
+ (letrec*
+ ((parse-req
+ (lambda (req opt rest kw body)
+ (let ((vars (map gen-var req)) (labels (gen-labels req)))
+ (let ((r* (extend-var-env labels vars r))
+ (w* (make-binding-wrap req labels w)))
+ (parse-opt
+ (map syntax->datum req)
+ opt
+ rest
+ kw
+ body
+ (reverse vars)
+ r*
+ w*
+ '()
+ '())))))
+ (parse-opt
+ (lambda (req opt rest kw body vars r* w* out inits)
+ (cond ((pair? opt)
+ (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (id i)
+ (let* ((v (gen-var id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list id) l w*)))
+ (parse-opt
+ req
+ (cdr opt)
+ rest
+ kw
+ body
+ (cons v vars)
+ r**
+ w**
+ (cons (syntax->datum id) out)
+ (cons (expand i r* w* mod) inits))))
+ tmp)
+ (syntax-violation
#f
- exp-6498))
- (if (eqv? key-6465 'lambda)
- (if (list? (car (cdr x-6464)))
- (let ((req-6509 (car (cdr x-6464)))
- (vars-6511 (car (cdr x-6464)))
- (exp-6513
- (regen-5817 (car (cdr (cdr x-6464))))))
- (let ((body-6518
- (make-struct/no-tail
- (vector-ref %expanded-vtables 15)
- #f
- req-6509
- #f
- #f
- #f
- '()
- vars-6511
- exp-6513
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- '()
- body-6518)))
- (error "how did we get here" x-6464))
- (let ((name-6534 (car x-6464))
- (args-6535 (map regen-5817 (cdr x-6464))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- #f
- name-6534
- args-6535))))))))))
- (lambda (e-5818 r-5819 w-5820 s-5821 mod-5822)
- (let ((e-5823
- (let ((x-6152
- (begin
- (if (if s-5821
- (supports-source-properties? e-5818)
- #f)
- (set-source-properties! e-5818 s-5821))
- e-5818)))
- (if (if (null? (car w-5820)) (null? (cdr w-5820)) #f)
- x-6152
- (if (if (vector? x-6152)
- (if (= (vector-length x-6152) 4)
- (eq? (vector-ref x-6152 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-6184 (vector-ref x-6152 1))
- (wrap-6185
- (let ((w2-6193 (vector-ref x-6152 2)))
- (let ((m1-6194 (car w-5820))
- (s1-6195 (cdr w-5820)))
- (if (null? m1-6194)
- (if (null? s1-6195)
- w2-6193
- (cons (car w2-6193)
- (let ((m2-6210 (cdr w2-6193)))
- (if (null? m2-6210)
- s1-6195
- (append
- s1-6195
- m2-6210)))))
- (cons (let ((m2-6218 (car w2-6193)))
- (if (null? m2-6218)
- m1-6194
- (append m1-6194 m2-6218)))
- (let ((m2-6226 (cdr w2-6193)))
- (if (null? m2-6226)
- s1-6195
- (append
- s1-6195
- m2-6226))))))))
- (module-6186 (vector-ref x-6152 3)))
- (vector
- 'syntax-object
- expression-6184
- wrap-6185
- module-6186))
- (if (null? x-6152)
- x-6152
- (vector
- 'syntax-object
- x-6152
- w-5820
- mod-5822)))))))
- (let ((tmp-5824 e-5823))
- (let ((tmp-5825 ($sc-dispatch tmp-5824 '(_ any))))
- (if tmp-5825
- (@apply
- (lambda (x-5873)
- (call-with-values
- (lambda ()
- (gen-syntax-5810
- e-5823
- x-5873
- r-5819
- '()
- ellipsis?-4391
- mod-5822))
- (lambda (e-5950 maps-5951) (regen-5817 e-5950))))
- tmp-5825)
+ "source expression failed to match any pattern"
+ tmp-1))))
+ (rest
+ (let* ((v (gen-var rest))
+ (l (gen-labels (list v)))
+ (r* (extend-var-env l (list v) r*))
+ (w* (make-binding-wrap (list rest) l w*)))
+ (parse-kw
+ req
+ (and (pair? out) (reverse out))
+ (syntax->datum rest)
+ (if (pair? kw) (cdr kw) kw)
+ body
+ (cons v vars)
+ r*
+ w*
+ (and (pair? kw) (car kw))
+ '()
+ inits)))
+ (else
+ (parse-kw
+ req
+ (and (pair? out) (reverse out))
+ #f
+ (if (pair? kw) (cdr kw) kw)
+ body
+ vars
+ r*
+ w*
+ (and (pair? kw) (car kw))
+ '()
+ inits)))))
+ (parse-kw
+ (lambda (req opt rest kw body vars r* w* aok out inits)
+ (if (pair? kw)
+ (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any))))
+ (if tmp
+ (apply (lambda (k id i)
+ (let* ((v (gen-var id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list id) l w*)))
+ (parse-kw
+ req
+ opt
+ rest
+ (cdr kw)
+ body
+ (cons v vars)
+ r**
+ w**
+ aok
+ (cons (list (syntax->datum k) (syntax->datum id) v) out)
+ (cons (expand i r* w* mod) inits))))
+ tmp)
(syntax-violation
- 'syntax
- "bad `syntax' form"
- e-5823))))))))
- (global-extend-4345
- 'core
- 'lambda
- (lambda (e-6763 r-6764 w-6765 s-6766 mod-6767)
- (let ((tmp-6769
- ($sc-dispatch e-6763 '(_ any any . each-any))))
- (if tmp-6769
- (@apply
- (lambda (args-6773 e1-6774 e2-6775)
- (call-with-values
- (lambda () (lambda-formals-4392 args-6773))
- (lambda (req-6778 opt-6779 rest-6780 kw-6781)
- (letrec*
- ((lp-6782
- (lambda (body-6785 meta-6786)
- (let ((tmp-6788
- ($sc-dispatch
- body-6785
- '(any any . each-any))))
- (if (if tmp-6788
- (@apply
- (lambda (docstring-6792 e1-6793 e2-6794)
- (string?
- (syntax->datum docstring-6792)))
- tmp-6788)
- #f)
- (@apply
- (lambda (docstring-6795 e1-6796 e2-6797)
- (lp-6782
- (cons e1-6796 e2-6797)
- (append
- meta-6786
- (list (cons 'documentation
- (syntax->datum
- docstring-6795))))))
- tmp-6788)
- (let ((tmp-6798
- ($sc-dispatch
- body-6785
- '(#(vector #(each (any . any)))
- any
- .
- each-any))))
- (if tmp-6798
- (@apply
- (lambda (k-6802 v-6803 e1-6804 e2-6805)
- (lp-6782
- (cons e1-6804 e2-6805)
- (append
- meta-6786
- (syntax->datum
- (map cons k-6802 v-6803)))))
- tmp-6798)
- (expand-simple-lambda-4393
- e-6763
- r-6764
- w-6765
- s-6766
- mod-6767
- req-6778
- rest-6780
- meta-6786
- body-6785))))))))
- (lp-6782 (cons e1-6774 e2-6775) '())))))
- tmp-6769)
- (syntax-violation 'lambda "bad lambda" e-6763)))))
- (global-extend-4345
- 'core
- 'lambda*
- (lambda (e-7177 r-7178 w-7179 s-7180 mod-7181)
- (let ((tmp-7183
- ($sc-dispatch e-7177 '(_ any any . each-any))))
- (if tmp-7183
- (@apply
- (lambda (args-7187 e1-7188 e2-7189)
- (call-with-values
- (lambda ()
- (expand-lambda-case-4395
- e-7177
- r-7178
- w-7179
- s-7180
- mod-7181
- lambda*-formals-4394
- (list (cons args-7187 (cons e1-7188 e2-7189)))))
- (lambda (meta-7192 lcase-7193)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- s-7180
- meta-7192
- lcase-7193))))
- tmp-7183)
- (syntax-violation 'lambda "bad lambda*" e-7177)))))
- (global-extend-4345
- 'core
- 'case-lambda
- (lambda (e-7356 r-7357 w-7358 s-7359 mod-7360)
- (let ((tmp-7362
- ($sc-dispatch
- e-7356
- '(_ (any any . each-any)
- .
- #(each (any any . each-any))))))
- (if tmp-7362
- (@apply
- (lambda (args-7366
- e1-7367
- e2-7368
- args*-7369
- e1*-7370
- e2*-7371)
- (call-with-values
- (lambda ()
- (expand-lambda-case-4395
- e-7356
- r-7357
- w-7358
- s-7359
- mod-7360
- lambda-formals-4392
- (cons (cons args-7366 (cons e1-7367 e2-7368))
- (map (lambda (tmp-3330-7374
- tmp-3329-7375
- tmp-3328-7376)
- (cons tmp-3328-7376
- (cons tmp-3329-7375 tmp-3330-7374)))
- e2*-7371
- e1*-7370
- args*-7369))))
- (lambda (meta-7377 lcase-7378)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- s-7359
- meta-7377
- lcase-7378))))
- tmp-7362)
- (syntax-violation
- 'case-lambda
- "bad case-lambda"
- e-7356)))))
- (global-extend-4345
- 'core
- 'case-lambda*
- (lambda (e-7547 r-7548 w-7549 s-7550 mod-7551)
- (let ((tmp-7553
- ($sc-dispatch
- e-7547
- '(_ (any any . each-any)
- .
- #(each (any any . each-any))))))
- (if tmp-7553
- (@apply
- (lambda (args-7557
- e1-7558
- e2-7559
- args*-7560
- e1*-7561
- e2*-7562)
- (call-with-values
- (lambda ()
- (expand-lambda-case-4395
- e-7547
- r-7548
- w-7549
- s-7550
- mod-7551
- lambda*-formals-4394
- (cons (cons args-7557 (cons e1-7558 e2-7559))
- (map (lambda (tmp-3365-7565
- tmp-3364-7566
- tmp-3363-7567)
- (cons tmp-3363-7567
- (cons tmp-3364-7566 tmp-3365-7565)))
- e2*-7562
- e1*-7561
- args*-7560))))
- (lambda (meta-7568 lcase-7569)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- s-7550
- meta-7568
- lcase-7569))))
- tmp-7553)
- (syntax-violation
- 'case-lambda
- "bad case-lambda*"
- e-7547)))))
- (global-extend-4345
- 'core
- 'let
- (letrec*
- ((expand-let-7777
- (lambda (e-7987
- r-7988
- w-7989
- s-7990
- mod-7991
- constructor-7992
- ids-7993
- vals-7994
- exps-7995)
- (if (not (valid-bound-ids?-4373 ids-7993))
- (syntax-violation
- 'let
- "duplicate bound variable"
- e-7987)
- (let ((labels-8080 (gen-labels-4350 ids-7993))
- (new-vars-8081 (map gen-var-4397 ids-7993)))
- (let ((nw-8082
- (make-binding-wrap-4361
- ids-7993
- labels-8080
- w-7989))
- (nr-8083
- (extend-var-env-4343
- labels-8080
- new-vars-8081
- r-7988)))
- (constructor-7992
- s-7990
- (map syntax->datum ids-7993)
- new-vars-8081
- (map (lambda (x-8100)
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))
+ (parse-body
+ req
+ opt
+ rest
+ (and (or aok (pair? out)) (cons aok (reverse out)))
+ body
+ (reverse vars)
+ r*
+ w*
+ (reverse inits)
+ '()))))
+ (parse-body
+ (lambda (req opt rest kw body vars r* w* inits meta)
+ (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any))))
+ (if (and tmp-1
+ (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
+ tmp-1))
+ (apply (lambda (docstring e1 e2)
+ (parse-body
+ req
+ opt
+ rest
+ kw
+ (cons e1 e2)
+ vars
+ r*
+ w*
+ inits
+ (append meta (list (cons 'documentation (syntax->datum docstring))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any))))
+ (if tmp-1
+ (apply (lambda (k v e1 e2)
+ (parse-body
+ req
+ opt
+ rest
+ kw
+ (cons e1 e2)
+ vars
+ r*
+ w*
+ inits
+ (append meta (syntax->datum (map cons k v)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2)
+ (values
+ meta
+ req
+ opt
+ rest
+ kw
+ inits
+ vars
+ (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod)))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))))
+ (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (values '() #f)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ '((any any . each-any) . #(each (any any . each-any))))))
+ (if tmp-1
+ (apply (lambda (args e1 e2 args* e1* e2*)
+ (call-with-values
+ (lambda () (get-formals args))
+ (lambda (req opt rest kw)
(call-with-values
- (lambda ()
- (syntax-type-4382
- x-8100
- r-7988
- w-7989
- (let ((props-8116
- (source-properties
- (if (if (vector? x-8100)
- (if (= (vector-length
- x-8100)
- 4)
- (eq? (vector-ref
- x-8100
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-8100 1)
- x-8100))))
- (if (pair? props-8116) props-8116 #f))
- #f
- mod-7991
- #f))
- (lambda (type-8149
- value-8150
- form-8151
- e-8152
- w-8153
- s-8154
- mod-8155)
- (expand-expr-4384
- type-8149
- value-8150
- form-8151
- e-8152
- r-7988
- w-8153
- s-8154
- mod-8155))))
- vals-7994)
- (expand-body-4387
- exps-7995
- (source-wrap-4377 e-7987 nw-8082 s-7990 mod-7991)
- nr-8083
- nw-8082
- mod-7991))))))))
- (lambda (e-7778 r-7779 w-7780 s-7781 mod-7782)
- (let ((tmp-7784
- ($sc-dispatch
- e-7778
- '(_ #(each (any any)) any . each-any))))
- (if (if tmp-7784
- (@apply
- (lambda (id-7788 val-7789 e1-7790 e2-7791)
- (and-map id?-4347 id-7788))
- tmp-7784)
- #f)
- (@apply
- (lambda (id-7807 val-7808 e1-7809 e2-7810)
- (expand-let-7777
- e-7778
- r-7779
- w-7780
- s-7781
- mod-7782
- (lambda (src-7814
- ids-7815
- vars-7816
- val-exps-7817
- body-exp-7818)
- (begin
- (for-each
- maybe-name-value!-4312
- ids-7815
- val-exps-7817)
- (if (null? vars-7816)
- body-exp-7818
- (make-struct/no-tail
- (vector-ref %expanded-vtables 16)
- src-7814
- ids-7815
- vars-7816
- val-exps-7817
- body-exp-7818))))
- id-7807
- val-7808
- (cons e1-7809 e2-7810)))
- tmp-7784)
- (let ((tmp-7825
- ($sc-dispatch
- e-7778
- '(_ any #(each (any any)) any . each-any))))
- (if (if tmp-7825
- (@apply
- (lambda (f-7829 id-7830 val-7831 e1-7832 e2-7833)
- (if (if (symbol? f-7829)
- #t
- (if (if (vector? f-7829)
- (if (= (vector-length f-7829) 4)
- (eq? (vector-ref f-7829 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref f-7829 1))
- #f))
- (and-map id?-4347 id-7830)
- #f))
- tmp-7825)
- #f)
- (@apply
- (lambda (f-7875 id-7876 val-7877 e1-7878 e2-7879)
- (expand-let-7777
- e-7778
- r-7779
- w-7780
- s-7781
- mod-7782
- build-named-let-4331
- (cons f-7875 id-7876)
- val-7877
- (cons e1-7878 e2-7879)))
- tmp-7825)
- (syntax-violation
- 'let
- "bad let"
- (let ((x-7892
- (begin
- (if (if s-7781
- (supports-source-properties? e-7778)
- #f)
- (set-source-properties! e-7778 s-7781))
- e-7778)))
- (if (if (null? (car w-7780)) (null? (cdr w-7780)) #f)
- x-7892
- (if (if (vector? x-7892)
- (if (= (vector-length x-7892) 4)
- (eq? (vector-ref x-7892 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-7924 (vector-ref x-7892 1))
- (wrap-7925
- (let ((w2-7933 (vector-ref x-7892 2)))
- (let ((m1-7934 (car w-7780))
- (s1-7935 (cdr w-7780)))
- (if (null? m1-7934)
- (if (null? s1-7935)
- w2-7933
- (cons (car w2-7933)
- (let ((m2-7950
- (cdr w2-7933)))
- (if (null? m2-7950)
- s1-7935
- (append
- s1-7935
- m2-7950)))))
- (cons (let ((m2-7958 (car w2-7933)))
- (if (null? m2-7958)
- m1-7934
- (append m1-7934 m2-7958)))
- (let ((m2-7966 (cdr w2-7933)))
- (if (null? m2-7966)
- s1-7935
- (append
- s1-7935
- m2-7966))))))))
- (module-7926 (vector-ref x-7892 3)))
- (vector
- 'syntax-object
- expression-7924
- wrap-7925
- module-7926))
- (if (null? x-7892)
- x-7892
- (vector
- 'syntax-object
- x-7892
- w-7780
- mod-7782)))))))))))))
- (global-extend-4345
- 'core
- 'letrec
- (lambda (e-8511 r-8512 w-8513 s-8514 mod-8515)
- (let ((tmp-8517
- ($sc-dispatch
- e-8511
- '(_ #(each (any any)) any . each-any))))
- (if (if tmp-8517
- (@apply
- (lambda (id-8521 val-8522 e1-8523 e2-8524)
- (and-map id?-4347 id-8521))
- tmp-8517)
- #f)
- (@apply
- (lambda (id-8540 val-8541 e1-8542 e2-8543)
- (if (not (valid-bound-ids?-4373 id-8540))
- (syntax-violation
- 'letrec
- "duplicate bound variable"
- e-8511)
- (let ((labels-8640 (gen-labels-4350 id-8540))
- (new-vars-8641 (map gen-var-4397 id-8540)))
- (let ((w-8642
- (make-binding-wrap-4361
- id-8540
- labels-8640
- w-8513))
- (r-8643
- (extend-var-env-4343
- labels-8640
- new-vars-8641
- r-8512)))
- (build-letrec-4332
- s-8514
- #f
- (map syntax->datum id-8540)
- new-vars-8641
- (map (lambda (x-8720)
- (expand-4383 x-8720 r-8643 w-8642 mod-8515))
- val-8541)
- (expand-body-4387
- (cons e1-8542 e2-8543)
- (let ((x-8782
- (begin
- (if (if s-8514
- (supports-source-properties?
- e-8511)
- #f)
- (set-source-properties! e-8511 s-8514))
- e-8511)))
- (if (if (null? (car w-8642))
- (null? (cdr w-8642))
- #f)
- x-8782
- (if (if (vector? x-8782)
- (if (= (vector-length x-8782) 4)
- (eq? (vector-ref x-8782 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-8814 (vector-ref x-8782 1))
- (wrap-8815
- (let ((w2-8823
- (vector-ref x-8782 2)))
- (let ((m1-8824 (car w-8642))
- (s1-8825 (cdr w-8642)))
- (if (null? m1-8824)
- (if (null? s1-8825)
- w2-8823
- (cons (car w2-8823)
- (let ((m2-8840
- (cdr w2-8823)))
- (if (null? m2-8840)
- s1-8825
- (append
- s1-8825
- m2-8840)))))
- (cons (let ((m2-8848
- (car w2-8823)))
- (if (null? m2-8848)
- m1-8824
- (append
- m1-8824
- m2-8848)))
- (let ((m2-8856
- (cdr w2-8823)))
- (if (null? m2-8856)
- s1-8825
- (append
- s1-8825
- m2-8856))))))))
- (module-8816 (vector-ref x-8782 3)))
- (vector
- 'syntax-object
- expression-8814
- wrap-8815
- module-8816))
- (if (null? x-8782)
- x-8782
- (vector
- 'syntax-object
- x-8782
- w-8642
- mod-8515)))))
- r-8643
- w-8642
- mod-8515))))))
- tmp-8517)
- (syntax-violation
- 'letrec
- "bad letrec"
- (let ((x-9067
- (begin
- (if (if s-8514
- (supports-source-properties? e-8511)
- #f)
- (set-source-properties! e-8511 s-8514))
- e-8511)))
- (if (if (null? (car w-8513)) (null? (cdr w-8513)) #f)
- x-9067
- (if (if (vector? x-9067)
- (if (= (vector-length x-9067) 4)
- (eq? (vector-ref x-9067 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-9099 (vector-ref x-9067 1))
- (wrap-9100
- (let ((w2-9108 (vector-ref x-9067 2)))
- (let ((m1-9109 (car w-8513))
- (s1-9110 (cdr w-8513)))
- (if (null? m1-9109)
- (if (null? s1-9110)
- w2-9108
- (cons (car w2-9108)
- (let ((m2-9125 (cdr w2-9108)))
- (if (null? m2-9125)
- s1-9110
- (append s1-9110 m2-9125)))))
- (cons (let ((m2-9133 (car w2-9108)))
- (if (null? m2-9133)
- m1-9109
- (append m1-9109 m2-9133)))
- (let ((m2-9141 (cdr w2-9108)))
- (if (null? m2-9141)
- s1-9110
- (append s1-9110 m2-9141))))))))
- (module-9101 (vector-ref x-9067 3)))
- (vector
- 'syntax-object
- expression-9099
- wrap-9100
- module-9101))
- (if (null? x-9067)
- x-9067
- (vector 'syntax-object x-9067 w-8513 mod-8515))))))))))
- (global-extend-4345
- 'core
- 'letrec*
- (lambda (e-9292 r-9293 w-9294 s-9295 mod-9296)
- (let ((tmp-9298
- ($sc-dispatch
- e-9292
- '(_ #(each (any any)) any . each-any))))
- (if (if tmp-9298
- (@apply
- (lambda (id-9302 val-9303 e1-9304 e2-9305)
- (and-map id?-4347 id-9302))
- tmp-9298)
- #f)
- (@apply
- (lambda (id-9321 val-9322 e1-9323 e2-9324)
- (if (not (valid-bound-ids?-4373 id-9321))
- (syntax-violation
- 'letrec*
- "duplicate bound variable"
- e-9292)
- (let ((labels-9421 (gen-labels-4350 id-9321))
- (new-vars-9422 (map gen-var-4397 id-9321)))
- (let ((w-9423
- (make-binding-wrap-4361
- id-9321
- labels-9421
- w-9294))
- (r-9424
- (extend-var-env-4343
- labels-9421
- new-vars-9422
- r-9293)))
- (build-letrec-4332
- s-9295
- #t
- (map syntax->datum id-9321)
- new-vars-9422
- (map (lambda (x-9501)
- (expand-4383 x-9501 r-9424 w-9423 mod-9296))
- val-9322)
- (expand-body-4387
- (cons e1-9323 e2-9324)
- (let ((x-9563
- (begin
- (if (if s-9295
- (supports-source-properties?
- e-9292)
- #f)
- (set-source-properties! e-9292 s-9295))
- e-9292)))
- (if (if (null? (car w-9423))
- (null? (cdr w-9423))
- #f)
- x-9563
- (if (if (vector? x-9563)
- (if (= (vector-length x-9563) 4)
- (eq? (vector-ref x-9563 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-9595 (vector-ref x-9563 1))
- (wrap-9596
- (let ((w2-9604
- (vector-ref x-9563 2)))
- (let ((m1-9605 (car w-9423))
- (s1-9606 (cdr w-9423)))
- (if (null? m1-9605)
- (if (null? s1-9606)
- w2-9604
- (cons (car w2-9604)
- (let ((m2-9621
- (cdr w2-9604)))
- (if (null? m2-9621)
- s1-9606
- (append
- s1-9606
- m2-9621)))))
- (cons (let ((m2-9629
- (car w2-9604)))
- (if (null? m2-9629)
- m1-9605
- (append
- m1-9605
- m2-9629)))
- (let ((m2-9637
- (cdr w2-9604)))
- (if (null? m2-9637)
- s1-9606
- (append
- s1-9606
- m2-9637))))))))
- (module-9597 (vector-ref x-9563 3)))
- (vector
- 'syntax-object
- expression-9595
- wrap-9596
- module-9597))
- (if (null? x-9563)
- x-9563
- (vector
- 'syntax-object
- x-9563
- w-9423
- mod-9296)))))
- r-9424
- w-9423
- mod-9296))))))
- tmp-9298)
- (syntax-violation
- 'letrec*
- "bad letrec*"
- (let ((x-9848
- (begin
- (if (if s-9295
- (supports-source-properties? e-9292)
- #f)
- (set-source-properties! e-9292 s-9295))
- e-9292)))
- (if (if (null? (car w-9294)) (null? (cdr w-9294)) #f)
- x-9848
- (if (if (vector? x-9848)
- (if (= (vector-length x-9848) 4)
- (eq? (vector-ref x-9848 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-9880 (vector-ref x-9848 1))
- (wrap-9881
- (let ((w2-9889 (vector-ref x-9848 2)))
- (let ((m1-9890 (car w-9294))
- (s1-9891 (cdr w-9294)))
- (if (null? m1-9890)
- (if (null? s1-9891)
- w2-9889
- (cons (car w2-9889)
- (let ((m2-9906 (cdr w2-9889)))
- (if (null? m2-9906)
- s1-9891
- (append s1-9891 m2-9906)))))
- (cons (let ((m2-9914 (car w2-9889)))
- (if (null? m2-9914)
- m1-9890
- (append m1-9890 m2-9914)))
- (let ((m2-9922 (cdr w2-9889)))
- (if (null? m2-9922)
- s1-9891
- (append s1-9891 m2-9922))))))))
- (module-9882 (vector-ref x-9848 3)))
- (vector
- 'syntax-object
- expression-9880
- wrap-9881
- module-9882))
- (if (null? x-9848)
- x-9848
- (vector 'syntax-object x-9848 w-9294 mod-9296))))))))))
- (global-extend-4345
- 'core
- 'set!
- (lambda (e-10179 r-10180 w-10181 s-10182 mod-10183)
- (let ((tmp-10185 ($sc-dispatch e-10179 '(_ any any))))
- (if (if tmp-10185
- (@apply
- (lambda (id-10189 val-10190)
- (if (symbol? id-10189)
- #t
- (if (if (vector? id-10189)
- (if (= (vector-length id-10189) 4)
- (eq? (vector-ref id-10189 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-10189 1))
- #f)))
- tmp-10185)
- #f)
- (@apply
- (lambda (id-10217 val-10218)
- (call-with-values
- (lambda ()
- (resolve-identifier-4368
- id-10217
- w-10181
- r-10180
- mod-10183
- #t))
- (lambda (type-10221 value-10222 id-mod-10223)
- (if (eqv? type-10221 'lexical)
- (let ((name-10234 (syntax->datum id-10217))
- (exp-10236
- (call-with-values
- (lambda ()
- (syntax-type-4382
- val-10218
- r-10180
- w-10181
- (let ((props-10257
- (source-properties
- (if (if (vector? val-10218)
- (if (= (vector-length
- val-10218)
- 4)
- (eq? (vector-ref
- val-10218
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref val-10218 1)
- val-10218))))
- (if (pair? props-10257)
- props-10257
- #f))
- #f
- mod-10183
- #f))
- (lambda (type-10290
- value-10291
- form-10292
- e-10293
- w-10294
- s-10295
- mod-10296)
- (expand-expr-4384
- type-10290
- value-10291
- form-10292
- e-10293
- r-10180
- w-10294
- s-10295
- mod-10296)))))
- (begin
- (if (if (struct? exp-10236)
- (eq? (struct-vtable exp-10236)
- (vector-ref %expanded-vtables 14))
- #f)
- (let ((meta-10308 (struct-ref exp-10236 1)))
- (if (not (assq 'name meta-10308))
- (let ((v-10315
- (cons (cons 'name name-10234)
- meta-10308)))
- (struct-set! exp-10236 1 v-10315)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 4)
- s-10182
- name-10234
- value-10222
- exp-10236)))
- (if (eqv? type-10221 'global)
- (let ((exp-10334
+ (lambda () (parse-req req opt rest kw (cons e1 e2)))
+ (lambda (meta req opt rest kw inits vars body)
(call-with-values
(lambda ()
- (syntax-type-4382
- val-10218
- r-10180
- w-10181
- (let ((props-10356
- (source-properties
- (if (if (vector? val-10218)
- (if (= (vector-length
- val-10218)
- 4)
- (eq? (vector-ref
- val-10218
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref val-10218 1)
- val-10218))))
- (if (pair? props-10356)
- props-10356
- #f))
- #f
- mod-10183
- #f))
- (lambda (type-10389
- value-10390
- form-10391
- e-10392
- w-10393
- s-10394
- mod-10395)
- (expand-expr-4384
- type-10389
- value-10390
- form-10391
- e-10392
- r-10180
- w-10393
- s-10394
- mod-10395)))))
- (begin
- (if (if (struct? exp-10334)
- (eq? (struct-vtable exp-10334)
- (vector-ref %expanded-vtables 14))
- #f)
- (let ((meta-10407 (struct-ref exp-10334 1)))
- (if (not (assq 'name meta-10407))
- (let ((v-10414
- (cons (cons 'name value-10222)
- meta-10407)))
- (struct-set! exp-10334 1 v-10414)))))
- (analyze-variable-4319
- id-mod-10223
- value-10222
- (lambda (mod-10422 var-10423 public?-10424)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 6)
- s-10182
- mod-10422
- var-10423
- public?-10424
- exp-10334))
- (lambda (var-10433)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 8)
- s-10182
- var-10433
- exp-10334)))))
- (if (eqv? type-10221 'macro)
- (if (procedure-property
- value-10222
- 'variable-transformer)
- (let ((e-10449
- (expand-macro-4386
- value-10222
- e-10179
- r-10180
- w-10181
- s-10182
- #f
- mod-10183)))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-10449
- r-10180
- '(())
- (let ((props-10460
- (source-properties
- (if (if (vector? e-10449)
- (if (= (vector-length
- e-10449)
- 4)
- (eq? (vector-ref
- e-10449
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref e-10449 1)
- e-10449))))
- (if (pair? props-10460)
- props-10460
- #f))
- #f
- mod-10183
- #f))
- (lambda (type-10483
- value-10484
- form-10485
- e-10486
- w-10487
- s-10488
- mod-10489)
- (expand-expr-4384
- type-10483
- value-10484
- form-10485
- e-10486
- r-10180
- w-10487
- s-10488
- mod-10489))))
- (syntax-violation
- 'set!
- "not a variable transformer"
- (if (if (null? (car w-10181))
- (null? (cdr w-10181))
- #f)
- e-10179
- (if (if (vector? e-10179)
- (if (= (vector-length e-10179) 4)
- (eq? (vector-ref e-10179 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-10522
- (vector-ref e-10179 1))
- (wrap-10523
- (let ((w2-10533
- (vector-ref e-10179 2)))
- (let ((m1-10534 (car w-10181))
- (s1-10535 (cdr w-10181)))
- (if (null? m1-10534)
- (if (null? s1-10535)
- w2-10533
- (cons (car w2-10533)
- (let ((m2-10552
- (cdr w2-10533)))
- (if (null? m2-10552)
- s1-10535
- (append
- s1-10535
- m2-10552)))))
- (cons (let ((m2-10560
- (car w2-10533)))
- (if (null? m2-10560)
- m1-10534
- (append
- m1-10534
- m2-10560)))
- (let ((m2-10568
- (cdr w2-10533)))
- (if (null? m2-10568)
- s1-10535
- (append
- s1-10535
- m2-10568))))))))
- (module-10524
- (vector-ref e-10179 3)))
- (vector
- 'syntax-object
- expression-10522
- wrap-10523
- module-10524))
- (if (null? e-10179)
- e-10179
- (vector
- 'syntax-object
- e-10179
- w-10181
- mod-10183))))
- (if (if (null? (car w-10181))
- (null? (cdr w-10181))
- #f)
- id-10217
- (if (if (vector? id-10217)
- (if (= (vector-length id-10217) 4)
- (eq? (vector-ref id-10217 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-10620
- (vector-ref id-10217 1))
- (wrap-10621
- (let ((w2-10631
- (vector-ref id-10217 2)))
- (let ((m1-10632 (car w-10181))
- (s1-10633 (cdr w-10181)))
- (if (null? m1-10632)
- (if (null? s1-10633)
- w2-10631
- (cons (car w2-10631)
- (let ((m2-10650
- (cdr w2-10631)))
- (if (null? m2-10650)
- s1-10633
- (append
- s1-10633
- m2-10650)))))
- (cons (let ((m2-10658
- (car w2-10631)))
- (if (null? m2-10658)
- m1-10632
- (append
- m1-10632
- m2-10658)))
- (let ((m2-10666
- (cdr w2-10631)))
- (if (null? m2-10666)
- s1-10633
- (append
- s1-10633
- m2-10666))))))))
- (module-10622
- (vector-ref id-10217 3)))
- (vector
- 'syntax-object
- expression-10620
- wrap-10621
- module-10622))
- (if (null? id-10217)
- id-10217
- (vector
- 'syntax-object
- id-10217
- w-10181
- id-mod-10223))))))
- (if (eqv? type-10221 'displaced-lexical)
- (syntax-violation
- 'set!
- "identifier out of context"
- (if (if (null? (car w-10181))
- (null? (cdr w-10181))
- #f)
- id-10217
- (if (if (vector? id-10217)
- (if (= (vector-length id-10217) 4)
- (eq? (vector-ref id-10217 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-10724
- (vector-ref id-10217 1))
- (wrap-10725
- (let ((w2-10735
- (vector-ref id-10217 2)))
- (let ((m1-10736 (car w-10181))
- (s1-10737 (cdr w-10181)))
- (if (null? m1-10736)
- (if (null? s1-10737)
- w2-10735
- (cons (car w2-10735)
- (let ((m2-10754
- (cdr w2-10735)))
- (if (null? m2-10754)
- s1-10737
- (append
- s1-10737
- m2-10754)))))
- (cons (let ((m2-10762
- (car w2-10735)))
- (if (null? m2-10762)
- m1-10736
- (append
- m1-10736
- m2-10762)))
- (let ((m2-10770
- (cdr w2-10735)))
- (if (null? m2-10770)
- s1-10737
- (append
- s1-10737
- m2-10770))))))))
- (module-10726
- (vector-ref id-10217 3)))
- (vector
- 'syntax-object
- expression-10724
- wrap-10725
- module-10726))
- (if (null? id-10217)
- id-10217
- (vector
- 'syntax-object
- id-10217
- w-10181
- mod-10183)))))
- (syntax-violation
- 'set!
- "bad set!"
- (let ((x-10802
- (begin
- (if (if s-10182
- (supports-source-properties?
- e-10179)
- #f)
- (set-source-properties!
- e-10179
- s-10182))
- e-10179)))
- (if (if (null? (car w-10181))
- (null? (cdr w-10181))
- #f)
- x-10802
- (if (if (vector? x-10802)
- (if (= (vector-length x-10802) 4)
- (eq? (vector-ref x-10802 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-10834
- (vector-ref x-10802 1))
- (wrap-10835
- (let ((w2-10843
- (vector-ref x-10802 2)))
- (let ((m1-10844 (car w-10181))
- (s1-10845 (cdr w-10181)))
- (if (null? m1-10844)
- (if (null? s1-10845)
- w2-10843
- (cons (car w2-10843)
- (let ((m2-10860
- (cdr w2-10843)))
- (if (null? m2-10860)
- s1-10845
- (append
- s1-10845
- m2-10860)))))
- (cons (let ((m2-10868
- (car w2-10843)))
- (if (null? m2-10868)
- m1-10844
- (append
- m1-10844
- m2-10868)))
- (let ((m2-10876
- (cdr w2-10843)))
- (if (null? m2-10876)
- s1-10845
- (append
- s1-10845
- m2-10876))))))))
- (module-10836
- (vector-ref x-10802 3)))
- (vector
- 'syntax-object
- expression-10834
- wrap-10835
- module-10836))
- (if (null? x-10802)
- x-10802
- (vector
- 'syntax-object
- x-10802
- w-10181
- mod-10183)))))))))))))
- tmp-10185)
- (let ((tmp-10891
- ($sc-dispatch e-10179 '(_ (any . each-any) any))))
- (if tmp-10891
- (@apply
- (lambda (head-10895 tail-10896 val-10897)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- head-10895
- r-10180
- '(())
- #f
- #f
- mod-10183
- #t))
- (lambda (type-10900
- value-10901
- ee*-10902
- ee-10903
- ww-10904
- ss-10905
- modmod-10906)
- (if (eqv? type-10900 'module-ref)
- (let ((val-10912
+ (expand-lambda-case
+ e
+ r
+ w
+ s
+ mod
+ get-formals
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+ e2*
+ e1*
+ args*)))
+ (lambda (meta* else*)
+ (values
+ (append meta meta*)
+ (build-lambda-case s req opt rest kw inits vars body else*)))))))))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))
+ (strip (lambda (x w)
+ (if (memq 'top (car w))
+ x
+ (let f ((x x))
+ (cond ((syntax-object? x)
+ (strip (syntax-object-expression x) (syntax-object-wrap x)))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d))))
+ ((vector? x)
+ (let* ((old (vector->list x)) (new (map f old)))
+ (let lp ((l1 old) (l2 new))
+ (cond ((null? l1) x)
+ ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2)))
+ (else (list->vector new))))))
+ (else x))))))
+ (gen-var
+ (lambda (id)
+ (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (gensym (string-append (symbol->string id) "-")))))
+ (lambda-var-list
+ (lambda (vars)
+ (let lvl ((vars vars) (ls '()) (w '(())))
+ (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
+ ((id? vars) (cons (wrap vars w #f) ls))
+ ((null? vars) ls)
+ ((syntax-object? vars)
+ (lvl (syntax-object-expression vars)
+ ls
+ (join-wraps w (syntax-object-wrap vars))))
+ (else (cons vars ls)))))))
+ (global-extend 'local-syntax 'letrec-syntax #t)
+ (global-extend 'local-syntax 'let-syntax #f)
+ (global-extend
+ 'core
+ 'syntax-parameterize
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
+ (apply (lambda (var val e1 e2)
+ (let ((names (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(displaced-lexical))
+ (syntax-violation
+ 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((memv key '(syntax-parameter)) value)
+ (else
+ (syntax-violation
+ 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod))))))))
+ var))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
+ val))))
+ (expand-body
+ (cons e1 e2)
+ (source-wrap e w s mod)
+ (extend-env names bindings r)
+ w
+ mod)))
+ tmp)
+ (syntax-violation
+ 'syntax-parameterize
+ "bad syntax"
+ (source-wrap e w s mod))))))
+ (global-extend
+ 'core
+ 'quote
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
+ (if tmp
+ (apply (lambda (e) (build-data s (strip e w))) tmp)
+ (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
+ (global-extend
+ 'core
+ 'syntax
+ (letrec*
+ ((gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
+ (call-with-values
+ (lambda () (resolve-identifier e '(()) r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(syntax))
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps) (values (list 'ref var) maps))))
+ ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
+ (else (values (list 'quote e) maps))))))
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
+ (apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
+ (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots)) tmp-1))
+ (apply (lambda (x dots y)
+ (let f ((y y)
+ (k (lambda (maps)
+ (call-with-values
+ (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis" src)
+ (values (gen-map x (car maps)) (cdr maps))))))))
+ (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
+ (if (and tmp (apply (lambda (dots y) (ellipsis? dots)) tmp))
+ (apply (lambda (dots y)
+ (f y
+ (lambda (maps)
+ (call-with-values
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis" src)
+ (values (gen-mappend x (car maps)) (cdr maps))))))))
+ tmp)
(call-with-values
- (lambda ()
- (syntax-type-4382
- val-10897
- r-10180
- w-10181
- (let ((props-10979
- (source-properties
- (if (if (vector? val-10897)
- (if (= (vector-length
- val-10897)
- 4)
- (eq? (vector-ref
- val-10897
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref val-10897 1)
- val-10897))))
- (if (pair? props-10979)
- props-10979
- #f))
- #f
- mod-10183
- #f))
- (lambda (type-11012
- value-11013
- form-11014
- e-11015
- w-11016
- s-11017
- mod-11018)
- (expand-expr-4384
- type-11012
- value-11013
- form-11014
- e-11015
- r-10180
- w-11016
- s-11017
- mod-11018)))))
- (call-with-values
- (lambda ()
- (value-10901
- (cons head-10895 tail-10896)
- r-10180
- w-10181))
- (lambda (e-10913
- r-10914
- w-10915
- s*-10916
- mod-10917)
- (let ((tmp-10919 (list e-10913)))
- (if (@apply
- (lambda (e-10921)
- (if (symbol? e-10921)
- #t
- (if (if (vector? e-10921)
- (if (= (vector-length
- e-10921)
- 4)
- (eq? (vector-ref
- e-10921
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref e-10921 1))
- #f)))
- tmp-10919)
- (@apply
- (lambda (e-10951)
- (let ((var-10956
- (syntax->datum e-10951)))
- (begin
- (if (if (struct? val-10912)
- (eq? (struct-vtable
- val-10912)
- (vector-ref
- %expanded-vtables
- 14))
- #f)
- (let ((meta-11034
- (struct-ref
- val-10912
- 1)))
- (if (not (assq 'name
- meta-11034))
- (let ((v-11043
- (cons (cons 'name
- var-10956)
- meta-11034)))
- (struct-set!
- val-10912
- 1
- v-11043)))))
- (analyze-variable-4319
- mod-10917
- var-10956
- (lambda (mod-11049
- var-11050
- public?-11051)
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 6)
- s-10182
- mod-11049
- var-11050
- public?-11051
- val-10912))
- (lambda (var-11062)
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 8)
- s-10182
- var-11062
- val-10912))))))
- tmp-10919)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-10913))))))
- (let ((fun-exp-11078
- (let ((e-11086
- (list '#(syntax-object
- setter
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-3609 top))
- #("l-*-3610"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(type
- value
- ee*
- ee
- ww
- ss
- modmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3602"
- "l-*-3603"
- "l-*-3604"
- "l-*-3605"
- "l-*-3606"
- "l-*-3607"
- "l-*-3608"))
- #(ribcage
- #(head tail val)
- #((top) (top) (top))
- #("l-*-3587"
- "l-*-3588"
- "l-*-3589"))
- #(ribcage () () ())
- #(ribcage
- #(e r w s mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3561"
- "l-*-3562"
- "l-*-3563"
- "l-*-3564"
- "l-*-3565"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile))
- head-10895)))
+ (lambda () (gen-syntax src y r maps ellipsis? mod))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps) (values (gen-append x y) maps)))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (x y)
+ (call-with-values
+ (lambda () (gen-syntax src x r maps ellipsis? mod))
+ (lambda (x maps)
(call-with-values
- (lambda ()
- (syntax-type-4382
- e-11086
- r-10180
- w-10181
- (let ((props-11096
- (source-properties
- (if (if (vector? e-11086)
- (if (= (vector-length
- e-11086)
- 4)
- (eq? (vector-ref
- e-11086
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref e-11086 1)
- e-11086))))
- (if (pair? props-11096)
- props-11096
- #f))
- #f
- mod-10183
- #f))
- (lambda (type-11119
- value-11120
- form-11121
- e-11122
- w-11123
- s-11124
- mod-11125)
- (expand-expr-4384
- type-11119
- value-11120
- form-11121
- e-11122
- r-10180
- w-11123
- s-11124
- mod-11125)))))
- (arg-exps-11079
- (map (lambda (e-11129)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- e-11129
- r-10180
- w-10181
- (let ((props-11144
- (source-properties
- (if (if (vector?
- e-11129)
- (if (= (vector-length
- e-11129)
- 4)
- (eq? (vector-ref
- e-11129
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- e-11129
- 1)
- e-11129))))
- (if (pair? props-11144)
- props-11144
- #f))
- #f
- mod-10183
- #f))
- (lambda (type-11177
- value-11178
- form-11179
- e-11180
- w-11181
- s-11182
- mod-11183)
- (expand-expr-4384
- type-11177
- value-11178
- form-11179
- e-11180
- r-10180
- w-11181
- s-11182
- mod-11183))))
- (append
- tail-10896
- (list val-10897)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- s-10182
- fun-exp-11078
- arg-exps-11079))))))
- tmp-10891)
- (syntax-violation
- 'set!
- "bad set!"
- (let ((x-11197
- (begin
- (if (if s-10182
- (supports-source-properties? e-10179)
- #f)
- (set-source-properties! e-10179 s-10182))
- e-10179)))
- (if (if (null? (car w-10181))
- (null? (cdr w-10181))
- #f)
- x-11197
- (if (if (vector? x-11197)
- (if (= (vector-length x-11197) 4)
- (eq? (vector-ref x-11197 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-11229 (vector-ref x-11197 1))
- (wrap-11230
- (let ((w2-11238 (vector-ref x-11197 2)))
- (let ((m1-11239 (car w-10181))
- (s1-11240 (cdr w-10181)))
- (if (null? m1-11239)
- (if (null? s1-11240)
- w2-11238
- (cons (car w2-11238)
- (let ((m2-11255
- (cdr w2-11238)))
- (if (null? m2-11255)
- s1-11240
- (append
- s1-11240
- m2-11255)))))
- (cons (let ((m2-11263 (car w2-11238)))
- (if (null? m2-11263)
- m1-11239
- (append m1-11239 m2-11263)))
- (let ((m2-11271 (cdr w2-11238)))
- (if (null? m2-11271)
- s1-11240
- (append
- s1-11240
- m2-11271))))))))
- (module-11231 (vector-ref x-11197 3)))
- (vector
- 'syntax-object
- expression-11229
- wrap-11230
- module-11231))
- (if (null? x-11197)
- x-11197
- (vector
- 'syntax-object
- x-11197
- w-10181
- mod-10183))))))))))))
- (module-define!
- (current-module)
- '@
- (make-syntax-transformer
- '@
- 'module-ref
- (lambda (e-11302 r-11303 w-11304)
- (let ((tmp-11306
- ($sc-dispatch e-11302 '(_ each-any any))))
- (if (if tmp-11306
- (@apply
- (lambda (mod-11309 id-11310)
- (if (and-map id?-4347 mod-11309)
- (if (symbol? id-11310)
- #t
- (if (if (vector? id-11310)
- (if (= (vector-length id-11310) 4)
- (eq? (vector-ref id-11310 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-11310 1))
- #f))
- #f))
- tmp-11306)
- #f)
- (@apply
- (lambda (mod-11350 id-11351)
- (values
- (syntax->datum id-11351)
- r-11303
- w-11304
- #f
- (syntax->datum
- (cons '#(syntax-object
- public
- ((top)
- #(ribcage
- #(mod id)
- #((top) (top))
- #("l-*-3651" "l-*-3652"))
- #(ribcage () () ())
- #(ribcage
- #(e r w)
- #((top) (top) (top))
- #("l-*-3639" "l-*-3640" "l-*-3641"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile))
- mod-11350))))
- tmp-11306)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-11302))))))
- (global-extend-4345
- 'module-ref
- '@@
- (lambda (e-11465 r-11466 w-11467)
- (letrec*
- ((remodulate-11468
- (lambda (x-11530 mod-11531)
- (if (pair? x-11530)
- (cons (remodulate-11468 (car x-11530) mod-11531)
- (remodulate-11468 (cdr x-11530) mod-11531))
- (if (if (vector? x-11530)
- (if (= (vector-length x-11530) 4)
- (eq? (vector-ref x-11530 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-11545
- (remodulate-11468
- (vector-ref x-11530 1)
- mod-11531))
- (wrap-11546 (vector-ref x-11530 2)))
- (vector
- 'syntax-object
- expression-11545
- wrap-11546
- mod-11531))
- (if (vector? x-11530)
- (let ((n-11554 (vector-length x-11530)))
- (let ((v-11555 (make-vector n-11554)))
- (letrec*
- ((loop-11556
- (lambda (i-11611)
- (if (= i-11611 n-11554)
- v-11555
- (begin
- (vector-set!
- v-11555
- i-11611
- (remodulate-11468
- (vector-ref x-11530 i-11611)
- mod-11531))
- (loop-11556 (#{1+}# i-11611)))))))
- (loop-11556 0))))
- x-11530))))))
- (let ((tmp-11470
- ($sc-dispatch e-11465 '(_ each-any any))))
- (if (if tmp-11470
- (@apply
- (lambda (mod-11474 exp-11475)
- (and-map id?-4347 mod-11474))
- tmp-11470)
- #f)
- (@apply
- (lambda (mod-11491 exp-11492)
- (let ((mod-11493
- (syntax->datum
- (cons '#(syntax-object
- private
- ((top)
- #(ribcage
- #(mod exp)
- #((top) (top))
- #("l-*-3689" "l-*-3690"))
- #(ribcage
- (remodulate)
- ((top))
- ("l-*-3662"))
- #(ribcage
- #(e r w)
- #((top) (top) (top))
- #("l-*-3659" "l-*-3660" "l-*-3661"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile))
- mod-11491))))
- (values
- (remodulate-11468 exp-11492 mod-11493)
- r-11466
- w-11467
- (let ((props-11501
- (source-properties
- (if (if (vector? exp-11492)
- (if (= (vector-length exp-11492) 4)
- (eq? (vector-ref exp-11492 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref exp-11492 1)
- exp-11492))))
- (if (pair? props-11501) props-11501 #f))
- mod-11493)))
- tmp-11470)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-11465))))))
- (global-extend-4345
- 'core
- 'if
- (lambda (e-11884 r-11885 w-11886 s-11887 mod-11888)
- (let ((tmp-11890 ($sc-dispatch e-11884 '(_ any any))))
- (if tmp-11890
- (@apply
- (lambda (test-11894 then-11895)
- (let ((test-exp-11900
- (call-with-values
- (lambda ()
- (syntax-type-4382
- test-11894
- r-11885
- w-11886
- (let ((props-11922
- (source-properties
- (if (if (vector? test-11894)
- (if (= (vector-length
- test-11894)
- 4)
- (eq? (vector-ref
- test-11894
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref test-11894 1)
- test-11894))))
- (if (pair? props-11922) props-11922 #f))
- #f
- mod-11888
- #f))
- (lambda (type-11955
- value-11956
- form-11957
- e-11958
- w-11959
- s-11960
- mod-11961)
- (expand-expr-4384
- type-11955
- value-11956
- form-11957
- e-11958
- r-11885
- w-11959
- s-11960
- mod-11961))))
- (then-exp-11901
- (call-with-values
- (lambda ()
- (syntax-type-4382
- then-11895
- r-11885
- w-11886
- (let ((props-11979
- (source-properties
- (if (if (vector? then-11895)
- (if (= (vector-length
- then-11895)
- 4)
- (eq? (vector-ref
- then-11895
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref then-11895 1)
- then-11895))))
- (if (pair? props-11979) props-11979 #f))
- #f
- mod-11888
- #f))
- (lambda (type-12012
- value-12013
- form-12014
- e-12015
- w-12016
- s-12017
- mod-12018)
- (expand-expr-4384
- type-12012
- value-12013
- form-12014
- e-12015
- r-11885
- w-12016
- s-12017
- mod-12018))))
- (else-exp-11902
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 10)
- s-11887
- test-exp-11900
- then-exp-11901
- else-exp-11902)))
- tmp-11890)
- (let ((tmp-12027
- ($sc-dispatch e-11884 '(_ any any any))))
- (if tmp-12027
- (@apply
- (lambda (test-12031 then-12032 else-12033)
- (let ((test-exp-12038
- (call-with-values
- (lambda ()
- (syntax-type-4382
- test-12031
- r-11885
- w-11886
- (let ((props-12060
- (source-properties
- (if (if (vector? test-12031)
- (if (= (vector-length
- test-12031)
- 4)
- (eq? (vector-ref
- test-12031
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref test-12031 1)
- test-12031))))
- (if (pair? props-12060) props-12060 #f))
- #f
- mod-11888
- #f))
- (lambda (type-12093
- value-12094
- form-12095
- e-12096
- w-12097
- s-12098
- mod-12099)
- (expand-expr-4384
- type-12093
- value-12094
- form-12095
- e-12096
- r-11885
- w-12097
- s-12098
- mod-12099))))
- (then-exp-12039
- (call-with-values
- (lambda ()
- (syntax-type-4382
- then-12032
- r-11885
- w-11886
- (let ((props-12117
- (source-properties
- (if (if (vector? then-12032)
- (if (= (vector-length
- then-12032)
- 4)
- (eq? (vector-ref
- then-12032
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref then-12032 1)
- then-12032))))
- (if (pair? props-12117) props-12117 #f))
- #f
- mod-11888
- #f))
- (lambda (type-12150
- value-12151
- form-12152
- e-12153
- w-12154
- s-12155
- mod-12156)
- (expand-expr-4384
- type-12150
- value-12151
- form-12152
- e-12153
- r-11885
- w-12154
- s-12155
- mod-12156))))
- (else-exp-12040
- (call-with-values
- (lambda ()
- (syntax-type-4382
- else-12033
- r-11885
- w-11886
- (let ((props-12174
- (source-properties
- (if (if (vector? else-12033)
- (if (= (vector-length
- else-12033)
- 4)
- (eq? (vector-ref
- else-12033
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref else-12033 1)
- else-12033))))
- (if (pair? props-12174) props-12174 #f))
- #f
- mod-11888
- #f))
- (lambda (type-12207
- value-12208
- form-12209
- e-12210
- w-12211
- s-12212
- mod-12213)
- (expand-expr-4384
- type-12207
- value-12208
- form-12209
- e-12210
- r-11885
- w-12211
- s-12212
- mod-12213)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 10)
- s-11887
- test-exp-12038
- then-exp-12039
- else-exp-12040)))
- tmp-12027)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-11884)))))))
- (global-extend-4345
- 'core
- 'with-fluids
- (lambda (e-12466 r-12467 w-12468 s-12469 mod-12470)
- (let ((tmp-12472
- ($sc-dispatch
- e-12466
- '(_ #(each (any any)) any . each-any))))
- (if tmp-12472
- (@apply
- (lambda (fluid-12476 val-12477 b-12478 b*-12479)
- (let ((fluids-12483
- (map (lambda (x-12491)
- (call-with-values
- (lambda ()
- (syntax-type-4382
- x-12491
- r-12467
- w-12468
- (let ((props-12506
- (source-properties
- (if (if (vector? x-12491)
- (if (= (vector-length
- x-12491)
- 4)
- (eq? (vector-ref
- x-12491
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-12491 1)
- x-12491))))
- (if (pair? props-12506)
- props-12506
- #f))
- #f
- mod-12470
- #f))
- (lambda (type-12539
- value-12540
- form-12541
- e-12542
- w-12543
- s-12544
- mod-12545)
- (expand-expr-4384
- type-12539
- value-12540
- form-12541
- e-12542
- r-12467
- w-12543
- s-12544
- mod-12545))))
- fluid-12476))
- (vals-12484
- (map (lambda (x-12549)
+ (lambda () (gen-syntax src y r maps ellipsis? mod))
+ (lambda (y maps) (values (gen-cons x y) maps))))))
+ tmp-1)
+ (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any)))))
+ (if tmp
+ (apply (lambda (e1 e2)
+ (call-with-values
+ (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ tmp)
+ (values (list 'quote e) maps))))))))))))
+ (gen-ref
+ (lambda (src var level maps)
+ (cond ((= level 0) (values var maps))
+ ((null? maps) (syntax-violation 'syntax "missing ellipsis" src))
+ (else
+ (call-with-values
+ (lambda () (gen-ref src var (- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values
+ inner-var
+ (cons (cons (cons outer-var inner-var) (car maps)) outer-maps)))))))))))
+ (gen-mappend
+ (lambda (e map-env)
+ (list 'apply '(primitive append) (gen-map e map-env))))
+ (gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) (list 'ref (car x))) map-env)))
+ (cond ((eq? (car e) 'ref) (car actuals))
+ ((and-map
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ (cons 'map
+ (cons (list 'primitive (car e))
+ (map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e)))))
+ (else (cons 'map (cons (list 'lambda formals e) actuals)))))))
+ (gen-cons
+ (lambda (x y)
+ (let ((key (car y)))
+ (cond ((memv key '(quote))
+ (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y))))
+ ((eq? (cadr y) '()) (list 'list x))
+ (else (list 'cons x y))))
+ ((memv key '(list)) (cons 'list (cons x (cdr y))))
+ (else (list 'cons x y))))))
+ (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y))))
+ (gen-vector
+ (lambda (x)
+ (cond ((eq? (car x) 'list) (cons 'vector (cdr x)))
+ ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x))))
+ (else (list 'list->vector x)))))
+ (regen (lambda (x)
+ (let ((key (car x)))
+ (cond ((memv key '(ref))
+ (build-lexical-reference 'value #f (cadr x) (cadr x)))
+ ((memv key '(primitive)) (build-primref #f (cadr x)))
+ ((memv key '(quote)) (build-data #f (cadr x)))
+ ((memv key '(lambda))
+ (if (list? (cadr x))
+ (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
+ (error "how did we get here" x)))
+ (else (build-primcall #f (car x) (map regen (cdr x)))))))))
+ (lambda (e r w s mod)
+ (let* ((e (source-wrap e w s mod))
+ (tmp e)
+ (tmp ($sc-dispatch tmp '(_ any))))
+ (if tmp
+ (apply (lambda (x)
+ (call-with-values
+ (lambda () (gen-syntax e x r '() ellipsis? mod))
+ (lambda (e maps) (regen e))))
+ tmp)
+ (syntax-violation 'syntax "bad `syntax' form" e))))))
+ (global-extend
+ 'core
+ 'lambda
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (call-with-values
+ (lambda () (lambda-formals args))
+ (lambda (req opt rest kw)
+ (let lp ((body (cons e1 e2)) (meta '()))
+ (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any))))
+ (if (and tmp
+ (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
+ tmp))
+ (apply (lambda (docstring e1 e2)
+ (lp (cons e1 e2)
+ (append meta (list (cons 'documentation (syntax->datum docstring))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any))))
+ (if tmp
+ (apply (lambda (k v e1 e2)
+ (lp (cons e1 e2) (append meta (syntax->datum (map cons k v)))))
+ tmp)
+ (expand-simple-lambda e r w s mod req rest meta body)))))))))
+ tmp)
+ (syntax-violation 'lambda "bad lambda" e)))))
+ (global-extend
+ 'core
+ 'lambda*
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case
+ e
+ r
+ w
+ s
+ mod
+ lambda*-formals
+ (list (cons args (cons e1 e2)))))
+ (lambda (meta lcase) (build-case-lambda s meta lcase))))
+ tmp)
+ (syntax-violation 'lambda "bad lambda*" e)))))
+ (global-extend
+ 'core
+ 'case-lambda
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch
+ tmp
+ '(_ (any any . each-any) . #(each (any any . each-any))))))
+ (if tmp
+ (apply (lambda (args e1 e2 args* e1* e2*)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case
+ e
+ r
+ w
+ s
+ mod
+ lambda-formals
+ (cons (cons args (cons e1 e2))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+ e2*
+ e1*
+ args*))))
+ (lambda (meta lcase) (build-case-lambda s meta lcase))))
+ tmp)
+ (syntax-violation 'case-lambda "bad case-lambda" e)))))
+ (global-extend
+ 'core
+ 'case-lambda*
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch
+ tmp
+ '(_ (any any . each-any) . #(each (any any . each-any))))))
+ (if tmp
+ (apply (lambda (args e1 e2 args* e1* e2*)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case
+ e
+ r
+ w
+ s
+ mod
+ lambda*-formals
+ (cons (cons args (cons e1 e2))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+ e2*
+ e1*
+ args*))))
+ (lambda (meta lcase) (build-case-lambda s meta lcase))))
+ tmp)
+ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+ (global-extend
+ 'core
+ 'let
+ (letrec*
+ ((expand-let
+ (lambda (e r w s mod constructor ids vals exps)
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation 'let "duplicate bound variable" e)
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (let ((nw (make-binding-wrap ids labels w))
+ (nr (extend-var-env labels new-vars r)))
+ (constructor
+ s
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (expand x r w mod)) vals)
+ (expand-body exps (source-wrap e nw s mod) nr nw mod))))))))
+ (lambda (e r w s mod)
+ (let* ((tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
+ (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+ (apply (lambda (id val e1 e2)
+ (expand-let e r w s mod build-let id val (cons e1 e2)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any))))
+ (if (and tmp
+ (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp))
+ (apply (lambda (f id val e1 e2)
+ (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2)))
+ tmp)
+ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))))
+ (global-extend
+ 'core
+ 'letrec
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+ (apply (lambda (id val e1 e2)
+ (let ((ids id))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation 'letrec "duplicate bound variable" e)
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (let ((w (make-binding-wrap ids labels w))
+ (r (extend-var-env labels new-vars r)))
+ (build-letrec
+ s
+ #f
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (expand x r w mod)) val)
+ (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
+ tmp)
+ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
+ (global-extend
+ 'core
+ 'letrec*
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+ (apply (lambda (id val e1 e2)
+ (let ((ids id))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation 'letrec* "duplicate bound variable" e)
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (let ((w (make-binding-wrap ids labels w))
+ (r (extend-var-env labels new-vars r)))
+ (build-letrec
+ s
+ #t
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (expand x r w mod)) val)
+ (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
+ tmp)
+ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
+ (global-extend
+ 'core
+ 'set!
+ (lambda (e r w s mod)
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
+ (if (and tmp (apply (lambda (id val) (id? id)) tmp))
+ (apply (lambda (id val)
+ (call-with-values
+ (lambda () (resolve-identifier id w r mod #t))
+ (lambda (type value id-mod)
+ (let ((key type))
+ (cond ((memv key '(lexical))
+ (build-lexical-assignment
+ s
+ (syntax->datum id)
+ value
+ (expand val r w mod)))
+ ((memv key '(global))
+ (build-global-assignment s value (expand val r w mod) id-mod))
+ ((memv key '(macro))
+ (if (procedure-property value 'variable-transformer)
+ (expand (expand-macro value e r w s #f mod) r '(()) mod)
+ (syntax-violation
+ 'set!
+ "not a variable transformer"
+ (wrap e w mod)
+ (wrap id w id-mod))))
+ ((memv key '(displaced-lexical))
+ (syntax-violation 'set! "identifier out of context" (wrap id w mod)))
+ (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
+ (if tmp
+ (apply (lambda (head tail val)
+ (call-with-values
+ (lambda () (syntax-type head r '(()) #f #f mod #t))
+ (lambda (type value ee* ee ww ss modmod)
+ (let ((key type))
+ (if (memv key '(module-ref))
+ (let ((val (expand val r w mod)))
(call-with-values
- (lambda ()
- (syntax-type-4382
- x-12549
- r-12467
- w-12468
- (let ((props-12564
- (source-properties
- (if (if (vector? x-12549)
- (if (= (vector-length
- x-12549)
- 4)
- (eq? (vector-ref
- x-12549
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-12549 1)
- x-12549))))
- (if (pair? props-12564)
- props-12564
- #f))
- #f
- mod-12470
- #f))
- (lambda (type-12597
- value-12598
- form-12599
- e-12600
- w-12601
- s-12602
- mod-12603)
- (expand-expr-4384
- type-12597
- value-12598
- form-12599
- e-12600
- r-12467
- w-12601
- s-12602
- mod-12603))))
- val-12477))
- (body-12485
- (expand-body-4387
- (cons b-12478 b*-12479)
- (let ((x-12616
- (begin
- (if (if s-12469
- (supports-source-properties?
- e-12466)
- #f)
- (set-source-properties!
- e-12466
- s-12469))
- e-12466)))
- (if (if (null? (car w-12468))
- (null? (cdr w-12468))
- #f)
- x-12616
- (if (if (vector? x-12616)
- (if (= (vector-length x-12616) 4)
- (eq? (vector-ref x-12616 0)
- 'syntax-object)
- #f)
- #f)
- (make-syntax-object-4333
- (vector-ref x-12616 1)
- (let ((w2-12652 (vector-ref x-12616 2)))
- (let ((m1-12653 (car w-12468))
- (s1-12654 (cdr w-12468)))
- (if (null? m1-12653)
- (if (null? s1-12654)
- w2-12652
- (cons (car w2-12652)
- (let ((m2-12669
- (cdr w2-12652)))
- (if (null? m2-12669)
- s1-12654
- (append
- s1-12654
- m2-12669)))))
- (cons (let ((m2-12677
- (car w2-12652)))
- (if (null? m2-12677)
- m1-12653
- (append
- m1-12653
- m2-12677)))
- (let ((m2-12685
- (cdr w2-12652)))
- (if (null? m2-12685)
- s1-12654
- (append
- s1-12654
- m2-12685)))))))
- (vector-ref x-12616 3))
- (if (null? x-12616)
- x-12616
- (make-syntax-object-4333
- x-12616
- w-12468
- mod-12470)))))
- r-12467
- w-12468
- mod-12470)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 18)
- s-12469
- fluids-12483
- vals-12484
- body-12485)))
- tmp-12472)
+ (lambda () (value (cons head tail) r w))
+ (lambda (e r w s* mod)
+ (let* ((tmp-1 e) (tmp (list tmp-1)))
+ (if (and tmp (apply (lambda (e) (id? e)) tmp))
+ (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))
+ (build-call
+ s
+ (expand
+ (list '#(syntax-object setter ((top)) (hygiene guile)) head)
+ r
+ w
+ mod)
+ (map (lambda (e) (expand e r w mod)) (append tail (list val)))))))))
+ tmp)
+ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
+ (global-extend
+ 'module-ref
+ '@
+ (lambda (e r w)
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
+ (if (and tmp
+ (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
+ (apply (lambda (mod id)
+ (values
+ (syntax->datum id)
+ r
+ w
+ #f
+ (syntax->datum
+ (cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ (global-extend
+ 'module-ref
+ '@@
+ (lambda (e r w)
+ (letrec*
+ ((remodulate
+ (lambda (x mod)
+ (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod)))
+ ((syntax-object? x)
+ (make-syntax-object
+ (remodulate (syntax-object-expression x) mod)
+ (syntax-object-wrap x)
+ mod))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (let loop ((i 0))
+ (if (= i n)
+ (begin (if #f #f) v)
+ (begin
+ (vector-set! v i (remodulate (vector-ref x i) mod))
+ (loop (+ i 1)))))))
+ (else x)))))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
+ (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
+ (apply (lambda (mod exp)
+ (let ((mod (syntax->datum
+ (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
+ (values (remodulate exp mod) r w (source-annotation exp) mod)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))
+ (global-extend
+ 'core
+ 'if
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
+ (if tmp-1
+ (apply (lambda (test then)
+ (build-conditional
+ s
+ (expand test r w mod)
+ (expand then r w mod)
+ (build-void #f)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
+ (if tmp-1
+ (apply (lambda (test then else)
+ (build-conditional
+ s
+ (expand test r w mod)
+ (expand then r w mod)
+ (expand else r w mod)))
+ tmp-1)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-12466)))))
- (module-define!
- (current-module)
- 'begin
- (make-syntax-transformer 'begin 'begin '()))
- (module-define!
- (current-module)
- 'define
- (make-syntax-transformer 'define 'define '()))
- (module-define!
- (current-module)
- 'define-syntax
- (make-syntax-transformer
- 'define-syntax
- 'define-syntax
- '()))
- (module-define!
- (current-module)
- 'define-syntax-parameter
- (make-syntax-transformer
- 'define-syntax-parameter
- 'define-syntax-parameter
- '()))
- (module-define!
- (current-module)
- 'eval-when
- (make-syntax-transformer
- 'eval-when
- 'eval-when
- '()))
- (global-extend-4345
- 'core
- 'syntax-case
- (letrec*
- ((convert-pattern-12980
- (lambda (pattern-14451 keys-14452)
- (letrec*
- ((cvt*-14453
- (lambda (p*-15252 n-15253 ids-15254)
- (if (not (pair? p*-15252))
- (cvt-14455 p*-15252 n-15253 ids-15254)
+ tmp)))))))
+ (global-extend
+ 'core
+ 'with-fluids
+ (lambda (e r w s mod)
+ (let* ((tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
+ (if tmp
+ (apply (lambda (fluid val b b*)
+ (build-dynlet
+ s
+ (map (lambda (x) (expand x r w mod)) fluid)
+ (map (lambda (x) (expand x r w mod)) val)
+ (expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ (global-extend 'begin 'begin '())
+ (global-extend 'define 'define '())
+ (global-extend 'define-syntax 'define-syntax '())
+ (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
+ (global-extend 'eval-when 'eval-when '())
+ (global-extend
+ 'core
+ 'syntax-case
+ (letrec*
+ ((convert-pattern
+ (lambda (pattern keys)
+ (letrec*
+ ((cvt* (lambda (p* n ids)
+ (if (not (pair? p*))
+ (cvt p* n ids)
(call-with-values
- (lambda ()
- (cvt*-14453 (cdr p*-15252) n-15253 ids-15254))
- (lambda (y-15257 ids-15258)
+ (lambda () (cvt* (cdr p*) n ids))
+ (lambda (y ids)
(call-with-values
- (lambda ()
- (cvt-14455 (car p*-15252) n-15253 ids-15258))
- (lambda (x-15261 ids-15262)
- (values
- (cons x-15261 y-15257)
- ids-15262))))))))
- (v-reverse-14454
- (lambda (x-15263)
- (letrec*
- ((loop-15264
- (lambda (r-15365 x-15366)
- (if (not (pair? x-15366))
- (values r-15365 x-15366)
- (loop-15264
- (cons (car x-15366) r-15365)
- (cdr x-15366))))))
- (loop-15264 '() x-15263))))
- (cvt-14455
- (lambda (p-14458 n-14459 ids-14460)
- (if (if (symbol? p-14458)
- #t
- (if (if (vector? p-14458)
- (if (= (vector-length p-14458) 4)
- (eq? (vector-ref p-14458 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref p-14458 1))
- #f))
- (if (bound-id-member?-4375 p-14458 keys-14452)
- (values (vector 'free-id p-14458) ids-14460)
- (if (free-id=?-4371
- p-14458
- '#(syntax-object
- _
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("l-*-3790" "l-*-3791" "l-*-3792"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("l-*-3763" "l-*-3761" "l-*-3759"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("l-*-3757" "l-*-3758"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3753"
- "l-*-3751"
- "l-*-3749"
- "l-*-3747"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile)))
- (values '_ ids-14460)
- (values
- 'any
- (cons (cons p-14458 n-14459) ids-14460))))
- (let ((tmp-14592 ($sc-dispatch p-14458 '(any any))))
- (if (if tmp-14592
- (@apply
- (lambda (x-14596 dots-14597)
- (if (if (if (vector? dots-14597)
- (if (= (vector-length dots-14597)
- 4)
- (eq? (vector-ref dots-14597 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref dots-14597 1))
- #f)
- (free-id=?-4371
- dots-14597
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2325"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile)))
- #f))
- tmp-14592)
- #f)
- (@apply
- (lambda (x-14636 dots-14637)
- (call-with-values
- (lambda ()
- (cvt-14455
- x-14636
- (#{1+}# n-14459)
- ids-14460))
- (lambda (p-14638 ids-14639)
- (values
- (if (eq? p-14638 'any)
- 'each-any
- (vector 'each p-14638))
- ids-14639))))
- tmp-14592)
- (let ((tmp-14640
- ($sc-dispatch p-14458 '(any any . any))))
- (if (if tmp-14640
- (@apply
- (lambda (x-14644 dots-14645 ys-14646)
- (if (if (if (vector? dots-14645)
- (if (= (vector-length
- dots-14645)
- 4)
- (eq? (vector-ref
- dots-14645
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref dots-14645 1))
- #f)
- (free-id=?-4371
- dots-14645
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2325"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile)))
- #f))
- tmp-14640)
- #f)
- (@apply
- (lambda (x-14685 dots-14686 ys-14687)
+ (lambda () (cvt (car p*) n ids))
+ (lambda (x ids) (values (cons x y) ids))))))))
+ (v-reverse
+ (lambda (x)
+ (let loop ((r '()) (x x))
+ (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x))))))
+ (cvt (lambda (p n ids)
+ (if (id? p)
+ (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids))
+ ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile)))
+ (values '_ ids))
+ (else (values 'any (cons (cons p n) ids))))
+ (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1))
+ (apply (lambda (x dots)
(call-with-values
- (lambda ()
- (cvt*-14453
- ys-14687
- n-14459
- ids-14460))
- (lambda (ys-15172 ids-15173)
+ (lambda () (cvt x (+ n 1) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any (vector 'each p)) ids))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
+ (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1))
+ (apply (lambda (x dots ys)
(call-with-values
- (lambda ()
- (cvt-14455
- x-14685
- (#{1+}# n-14459)
- ids-15173))
- (lambda (x-15174 ids-15175)
+ (lambda () (cvt* ys n ids))
+ (lambda (ys ids)
(call-with-values
- (lambda ()
- (v-reverse-14454 ys-15172))
- (lambda (ys-15211 e-15212)
- (values
- (vector
- 'each+
- x-15174
- ys-15211
- e-15212)
- ids-15175))))))))
- tmp-14640)
- (let ((tmp-15213
- ($sc-dispatch p-14458 '(any . any))))
- (if tmp-15213
- (@apply
- (lambda (x-15217 y-15218)
- (call-with-values
- (lambda ()
- (cvt-14455
- y-15218
- n-14459
- ids-14460))
- (lambda (y-15219 ids-15220)
+ (lambda () (cvt x (+ n 1) ids))
+ (lambda (x ids)
+ (call-with-values
+ (lambda () (v-reverse ys))
+ (lambda (ys e) (values (vector 'each+ x ys e) ids))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (x y)
(call-with-values
- (lambda ()
- (cvt-14455
- x-15217
- n-14459
- ids-15220))
- (lambda (x-15221 ids-15222)
- (values
- (cons x-15221 y-15219)
- ids-15222))))))
- tmp-15213)
- (let ((tmp-15223
- ($sc-dispatch p-14458 '())))
- (if tmp-15223
- (@apply
- (lambda () (values '() ids-14460))
- tmp-15223)
- (let ((tmp-15227
- ($sc-dispatch
- p-14458
- '#(vector each-any))))
- (if tmp-15227
- (@apply
- (lambda (x-15231)
+ (lambda () (cvt y n ids))
+ (lambda (y ids)
(call-with-values
- (lambda ()
- (cvt-14455
- x-15231
- n-14459
- ids-14460))
- (lambda (p-15232 ids-15233)
- (values
- (vector 'vector p-15232)
- ids-15233))))
- tmp-15227)
- (values
- (vector
- 'atom
- (strip-4396 p-14458 '(())))
- ids-14460)))))))))))))))
- (cvt-14455 pattern-14451 0 '()))))
- (build-dispatch-call-12981
- (lambda (pvars-15367 exp-15368 y-15369 r-15370 mod-15371)
- (let ((ids-15372 (map car pvars-15367)))
- (begin
- (map cdr pvars-15367)
- (let ((labels-15374 (gen-labels-4350 ids-15372))
- (new-vars-15375 (map gen-var-4397 ids-15372)))
- (build-primcall-4326
- #f
- 'apply
- (list (build-simple-lambda-4323
- #f
- (map syntax->datum ids-15372)
- #f
- new-vars-15375
- '()
- (expand-4383
- exp-15368
- (extend-env-4342
- labels-15374
- (map (lambda (var-15703 level-15704)
- (cons 'syntax
- (cons var-15703 level-15704)))
- new-vars-15375
- (map cdr pvars-15367))
- r-15370)
- (make-binding-wrap-4361
- ids-15372
- labels-15374
- '(()))
- mod-15371))
- y-15369)))))))
- (gen-clause-12982
- (lambda (x-14035
- keys-14036
- clauses-14037
- r-14038
- pat-14039
- fender-14040
- exp-14041
- mod-14042)
+ (lambda () (cvt x n ids))
+ (lambda (x ids) (values (cons x y) ids))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (values '() ids)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (call-with-values
+ (lambda () (cvt x n ids))
+ (lambda (p ids) (values (vector 'vector p) ids))))
+ tmp-1)
+ (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids))))))))))))))))
+ (cvt pattern 0 '()))))
+ (build-dispatch-call
+ (lambda (pvars exp y r mod)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (build-primcall
+ #f
+ 'apply
+ (list (build-simple-lambda
+ #f
+ (map syntax->datum ids)
+ #f
+ new-vars
+ '()
+ (expand
+ exp
+ (extend-env
+ labels
+ (map (lambda (var level) (cons 'syntax (cons var level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels '(()))
+ mod))
+ y))))))
+ (gen-clause
+ (lambda (x keys clauses r pat fender exp mod)
+ (call-with-values
+ (lambda () (convert-pattern pat keys))
+ (lambda (p pvars)
+ (cond ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-violation 'syntax-case "duplicate pattern variable" pat))
+ ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (syntax-violation 'syntax-case "misplaced ellipsis" pat))
+ (else
+ (let ((y (gen-var 'tmp)))
+ (build-call
+ #f
+ (build-simple-lambda
+ #f
+ (list 'tmp)
+ #f
+ (list y)
+ '()
+ (let ((y (build-lexical-reference 'value #f 'tmp y)))
+ (build-conditional
+ #f
+ (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t))))
+ (if tmp
+ (apply (lambda () y) tmp)
+ (build-conditional
+ #f
+ y
+ (build-dispatch-call pvars fender y r mod)
+ (build-data #f #f))))
+ (build-dispatch-call pvars exp y r mod)
+ (gen-syntax-case x keys clauses r mod))))
+ (list (if (eq? p 'any)
+ (build-primcall #f 'list (list x))
+ (build-primcall #f '$sc-dispatch (list x (build-data #f p)))))))))))))
+ (gen-syntax-case
+ (lambda (x keys clauses r mod)
+ (if (null? clauses)
+ (build-primcall
+ #f
+ 'syntax-violation
+ (list (build-data #f #f)
+ (build-data #f "source expression failed to match any pattern")
+ x))
+ (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (pat exp)
+ (if (and (id? pat)
+ (and-map
+ (lambda (x) (not (free-id=? pat x)))
+ (cons '#(syntax-object ... ((top)) (hygiene guile)) keys)))
+ (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
+ (expand exp r '(()) mod)
+ (let ((labels (list (gen-label))) (var (gen-var pat)))
+ (build-call
+ #f
+ (build-simple-lambda
+ #f
+ (list (syntax->datum pat))
+ #f
+ (list var)
+ '()
+ (expand
+ exp
+ (extend-env labels (list (cons 'syntax (cons var 0))) r)
+ (make-binding-wrap (list pat) labels '(()))
+ mod))
+ (list x))))
+ (gen-clause x keys (cdr clauses) r pat #t exp mod)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(any any any))))
+ (if tmp
+ (apply (lambda (pat fender exp)
+ (gen-clause x keys (cdr clauses) r pat fender exp mod))
+ tmp)
+ (syntax-violation 'syntax-case "invalid clause" (car clauses))))))))))
+ (lambda (e r w s mod)
+ (let* ((e (source-wrap e w s mod))
+ (tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
+ (if tmp
+ (apply (lambda (val key m)
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key)
+ (let ((x (gen-var 'tmp)))
+ (build-call
+ s
+ (build-simple-lambda
+ #f
+ (list 'tmp)
+ #f
+ (list x)
+ '()
+ (gen-syntax-case
+ (build-lexical-reference 'value #f 'tmp x)
+ key
+ m
+ r
+ mod))
+ (list (expand val r '(()) mod))))
+ (syntax-violation 'syntax-case "invalid literals list" e)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))
+ (set! macroexpand
+ (lambda* (x #:optional (m 'e) (esew '(eval)))
+ (expand-top-sequence
+ (list x)
+ '()
+ '((top))
+ #f
+ m
+ esew
+ (cons 'hygiene (module-name (current-module))))))
+ (set! identifier? (lambda (x) (nonsymbol-id? x)))
+ (set! datum->syntax
+ (lambda (id datum)
+ (make-syntax-object
+ datum
+ (syntax-object-wrap id)
+ (syntax-object-module id))))
+ (set! syntax->datum (lambda (x) (strip x '(()))))
+ (set! syntax-source (lambda (x) (source-annotation x)))
+ (set! generate-temporaries
+ (lambda (ls)
+ (let ((x ls))
+ (if (not (list? x))
+ (syntax-violation 'generate-temporaries "invalid argument" x)))
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls))))
+ (set! free-identifier=?
+ (lambda (x y)
+ (let ((x x))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'free-identifier=? "invalid argument" x)))
+ (let ((x y))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'free-identifier=? "invalid argument" x)))
+ (free-id=? x y)))
+ (set! bound-identifier=?
+ (lambda (x y)
+ (let ((x x))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'bound-identifier=? "invalid argument" x)))
+ (let ((x y))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'bound-identifier=? "invalid argument" x)))
+ (bound-id=? x y)))
+ (set! syntax-violation
+ (lambda* (who message form #:optional (subform #f))
+ (let ((x who))
+ (if (not (let ((x x)) (or (not x) (string? x) (symbol? x))))
+ (syntax-violation 'syntax-violation "invalid argument" x)))
+ (let ((x message))
+ (if (not (string? x))
+ (syntax-violation 'syntax-violation "invalid argument" x)))
+ (throw 'syntax-error
+ who
+ message
+ (or (source-annotation subform) (source-annotation form))
+ (strip form '(()))
+ (and subform (strip subform '(()))))))
+ (letrec*
+ ((syntax-module
+ (lambda (id)
+ (let ((x id))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'syntax-module "invalid argument" x)))
+ (cdr (syntax-object-module id))))
+ (syntax-local-binding
+ (lambda (id)
+ (let ((x id))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'syntax-local-binding "invalid argument" x)))
+ (with-transformer-environment
+ (lambda (e r w s rib mod)
+ (letrec*
+ ((strip-anti-mark
+ (lambda (w)
+ (let ((ms (car w)) (s (cdr w)))
+ (if (and (pair? ms) (eq? (car ms) #f))
+ (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+ (cons ms (if rib (cons rib s) s)))))))
(call-with-values
(lambda ()
- (convert-pattern-12980 pat-14039 keys-14036))
- (lambda (p-14180 pvars-14181)
- (if (not (distinct-bound-ids?-4374 (map car pvars-14181)))
- (syntax-violation
- 'syntax-case
- "duplicate pattern variable"
- pat-14039)
- (if (not (and-map
- (lambda (x-14290)
- (not (let ((x-14294 (car x-14290)))
- (if (if (if (vector? x-14294)
- (if (= (vector-length
- x-14294)
- 4)
- (eq? (vector-ref
- x-14294
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-14294 1))
- #f)
- (free-id=?-4371
- x-14294
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2325"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile)))
- #f))))
- pvars-14181))
- (syntax-violation
- 'syntax-case
- "misplaced ellipsis"
- pat-14039)
- (let ((y-14319
- (gensym
- (string-append (symbol->string 'tmp) "-"))))
- (let ((fun-exp-14324
- (let ((req-14333 (list 'tmp))
- (vars-14335 (list y-14319))
- (exp-14337
- (let ((y-14366
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 3)
- #f
- 'tmp
- y-14319)))
- (let ((test-exp-14370
- (let ((tmp-14379
- ($sc-dispatch
- fender-14040
- '#(atom #t))))
- (if tmp-14379
- (@apply
- (lambda () y-14366)
- tmp-14379)
- (let ((then-exp-14397
- (build-dispatch-call-12981
- pvars-14181
- fender-14040
- y-14366
- r-14038
- mod-14042))
- (else-exp-14398
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 1)
- #f
- #f)))
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 10)
- #f
- y-14366
- then-exp-14397
- else-exp-14398)))))
- (then-exp-14371
- (build-dispatch-call-12981
- pvars-14181
- exp-14041
- y-14366
- r-14038
- mod-14042))
- (else-exp-14372
- (gen-syntax-case-12983
- x-14035
- keys-14036
- clauses-14037
- r-14038
- mod-14042)))
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 10)
- #f
- test-exp-14370
- then-exp-14371
- else-exp-14372)))))
- (let ((body-14342
- (make-struct/no-tail
- (vector-ref %expanded-vtables 15)
- #f
- req-14333
- #f
- #f
- #f
- '()
- vars-14335
- exp-14337
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- '()
- body-14342))))
- (arg-exps-14325
- (list (if (eq? p-14180 'any)
- (let ((args-14430 (list x-14035)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- #f
- 'list
- args-14430))
- (let ((args-14439
- (list x-14035
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 1)
- #f
- p-14180))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- #f
- '$sc-dispatch
- args-14439))))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-14324
- arg-exps-14325)))))))))
- (gen-syntax-case-12983
- (lambda (x-13555
- keys-13556
- clauses-13557
- r-13558
- mod-13559)
- (if (null? clauses-13557)
- (let ((args-13565
- (list (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- #f)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- "source expression failed to match any pattern")
- x-13555)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- #f
- 'syntax-violation
- args-13565))
- (let ((tmp-13584 (car clauses-13557)))
- (let ((tmp-13585 ($sc-dispatch tmp-13584 '(any any))))
- (if tmp-13585
- (@apply
- (lambda (pat-13587 exp-13588)
- (if (if (if (symbol? pat-13587)
- #t
- (if (if (vector? pat-13587)
- (if (= (vector-length pat-13587) 4)
- (eq? (vector-ref pat-13587 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref pat-13587 1))
- #f))
- (and-map
- (lambda (x-13615)
- (not (free-id=?-4371 pat-13587 x-13615)))
- (cons '#(syntax-object
- ...
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3942" "l-*-3943"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top) (top) (top) (top) (top))
- #("l-*-3932"
- "l-*-3933"
- "l-*-3934"
- "l-*-3935"
- "l-*-3936"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3753"
- "l-*-3751"
- "l-*-3749"
- "l-*-3747"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile))
- keys-13556))
- #f)
- (if (free-id=?-4371
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3942" "l-*-3943"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top) (top) (top) (top) (top))
- #("l-*-3932"
- "l-*-3933"
- "l-*-3934"
- "l-*-3935"
- "l-*-3936"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3753"
- "l-*-3751"
- "l-*-3749"
- "l-*-3747"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile))
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3942" "l-*-3943"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top) (top) (top) (top) (top))
- #("l-*-3932"
- "l-*-3933"
- "l-*-3934"
- "l-*-3935"
- "l-*-3936"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3753"
- "l-*-3751"
- "l-*-3749"
- "l-*-3747"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile)))
- (call-with-values
- (lambda ()
- (syntax-type-4382
- exp-13588
- r-13558
- '(())
- (let ((props-13635
- (source-properties
- (if (if (vector? exp-13588)
- (if (= (vector-length
- exp-13588)
- 4)
- (eq? (vector-ref
- exp-13588
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref exp-13588 1)
- exp-13588))))
- (if (pair? props-13635) props-13635 #f))
- #f
- mod-13559
- #f))
- (lambda (type-13668
- value-13669
- form-13670
- e-13671
- w-13672
- s-13673
- mod-13674)
- (expand-expr-4384
- type-13668
- value-13669
- form-13670
- e-13671
- r-13558
- w-13672
- s-13673
- mod-13674)))
- (let ((labels-13678
- (list (string-append
- "l-"
- (session-id-4308)
- (symbol->string (gensym "-")))))
- (var-13679
- (let ((id-13717
- (if (if (vector? pat-13587)
- (if (= (vector-length
- pat-13587)
- 4)
- (eq? (vector-ref
- pat-13587
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref pat-13587 1)
- pat-13587)))
- (gensym
- (string-append
- (symbol->string id-13717)
- "-")))))
- (build-call-4314
- #f
- (build-simple-lambda-4323
- #f
- (list (syntax->datum pat-13587))
- #f
- (list var-13679)
- '()
- (expand-4383
- exp-13588
- (extend-env-4342
- labels-13678
- (list (cons 'syntax
- (cons var-13679 0)))
- r-13558)
- (make-binding-wrap-4361
- (list pat-13587)
- labels-13678
- '(()))
- mod-13559))
- (list x-13555))))
- (gen-clause-12982
- x-13555
- keys-13556
- (cdr clauses-13557)
- r-13558
- pat-13587
- #t
- exp-13588
- mod-13559)))
- tmp-13585)
- (let ((tmp-14027
- ($sc-dispatch tmp-13584 '(any any any))))
- (if tmp-14027
- (@apply
- (lambda (pat-14029 fender-14030 exp-14031)
- (gen-clause-12982
- x-13555
- keys-13556
- (cdr clauses-13557)
- r-13558
- pat-14029
- fender-14030
- exp-14031
- mod-13559))
- tmp-14027)
- (syntax-violation
- 'syntax-case
- "invalid clause"
- (car clauses-13557)))))))))))
- (lambda (e-12984 r-12985 w-12986 s-12987 mod-12988)
- (let ((e-12989
- (let ((x-13466
- (begin
- (if (if s-12987
- (supports-source-properties? e-12984)
- #f)
- (set-source-properties! e-12984 s-12987))
- e-12984)))
- (if (if (null? (car w-12986))
- (null? (cdr w-12986))
- #f)
- x-13466
- (if (if (vector? x-13466)
- (if (= (vector-length x-13466) 4)
- (eq? (vector-ref x-13466 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-13498 (vector-ref x-13466 1))
- (wrap-13499
- (let ((w2-13507 (vector-ref x-13466 2)))
- (let ((m1-13508 (car w-12986))
- (s1-13509 (cdr w-12986)))
- (if (null? m1-13508)
- (if (null? s1-13509)
- w2-13507
- (cons (car w2-13507)
- (let ((m2-13524
- (cdr w2-13507)))
- (if (null? m2-13524)
- s1-13509
- (append
- s1-13509
- m2-13524)))))
- (cons (let ((m2-13532 (car w2-13507)))
- (if (null? m2-13532)
- m1-13508
- (append m1-13508 m2-13532)))
- (let ((m2-13540 (cdr w2-13507)))
- (if (null? m2-13540)
- s1-13509
- (append
- s1-13509
- m2-13540))))))))
- (module-13500 (vector-ref x-13466 3)))
- (vector
- 'syntax-object
- expression-13498
- wrap-13499
- module-13500))
- (if (null? x-13466)
- x-13466
- (vector
- 'syntax-object
- x-13466
- w-12986
- mod-12988)))))))
- (let ((tmp-12990 e-12989))
- (let ((tmp-12991
- ($sc-dispatch
- tmp-12990
- '(_ any each-any . each-any))))
- (if tmp-12991
- (@apply
- (lambda (val-13039 key-13040 m-13041)
- (if (and-map
- (lambda (x-13042)
- (if (if (symbol? x-13042)
- #t
- (if (if (vector? x-13042)
- (if (= (vector-length x-13042) 4)
- (eq? (vector-ref x-13042 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-13042 1))
- #f))
- (not (if (if (if (vector? x-13042)
- (if (= (vector-length x-13042)
- 4)
- (eq? (vector-ref x-13042 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-13042 1))
- #f)
- (free-id=?-4371
- x-13042
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2325"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-call
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- 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
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-primcall
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-call
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-seq
- make-primcall
- make-call
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-478"
- "l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-401"
- "l-*-399"
- "l-*-396"
- "l-*-395"
- "l-*-394"
- "l-*-392"
- "l-*-391"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-372"
- "l-*-370"
- "l-*-369"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-360"
- "l-*-359"
- "l-*-358"
- "l-*-356"
- "l-*-355"
- "l-*-352"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-341"
- "l-*-340"
- "l-*-338"
- "l-*-336"
- "l-*-335"
- "l-*-332"
- "l-*-331"
- "l-*-329"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-310"
- "l-*-308"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-257"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-245"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45"))
- #(ribcage () () ()))
- (hygiene guile)))
- #f))
- #f))
- key-13040)
- (let ((x-13107
- (gensym
- (string-append
- (symbol->string 'tmp)
- "-"))))
- (let ((fun-exp-13112
- (let ((req-13121 (list 'tmp))
- (vars-13123 (list x-13107))
- (exp-13125
- (gen-syntax-case-12983
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 3)
- #f
- 'tmp
- x-13107)
- key-13040
- m-13041
- r-12985
- mod-12988)))
- (let ((body-13130
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 15)
- #f
- req-13121
- #f
- #f
- #f
- '()
- vars-13123
- exp-13125
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- '()
- body-13130))))
- (arg-exps-13113
- (list (call-with-values
- (lambda ()
- (syntax-type-4382
- val-13039
- r-12985
- '(())
- (let ((props-13179
- (source-properties
- (if (if (vector?
- val-13039)
- (if (= (vector-length
- val-13039)
- 4)
- (eq? (vector-ref
- val-13039
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- val-13039
- 1)
- val-13039))))
- (if (pair? props-13179)
- props-13179
- #f))
- #f
- mod-12988
- #f))
- (lambda (type-13212
- value-13213
- form-13214
- e-13215
- w-13216
- s-13217
- mod-13218)
- (expand-expr-4384
- type-13212
- value-13213
- form-13214
- e-13215
- r-12985
- w-13216
- s-13217
- mod-13218))))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- s-12987
- fun-exp-13112
- arg-exps-13113)))
- (syntax-violation
- 'syntax-case
- "invalid literals list"
- e-12989)))
- tmp-12991)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-12990))))))))
- (set! macroexpand
- (lambda*
- (x-15783
- #:optional
- (m-15784 'e)
- (esew-15785 '(eval)))
- (expand-top-sequence-4379
- (list x-15783)
- '()
- '((top))
- #f
- m-15784
- esew-15785
- (cons 'hygiene (module-name (current-module))))))
- (set! identifier?
- (lambda (x-15788)
- (if (if (vector? x-15788)
- (if (= (vector-length x-15788) 4)
- (eq? (vector-ref x-15788 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-15788 1))
- #f)))
- (set! datum->syntax
- (lambda (id-15813 datum-15814)
- (let ((wrap-15819 (vector-ref id-15813 2))
- (module-15820 (vector-ref id-15813 3)))
- (vector
- 'syntax-object
- datum-15814
- wrap-15819
- module-15820))))
- (set! syntax->datum
- (lambda (x-15827) (strip-4396 x-15827 '(()))))
- (set! syntax-source
- (lambda (x-15830)
- (let ((props-15835
- (source-properties
- (if (if (vector? x-15830)
- (if (= (vector-length x-15830) 4)
- (eq? (vector-ref x-15830 0) 'syntax-object)
- #f)
- #f)
- (vector-ref x-15830 1)
- x-15830))))
- (if (pair? props-15835) props-15835 #f))))
- (set! generate-temporaries
- (lambda (ls-15858)
- (begin
- (if (not (list? ls-15858))
- (syntax-violation
- 'generate-temporaries
- "invalid argument"
- ls-15858))
- (let ((mod-15866
- (cons 'hygiene (module-name (current-module)))))
- (map (lambda (x-15867)
- (let ((x-15871 (gensym "t-")))
- (if (if (vector? x-15871)
- (if (= (vector-length x-15871) 4)
- (eq? (vector-ref x-15871 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-15886 (vector-ref x-15871 1))
- (wrap-15887
- (let ((w2-15895 (vector-ref x-15871 2)))
- (cons (let ((m2-15902 (car w2-15895)))
- (if (null? m2-15902)
- '(top)
- (append '(top) m2-15902)))
- (let ((m2-15909 (cdr w2-15895)))
- (if (null? m2-15909)
- '()
- (append '() m2-15909))))))
- (module-15888 (vector-ref x-15871 3)))
- (vector
- 'syntax-object
- expression-15886
- wrap-15887
- module-15888))
- (if (null? x-15871)
- x-15871
- (vector
- 'syntax-object
- x-15871
- '((top))
- mod-15866)))))
- ls-15858)))))
- (set! free-identifier=?
- (lambda (x-15918 y-15919)
- (begin
- (if (not (if (if (vector? x-15918)
- (if (= (vector-length x-15918) 4)
- (eq? (vector-ref x-15918 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-15918 1))
- #f))
- (syntax-violation
- 'free-identifier=?
- "invalid argument"
- x-15918))
- (if (not (if (if (vector? y-15919)
- (if (= (vector-length y-15919) 4)
- (eq? (vector-ref y-15919 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref y-15919 1))
- #f))
- (syntax-violation
- 'free-identifier=?
- "invalid argument"
- y-15919))
- (free-id=?-4371 x-15918 y-15919))))
- (set! bound-identifier=?
- (lambda (x-15994 y-15995)
- (begin
- (if (not (if (if (vector? x-15994)
- (if (= (vector-length x-15994) 4)
- (eq? (vector-ref x-15994 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-15994 1))
- #f))
- (syntax-violation
- 'bound-identifier=?
- "invalid argument"
- x-15994))
- (if (not (if (if (vector? y-15995)
- (if (= (vector-length y-15995) 4)
- (eq? (vector-ref y-15995 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref y-15995 1))
- #f))
- (syntax-violation
- 'bound-identifier=?
- "invalid argument"
- y-15995))
- (bound-id=?-4372 x-15994 y-15995))))
- (set! syntax-violation
- (lambda*
- (who-16161
- message-16162
- form-16163
- #:optional
- (subform-16164 #f))
- (begin
- (if (not (if (not who-16161)
- (not who-16161)
- (let ((t-16182 (string? who-16161)))
- (if t-16182 t-16182 (symbol? who-16161)))))
- (syntax-violation
- 'syntax-violation
- "invalid argument"
- who-16161))
- (if (not (string? message-16162))
- (syntax-violation
- 'syntax-violation
- "invalid argument"
- message-16162))
- (throw 'syntax-error
- who-16161
- message-16162
- (let ((t-16213
- (let ((props-16272
- (source-properties
- (if (if (vector? subform-16164)
- (if (= (vector-length subform-16164)
- 4)
- (eq? (vector-ref subform-16164 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref subform-16164 1)
- subform-16164))))
- (if (pair? props-16272) props-16272 #f))))
- (if t-16213
- t-16213
- (let ((props-16245
- (source-properties
- (if (if (vector? form-16163)
- (if (= (vector-length form-16163) 4)
- (eq? (vector-ref form-16163 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref form-16163 1)
- form-16163))))
- (if (pair? props-16245) props-16245 #f))))
- (strip-4396 form-16163 '(()))
- (if subform-16164
- (strip-4396 subform-16164 '(()))
- #f)))))
- (letrec*
- ((syntax-local-binding-16300
- (lambda (id-16440)
- (begin
- (if (not (if (if (vector? id-16440)
- (if (= (vector-length id-16440) 4)
- (eq? (vector-ref id-16440 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-16440 1))
- #f))
- (syntax-violation
- 'syntax-local-binding
- "invalid argument"
- id-16440))
- ((fluid-ref transformer-environment-4369)
- (lambda (e-16480
- r-16481
- w-16482
- s-16483
- rib-16484
- mod-16485)
+ (resolve-identifier
+ (syntax-object-expression id)
+ (strip-anti-mark (syntax-object-wrap id))
+ r
+ (syntax-object-module id)
+ #t))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(lexical)) (values 'lexical value))
+ ((memv key '(macro)) (values 'macro value))
+ ((memv key '(syntax)) (values 'pattern-variable value))
+ ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
+ ((memv key '(global)) (values 'global (cons value (cdr mod))))
+ (else (values 'other #f)))))))))))
+ (syntax-locally-bound-identifiers
+ (lambda (id)
+ (let ((x id))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation
+ 'syntax-locally-bound-identifiers
+ "invalid argument"
+ x)))
+ (locally-bound-identifiers
+ (syntax-object-wrap id)
+ (syntax-object-module id)))))
+ (define! 'syntax-module syntax-module)
+ (define! 'syntax-local-binding syntax-local-binding)
+ (define!
+ 'syntax-locally-bound-identifiers
+ syntax-locally-bound-identifiers))
+ (letrec*
+ ((match-each
+ (lambda (e p w mod)
+ (cond ((pair? e)
+ (let ((first (match (car e) p w '() mod)))
+ (and first
+ (let ((rest (match-each (cdr e) p w mod)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each
+ (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ (syntax-object-module e)))
+ (else #f))))
+ (match-each+
+ (lambda (e x-pat y-pat z-pat w r mod)
+ (let f ((e e) (w w))
+ (cond ((pair? e)
(call-with-values
- (lambda ()
- (resolve-identifier-4368
- (vector-ref id-16440 1)
- (let ((w-16492 (vector-ref id-16440 2)))
- (let ((ms-16493 (car w-16492))
- (s-16494 (cdr w-16492)))
- (if (if (pair? ms-16493)
- (eq? (car ms-16493) #f)
- #f)
- (cons (cdr ms-16493)
- (if rib-16484
- (cons rib-16484 (cdr s-16494))
- (cdr s-16494)))
- (cons ms-16493
- (if rib-16484
- (cons rib-16484 s-16494)
- s-16494)))))
- r-16481
- (vector-ref id-16440 3)
- #t))
- (lambda (type-16501 value-16502 mod-16503)
- (if (eqv? type-16501 'lexical)
- (values 'lexical value-16502)
- (if (eqv? type-16501 'macro)
- (values 'macro value-16502)
- (if (eqv? type-16501 'syntax)
- (values 'pattern-variable value-16502)
- (if (eqv? type-16501 'displaced-lexical)
- (values 'displaced-lexical #f)
- (if (eqv? type-16501 'global)
- (values
- 'global
- (cons value-16502 (cdr mod-16503)))
- (values 'other #f)))))))))))))
- (syntax-locally-bound-identifiers-16301
- (lambda (id-16525)
- (begin
- (if (not (if (if (vector? id-16525)
- (if (= (vector-length id-16525) 4)
- (eq? (vector-ref id-16525 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-16525 1))
- #f))
- (syntax-violation
- 'syntax-locally-bound-identifiers
- "invalid argument"
- id-16525))
- (locally-bound-identifiers-4367
- (vector-ref id-16525 2)
- (vector-ref id-16525 3))))))
- (begin
- (define!
- 'syntax-module
- (lambda (id-16303)
- (begin
- (if (not (if (if (vector? id-16303)
- (if (= (vector-length id-16303) 4)
- (eq? (vector-ref id-16303 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-16303 1))
- #f))
- (syntax-violation
- 'syntax-module
- "invalid argument"
- id-16303))
- (cdr (vector-ref id-16303 3)))))
- (define!
- 'syntax-local-binding
- syntax-local-binding-16300)
- (define!
- 'syntax-locally-bound-identifiers
- syntax-locally-bound-identifiers-16301)))
- (letrec*
- ((match-each-16642
- (lambda (e-17521 p-17522 w-17523 mod-17524)
- (if (pair? e-17521)
- (let ((first-17525
- (match-16648
- (car e-17521)
- p-17522
- w-17523
- '()
- mod-17524)))
- (if first-17525
- (let ((rest-17528
- (match-each-16642
- (cdr e-17521)
- p-17522
- w-17523
- mod-17524)))
- (if rest-17528 (cons first-17525 rest-17528) #f))
- #f))
- (if (null? e-17521)
- '()
- (if (if (vector? e-17521)
- (if (= (vector-length e-17521) 4)
- (eq? (vector-ref e-17521 0) 'syntax-object)
- #f)
- #f)
- (match-each-16642
- (vector-ref e-17521 1)
- p-17522
- (let ((w2-17550 (vector-ref e-17521 2)))
- (let ((m1-17551 (car w-17523))
- (s1-17552 (cdr w-17523)))
- (if (null? m1-17551)
- (if (null? s1-17552)
- w2-17550
- (cons (car w2-17550)
- (let ((m2-17563 (cdr w2-17550)))
- (if (null? m2-17563)
- s1-17552
- (append s1-17552 m2-17563)))))
- (cons (let ((m2-17571 (car w2-17550)))
- (if (null? m2-17571)
- m1-17551
- (append m1-17551 m2-17571)))
- (let ((m2-17579 (cdr w2-17550)))
- (if (null? m2-17579)
- s1-17552
- (append s1-17552 m2-17579)))))))
- (vector-ref e-17521 3))
- #f)))))
- (match-each-any-16644
- (lambda (e-17588 w-17589 mod-17590)
- (if (pair? e-17588)
- (let ((l-17591
- (match-each-any-16644
- (cdr e-17588)
- w-17589
- mod-17590)))
- (if l-17591
- (cons (let ((x-17596 (car e-17588)))
- (if (if (null? (car w-17589))
- (null? (cdr w-17589))
- #f)
- x-17596
- (if (if (vector? x-17596)
- (if (= (vector-length x-17596) 4)
- (eq? (vector-ref x-17596 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-17614 (vector-ref x-17596 1))
- (wrap-17615
- (let ((w2-17623 (vector-ref x-17596 2)))
- (let ((m1-17624 (car w-17589))
- (s1-17625 (cdr w-17589)))
- (if (null? m1-17624)
- (if (null? s1-17625)
- w2-17623
- (cons (car w2-17623)
- (let ((m2-17640
- (cdr w2-17623)))
- (if (null? m2-17640)
- s1-17625
- (append
- s1-17625
- m2-17640)))))
- (cons (let ((m2-17648
- (car w2-17623)))
- (if (null? m2-17648)
- m1-17624
- (append
- m1-17624
- m2-17648)))
- (let ((m2-17656
- (cdr w2-17623)))
- (if (null? m2-17656)
- s1-17625
- (append
- s1-17625
- m2-17656))))))))
- (module-17616 (vector-ref x-17596 3)))
- (vector
- 'syntax-object
- expression-17614
- wrap-17615
- module-17616))
- (if (null? x-17596)
- x-17596
- (vector
- 'syntax-object
- x-17596
- w-17589
- mod-17590)))))
- l-17591)
- #f))
- (if (null? e-17588)
- '()
- (if (if (vector? e-17588)
- (if (= (vector-length e-17588) 4)
- (eq? (vector-ref e-17588 0) 'syntax-object)
- #f)
- #f)
- (match-each-any-16644
- (vector-ref e-17588 1)
- (let ((w2-17689 (vector-ref e-17588 2)))
- (let ((m1-17690 (car w-17589))
- (s1-17691 (cdr w-17589)))
- (if (null? m1-17690)
- (if (null? s1-17691)
- w2-17689
- (cons (car w2-17689)
- (let ((m2-17702 (cdr w2-17689)))
- (if (null? m2-17702)
- s1-17691
- (append s1-17691 m2-17702)))))
- (cons (let ((m2-17710 (car w2-17689)))
- (if (null? m2-17710)
- m1-17690
- (append m1-17690 m2-17710)))
- (let ((m2-17718 (cdr w2-17689)))
- (if (null? m2-17718)
- s1-17691
- (append s1-17691 m2-17718)))))))
- mod-17590)
- #f)))))
- (match-empty-16645
- (lambda (p-17723 r-17724)
- (if (null? p-17723)
- r-17724
- (if (eq? p-17723 '_)
- r-17724
- (if (eq? p-17723 'any)
- (cons '() r-17724)
- (if (pair? p-17723)
- (match-empty-16645
- (car p-17723)
- (match-empty-16645 (cdr p-17723) r-17724))
- (if (eq? p-17723 'each-any)
- (cons '() r-17724)
- (let ((key-17725 (vector-ref p-17723 0)))
- (if (eqv? key-17725 'each)
- (match-empty-16645
- (vector-ref p-17723 1)
- r-17724)
- (if (eqv? key-17725 'each+)
- (match-empty-16645
- (vector-ref p-17723 1)
- (match-empty-16645
- (reverse (vector-ref p-17723 2))
- (match-empty-16645
- (vector-ref p-17723 3)
- r-17724)))
- (if (if (eqv? key-17725 'free-id)
- #t
- (eqv? key-17725 'atom))
- r-17724
- (if (eqv? key-17725 'vector)
- (match-empty-16645
- (vector-ref p-17723 1)
- r-17724)))))))))))))
- (combine-16646
- (lambda (r*-17744 r-17745)
- (if (null? (car r*-17744))
- r-17745
- (cons (map car r*-17744)
- (combine-16646 (map cdr r*-17744) r-17745)))))
- (match*-16647
- (lambda (e-16677 p-16678 w-16679 r-16680 mod-16681)
- (if (null? p-16678)
- (if (null? e-16677) r-16680 #f)
- (if (pair? p-16678)
- (if (pair? e-16677)
- (match-16648
- (car e-16677)
- (car p-16678)
- w-16679
- (match-16648
- (cdr e-16677)
- (cdr p-16678)
- w-16679
- r-16680
- mod-16681)
- mod-16681)
- #f)
- (if (eq? p-16678 'each-any)
- (let ((l-16686
- (match-each-any-16644 e-16677 w-16679 mod-16681)))
- (if l-16686 (cons l-16686 r-16680) #f))
- (let ((key-16691 (vector-ref p-16678 0)))
- (if (eqv? key-16691 'each)
- (if (null? e-16677)
- (match-empty-16645
- (vector-ref p-16678 1)
- r-16680)
- (let ((l-16698
- (match-each-16642
- e-16677
- (vector-ref p-16678 1)
- w-16679
- mod-16681)))
- (if l-16698
- (letrec*
- ((collect-16701
- (lambda (l-16758)
- (if (null? (car l-16758))
- r-16680
- (cons (map car l-16758)
- (collect-16701
- (map cdr l-16758)))))))
- (collect-16701 l-16698))
- #f)))
- (if (eqv? key-16691 'each+)
+ (lambda () (f (cdr e) w))
+ (lambda (xr* y-pat r)
+ (if r
+ (if (null? y-pat)
+ (let ((xr (match (car e) x-pat w '() mod)))
+ (if xr (values (cons xr xr*) y-pat r) (values #f #f #f)))
+ (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
+ (values #f #f #f)))))
+ ((syntax-object? e)
+ (f (syntax-object-expression e) (join-wraps w e)))
+ (else (values '() y-pat (match e z-pat w r mod)))))))
+ (match-each-any
+ (lambda (e w mod)
+ (cond ((pair? e)
+ (let ((l (match-each-any (cdr e) w mod)))
+ (and l (cons (wrap (car e) w mod) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any
+ (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))
+ mod))
+ (else #f))))
+ (match-empty
+ (lambda (p r)
+ (cond ((null? p) r)
+ ((eq? p '_) r)
+ ((eq? p 'any) (cons '() r))
+ ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+ ((eq? p 'each-any) (cons '() r))
+ (else
+ (let ((key (vector-ref p 0)))
+ (cond ((memv key '(each)) (match-empty (vector-ref p 1) r))
+ ((memv key '(each+))
+ (match-empty
+ (vector-ref p 1)
+ (match-empty
+ (reverse (vector-ref p 2))
+ (match-empty (vector-ref p 3) r))))
+ ((memv key '(free-id atom)) r)
+ ((memv key '(vector)) (match-empty (vector-ref p 1) r))))))))
+ (combine
+ (lambda (r* r)
+ (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
+ (match*
+ (lambda (e p w r mod)
+ (cond ((null? p) (and (null? e) r))
+ ((pair? p)
+ (and (pair? e)
+ (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod)))
+ ((eq? p 'each-any)
+ (let ((l (match-each-any e w mod))) (and l (cons l r))))
+ (else
+ (let ((key (vector-ref p 0)))
+ (cond ((memv key '(each))
+ (if (null? e)
+ (match-empty (vector-ref p 1) r)
+ (let ((l (match-each e (vector-ref p 1) w mod)))
+ (and l
+ (let collect ((l l))
+ (if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
+ ((memv key '(each+))
(call-with-values
(lambda ()
- (let ((x-pat-16767 (vector-ref p-16678 1))
- (y-pat-16768 (vector-ref p-16678 2))
- (z-pat-16769 (vector-ref p-16678 3)))
- (letrec*
- ((f-16773
- (lambda (e-16775 w-16776)
- (if (pair? e-16775)
- (call-with-values
- (lambda ()
- (f-16773 (cdr e-16775) w-16776))
- (lambda (xr*-16777
- y-pat-16778
- r-16779)
- (if r-16779
- (if (null? y-pat-16778)
- (let ((xr-16780
- (match-16648
- (car e-16775)
- x-pat-16767
- w-16776
- '()
- mod-16681)))
- (if xr-16780
- (values
- (cons xr-16780 xr*-16777)
- y-pat-16778
- r-16779)
- (values #f #f #f)))
- (values
- '()
- (cdr y-pat-16778)
- (match-16648
- (car e-16775)
- (car y-pat-16778)
- w-16776
- r-16779
- mod-16681)))
- (values #f #f #f))))
- (if (if (vector? e-16775)
- (if (= (vector-length e-16775) 4)
- (eq? (vector-ref e-16775 0)
- 'syntax-object)
- #f)
- #f)
- (f-16773
- (vector-ref e-16775 1)
- (let ((m1-16806 (car w-16776))
- (s1-16807 (cdr w-16776)))
- (if (null? m1-16806)
- (if (null? s1-16807)
- e-16775
- (cons (car e-16775)
- (let ((m2-16819
- (cdr e-16775)))
- (if (null? m2-16819)
- s1-16807
- (append
- s1-16807
- m2-16819)))))
- (cons (let ((m2-16829
- (car e-16775)))
- (if (null? m2-16829)
- m1-16806
- (append
- m1-16806
- m2-16829)))
- (let ((m2-16839
- (cdr e-16775)))
- (if (null? m2-16839)
- s1-16807
- (append
- s1-16807
- m2-16839)))))))
- (values
- '()
- y-pat-16768
- (match-16648
- e-16775
- z-pat-16769
- w-16776
- r-16680
- mod-16681)))))))
- (f-16773 e-16677 w-16679))))
- (lambda (xr*-16849 y-pat-16850 r-16851)
- (if r-16851
- (if (null? y-pat-16850)
- (if (null? xr*-16849)
- (match-empty-16645
- (vector-ref p-16678 1)
- r-16851)
- (combine-16646 xr*-16849 r-16851))
- #f)
- #f)))
- (if (eqv? key-16691 'free-id)
- (if (if (symbol? e-16677)
- #t
- (if (if (vector? e-16677)
- (if (= (vector-length e-16677) 4)
- (eq? (vector-ref e-16677 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref e-16677 1))
- #f))
- (if (free-id=?-4371
- (if (if (null? (car w-16679))
- (null? (cdr w-16679))
- #f)
- e-16677
- (if (if (vector? e-16677)
- (if (= (vector-length e-16677) 4)
- (eq? (vector-ref e-16677 0)
- 'syntax-object)
- #f)
- #f)
- (let ((expression-17279
- (vector-ref e-16677 1))
- (wrap-17280
- (let ((w2-17290
- (vector-ref e-16677 2)))
- (let ((m1-17291 (car w-16679))
- (s1-17292
- (cdr w-16679)))
- (if (null? m1-17291)
- (if (null? s1-17292)
- w2-17290
- (cons (car w2-17290)
- (let ((m2-17309
- (cdr w2-17290)))
- (if (null? m2-17309)
- s1-17292
- (append
- s1-17292
- m2-17309)))))
- (cons (let ((m2-17317
- (car w2-17290)))
- (if (null? m2-17317)
- m1-17291
- (append
- m1-17291
- m2-17317)))
- (let ((m2-17325
- (cdr w2-17290)))
- (if (null? m2-17325)
- s1-17292
- (append
- s1-17292
- m2-17325))))))))
- (module-17281
- (vector-ref e-16677 3)))
- (vector
- 'syntax-object
- expression-17279
- wrap-17280
- module-17281))
- (if (null? e-16677)
- e-16677
- (vector
- 'syntax-object
- e-16677
- w-16679
- mod-16681))))
- (vector-ref p-16678 1))
- r-16680
- #f)
- #f)
- (if (eqv? key-16691 'atom)
- (if (equal?
- (vector-ref p-16678 1)
- (strip-4396 e-16677 w-16679))
- r-16680
- #f)
- (if (eqv? key-16691 'vector)
- (if (vector? e-16677)
- (match-16648
- (vector->list e-16677)
- (vector-ref p-16678 1)
- w-16679
- r-16680
- mod-16681)
- #f))))))))))))
- (match-16648
- (lambda (e-17358 p-17359 w-17360 r-17361 mod-17362)
- (if (not r-17361)
- #f
- (if (eq? p-17359 '_)
- r-17361
- (if (eq? p-17359 'any)
- (cons (if (if (null? (car w-17360))
- (null? (cdr w-17360))
- #f)
- e-17358
- (if (if (vector? e-17358)
- (if (= (vector-length e-17358) 4)
- (eq? (vector-ref e-17358 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-17392 (vector-ref e-17358 1))
- (wrap-17393
- (let ((w2-17403 (vector-ref e-17358 2)))
- (let ((m1-17404 (car w-17360))
- (s1-17405 (cdr w-17360)))
- (if (null? m1-17404)
- (if (null? s1-17405)
- w2-17403
- (cons (car w2-17403)
- (let ((m2-17422
- (cdr w2-17403)))
- (if (null? m2-17422)
- s1-17405
- (append
- s1-17405
- m2-17422)))))
- (cons (let ((m2-17430
- (car w2-17403)))
- (if (null? m2-17430)
- m1-17404
- (append
- m1-17404
- m2-17430)))
- (let ((m2-17438
- (cdr w2-17403)))
- (if (null? m2-17438)
- s1-17405
- (append
- s1-17405
- m2-17438))))))))
- (module-17394 (vector-ref e-17358 3)))
- (vector
- 'syntax-object
- expression-17392
- wrap-17393
- module-17394))
- (if (null? e-17358)
- e-17358
- (vector
- 'syntax-object
- e-17358
- w-17360
- mod-17362))))
- r-17361)
- (if (if (vector? e-17358)
- (if (= (vector-length e-17358) 4)
- (eq? (vector-ref e-17358 0) 'syntax-object)
- #f)
- #f)
- (match*-16647
- (vector-ref e-17358 1)
- p-17359
- (let ((w2-17481 (vector-ref e-17358 2)))
- (let ((m1-17482 (car w-17360))
- (s1-17483 (cdr w-17360)))
- (if (null? m1-17482)
- (if (null? s1-17483)
- w2-17481
- (cons (car w2-17481)
- (let ((m2-17494 (cdr w2-17481)))
- (if (null? m2-17494)
- s1-17483
- (append s1-17483 m2-17494)))))
- (cons (let ((m2-17502 (car w2-17481)))
- (if (null? m2-17502)
- m1-17482
- (append m1-17482 m2-17502)))
- (let ((m2-17510 (cdr w2-17481)))
- (if (null? m2-17510)
- s1-17483
- (append s1-17483 m2-17510)))))))
- r-17361
- (vector-ref e-17358 3))
- (match*-16647
- e-17358
- p-17359
- w-17360
- r-17361
- mod-17362))))))))
- (set! $sc-dispatch
- (lambda (e-16649 p-16650)
- (if (eq? p-16650 'any)
- (list e-16649)
- (if (eq? p-16650 '_)
- '()
- (if (if (vector? e-16649)
- (if (= (vector-length e-16649) 4)
- (eq? (vector-ref e-16649 0) 'syntax-object)
- #f)
- #f)
- (match*-16647
- (vector-ref e-16649 1)
- p-16650
- (vector-ref e-16649 2)
- '()
- (vector-ref e-16649 3))
- (match*-16647 e-16649 p-16650 '(()) '() #f))))))))))
+ (match-each+
+ e
+ (vector-ref p 1)
+ (vector-ref p 2)
+ (vector-ref p 3)
+ w
+ r
+ mod))
+ (lambda (xr* y-pat r)
+ (and r
+ (null? y-pat)
+ (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
+ ((memv key '(free-id))
+ (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
+ ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r))
+ ((memv key '(vector))
+ (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
+ (match (lambda (e p w r mod)
+ (cond ((not r) #f)
+ ((eq? p '_) r)
+ ((eq? p 'any) (cons (wrap e w mod) r))
+ ((syntax-object? e)
+ (match*
+ (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r
+ (syntax-object-module e)))
+ (else (match* e p w r mod))))))
+ (set! $sc-dispatch
+ (lambda (e p)
+ (cond ((eq? p 'any) (list e))
+ ((eq? p '_) '())
+ ((syntax-object? e)
+ (match*
+ (syntax-object-expression e)
+ p
+ (syntax-object-wrap e)
+ '()
+ (syntax-object-module e)))
+ (else (match* e p '(()) '() #f)))))))
(define with-syntax
(make-syntax-transformer
'with-syntax
'macro
- (lambda (x-35161)
- (let ((tmp-35163
- ($sc-dispatch x-35161 '(_ () any . each-any))))
- (if tmp-35163
- (@apply
- (lambda (e1-35167 e2-35168)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-35134" "l-*-35135"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35131"))
- #(ribcage
- (with-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- with-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons '() (cons e1-35167 e2-35168))))
- tmp-35163)
- (let ((tmp-35169
- ($sc-dispatch
- x-35161
- '(_ ((any any)) any . each-any))))
- (if tmp-35169
- (@apply
- (lambda (out-35173 in-35174 e1-35175 e2-35176)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-35140"
- "l-*-35141"
- "l-*-35142"
- "l-*-35143"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35131"))
- #(ribcage
- (with-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- with-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- in-35174
- '()
- (list out-35173
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-35140"
- "l-*-35141"
- "l-*-35142"
- "l-*-35143"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35131"))
- #(ribcage
- (with-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- with-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons '() (cons e1-35175 e2-35176))))))
- tmp-35169)
- (let ((tmp-35177
- ($sc-dispatch
- x-35161
- '(_ #(each (any any)) any . each-any))))
- (if tmp-35177
- (@apply
- (lambda (out-35181 in-35182 e1-35183 e2-35184)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-35150"
- "l-*-35151"
- "l-*-35152"
- "l-*-35153"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35131"))
- #(ribcage
- (with-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- with-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons '#(syntax-object
- list
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-35150"
- "l-*-35151"
- "l-*-35152"
- "l-*-35153"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35131"))
- #(ribcage
- (with-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- with-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- in-35182)
- '()
- (list out-35181
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-35150"
- "l-*-35151"
- "l-*-35152"
- "l-*-35153"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35131"))
- #(ribcage
- (with-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- with-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons '() (cons e1-35183 e2-35184))))))
- tmp-35177)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-35161))))))))))
+ (lambda (x)
+ (let ((tmp x))
+ (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2)
+ (cons '#(syntax-object let ((top)) (hygiene guile))
+ (cons '() (cons e1 e2))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
+ (if tmp-1
+ (apply (lambda (out in e1 e2)
+ (list '#(syntax-object syntax-case ((top)) (hygiene guile))
+ in
+ '()
+ (list out
+ (cons '#(syntax-object let ((top)) (hygiene guile))
+ (cons '() (cons e1 e2))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if tmp-1
+ (apply (lambda (out in e1 e2)
+ (list '#(syntax-object syntax-case ((top)) (hygiene guile))
+ (cons '#(syntax-object list ((top)) (hygiene guile)) in)
+ '()
+ (list out
+ (cons '#(syntax-object let ((top)) (hygiene guile))
+ (cons '() (cons e1 e2))))))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp)))))))))))
(define syntax-rules
(make-syntax-transformer
'syntax-rules
'macro
- (lambda (x-35239)
- (let ((tmp-35241
- ($sc-dispatch
- x-35239
- '(_ each-any . #(each ((any . any) any))))))
- (if tmp-35241
- (@apply
- (lambda (k-35245
- keyword-35246
- pattern-35247
- template-35248)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (vector
- '(#(syntax-object
- macro-type
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- .
- #(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
+ (lambda (xx)
+ (let ((tmp-1 xx))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any))))))
+ (if tmp
+ (apply (lambda (k keyword pattern template)
+ (list '#(syntax-object lambda ((top)) (hygiene guile))
+ '(#(syntax-object x ((top)) (hygiene guile)))
+ (vector
+ '(#(syntax-object macro-type ((top)) (hygiene guile))
.
#(syntax-object
syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (cons '#(syntax-object
- patterns
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- pattern-35247))
- (cons '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons '#(syntax-object
- x
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons k-35245
- (map (lambda (tmp-35213-35249
- tmp-35212-35250)
- (list (cons '#(syntax-object
- _
- ((top)
- #(ribcage
- #(k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- tmp-35212-35250)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top))
- #("l-*-35202"
- "l-*-35203"
- "l-*-35204"
- "l-*-35205"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- tmp-35213-35249)))
- template-35248
- pattern-35247))))))
- tmp-35241)
- (let ((tmp-35251
- ($sc-dispatch
- x-35239
- '(_ each-any any . #(each ((any . any) any))))))
- (if (if tmp-35251
- (@apply
- (lambda (k-35255
- docstring-35256
- keyword-35257
- pattern-35258
- template-35259)
- (string? (syntax->datum docstring-35256)))
- tmp-35251)
- #f)
- (@apply
- (lambda (k-35260
- docstring-35261
- keyword-35262
- pattern-35263
- template-35264)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- docstring-35261
- (vector
- '(#(syntax-object
- macro-type
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- .
- #(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
+ ((top)
+ #(ribcage
+ #(syntax-rules)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object syntax-rules ((top)) (hygiene guile))))))
+ (hygiene guile)))
+ (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
+ (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
+ (cons '#(syntax-object x ((top)) (hygiene guile))
+ (cons k
+ (map (lambda (tmp-1 tmp)
+ (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
+ (list '#(syntax-object syntax ((top)) (hygiene guile))
+ tmp-1)))
+ template
+ pattern))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any))))))
+ (if (if tmp
+ (apply (lambda (k docstring keyword pattern template)
+ (string? (syntax->datum docstring)))
+ tmp)
+ #f)
+ (apply (lambda (k docstring keyword pattern template)
+ (list '#(syntax-object lambda ((top)) (hygiene guile))
+ '(#(syntax-object x ((top)) (hygiene guile)))
+ docstring
+ (vector
+ '(#(syntax-object macro-type ((top)) (hygiene guile))
.
#(syntax-object
syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (cons '#(syntax-object
- patterns
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- pattern-35263))
- (cons '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons '#(syntax-object
- x
- ((top)
- #(ribcage
- #(k
- docstring
- keyword
- pattern
- template)
- #((top) (top) (top) (top) (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons k-35260
- (map (lambda (tmp-35238-35265
- tmp-35237-35266)
- (list (cons '#(syntax-object
- _
- ((top)
- #(ribcage
- #(k
- docstring
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene
- guile))))))
- (hygiene
- guile))
- tmp-35237-35266)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(k
- docstring
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35225"
- "l-*-35226"
- "l-*-35227"
- "l-*-35228"
- "l-*-35229"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35199"))
- #(ribcage
- (syntax-rules)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- syntax-rules
- ((top))
- (hygiene
- guile))))))
- (hygiene
- guile))
- tmp-35238-35265)))
- template-35264
- pattern-35263))))))
- tmp-35251)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-35239))))))))
+ ((top)
+ #(ribcage
+ #(syntax-rules)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object syntax-rules ((top)) (hygiene guile))))))
+ (hygiene guile)))
+ (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
+ (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
+ (cons '#(syntax-object x ((top)) (hygiene guile))
+ (cons k
+ (map (lambda (tmp-1 tmp)
+ (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
+ (list '#(syntax-object syntax ((top)) (hygiene guile))
+ tmp-1)))
+ template
+ pattern))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
(define define-syntax-rule
(make-syntax-transformer
'define-syntax-rule
'macro
- (lambda (x-35304)
- (let ((tmp-35306
- ($sc-dispatch x-35304 '(_ (any . any) any))))
- (if tmp-35306
- (@apply
- (lambda (name-35310 pattern-35311 template-35312)
- (list '#(syntax-object
- define-syntax
- ((top)
- #(ribcage
- #(name pattern template)
- #((top) (top) (top))
- #("l-*-35281" "l-*-35282" "l-*-35283"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35278"))
- #(ribcage
- (define-syntax-rule)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define-syntax-rule
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- name-35310
- (list '#(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(name pattern template)
- #((top) (top) (top))
- #("l-*-35281" "l-*-35282" "l-*-35283"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35278"))
- #(ribcage
- (define-syntax-rule)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define-syntax-rule
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '()
- (list (cons '#(syntax-object
- _
- ((top)
- #(ribcage
- #(name pattern template)
- #((top) (top) (top))
- #("l-*-35281"
- "l-*-35282"
- "l-*-35283"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35278"))
- #(ribcage
- (define-syntax-rule)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define-syntax-rule
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- pattern-35311)
- template-35312))))
- tmp-35306)
- (let ((tmp-35313
- ($sc-dispatch x-35304 '(_ (any . any) any any))))
- (if (if tmp-35313
- (@apply
- (lambda (name-35317
- pattern-35318
- docstring-35319
- template-35320)
- (string? (syntax->datum docstring-35319)))
- tmp-35313)
- #f)
- (@apply
- (lambda (name-35321
- pattern-35322
- docstring-35323
- template-35324)
- (list '#(syntax-object
- define-syntax
- ((top)
- #(ribcage
- #(name pattern docstring template)
- #((top) (top) (top) (top))
- #("l-*-35296"
- "l-*-35297"
- "l-*-35298"
- "l-*-35299"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35278"))
- #(ribcage
- (define-syntax-rule)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define-syntax-rule
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- name-35321
- (list '#(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(name pattern docstring template)
- #((top) (top) (top) (top))
- #("l-*-35296"
- "l-*-35297"
- "l-*-35298"
- "l-*-35299"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35278"))
- #(ribcage
- (define-syntax-rule)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define-syntax-rule
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '()
- docstring-35323
- (list (cons '#(syntax-object
- _
- ((top)
- #(ribcage
- #(name
- pattern
- docstring
- template)
- #((top) (top) (top) (top))
- #("l-*-35296"
- "l-*-35297"
- "l-*-35298"
- "l-*-35299"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35278"))
- #(ribcage
- (define-syntax-rule)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define-syntax-rule
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- pattern-35322)
- template-35324))))
- tmp-35313)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-35304))))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
+ (if tmp
+ (apply (lambda (name pattern template)
+ (list '#(syntax-object define-syntax ((top)) (hygiene guile))
+ name
+ (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
+ '()
+ (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
+ template))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
+ (if (if tmp
+ (apply (lambda (name pattern docstring template)
+ (string? (syntax->datum docstring)))
+ tmp)
+ #f)
+ (apply (lambda (name pattern docstring template)
+ (list '#(syntax-object define-syntax ((top)) (hygiene guile))
+ name
+ (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
+ '()
+ docstring
+ (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
+ template))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
(define let*
(make-syntax-transformer
'let*
'macro
- (lambda (x-35374)
- (let ((tmp-35376
- ($sc-dispatch
- x-35374
- '(any #(each (any any)) any . each-any))))
- (if (if tmp-35376
- (@apply
- (lambda (let*-35380 x-35381 v-35382 e1-35383 e2-35384)
- (and-map identifier? x-35381))
- tmp-35376)
- #f)
- (@apply
- (lambda (let*-35385 x-35386 v-35387 e1-35388 e2-35389)
- (letrec*
- ((f-35390
- (lambda (bindings-35393)
- (if (null? bindings-35393)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(f bindings)
- #((top) (top))
- #("l-*-35360" "l-*-35361"))
- #(ribcage
- #(let* x v e1 e2)
- #((top) (top) (top) (top) (top))
- #("l-*-35350"
- "l-*-35351"
- "l-*-35352"
- "l-*-35353"
- "l-*-35354"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35336"))
- #(ribcage
- (let*)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- let*
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons '() (cons e1-35388 e2-35389)))
- (let ((tmp-35394
- (list (f-35390 (cdr bindings-35393))
- (car bindings-35393))))
- (let ((tmp-35395 ($sc-dispatch tmp-35394 '(any any))))
- (if tmp-35395
- (@apply
- (lambda (body-35397 binding-35398)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(body binding)
- #((top) (top))
- #("l-*-35370" "l-*-35371"))
- #(ribcage () () ())
- #(ribcage
- #(f bindings)
- #((top) (top))
- #("l-*-35360" "l-*-35361"))
- #(ribcage
- #(let* x v e1 e2)
- #((top) (top) (top) (top) (top))
- #("l-*-35350"
- "l-*-35351"
- "l-*-35352"
- "l-*-35353"
- "l-*-35354"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35336"))
- #(ribcage
- (let*)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- let*
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (list binding-35398)
- body-35397))
- tmp-35395)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-35394))))))))
- (f-35390 (map list x-35386 v-35387))))
- tmp-35376)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-35374))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any))))
+ (if (if tmp
+ (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp)
+ #f)
+ (apply (lambda (let* x v e1 e2)
+ (let f ((bindings (map list x v)))
+ (if (null? bindings)
+ (cons '#(syntax-object let ((top)) (hygiene guile))
+ (cons '() (cons e1 e2)))
+ (let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (body binding)
+ (list '#(syntax-object let ((top)) (hygiene guile))
+ (list binding)
+ body))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
(define do
(make-syntax-transformer
'do
'macro
- (lambda (orig-x-35457)
- (let ((tmp-35459
- ($sc-dispatch
- orig-x-35457
- '(_ #(each (any any . any))
- (any . each-any)
- .
- each-any))))
- (if tmp-35459
- (@apply
- (lambda (var-35463
- init-35464
- step-35465
- e0-35466
- e1-35467
- c-35468)
- (let ((tmp-35469
- (map (lambda (v-35472 s-35473)
- (let ((tmp-35475 ($sc-dispatch s-35473 '())))
- (if tmp-35475
- (@apply (lambda () v-35472) tmp-35475)
- (let ((tmp-35478
- ($sc-dispatch s-35473 '(any))))
- (if tmp-35478
- (@apply
- (lambda (e-35481) e-35481)
- tmp-35478)
- (syntax-violation
- 'do
- "bad step expression"
- orig-x-35457
- s-35473))))))
- var-35463
- step-35465)))
- (let ((tmp-35470 ($sc-dispatch tmp-35469 'each-any)))
- (if tmp-35470
- (@apply
- (lambda (step-35487)
- (let ((tmp-35489 ($sc-dispatch e1-35467 '())))
- (if tmp-35489
- (@apply
- (lambda ()
- (list '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (map list var-35463 init-35464)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (list '#(syntax-object
- not
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- e0-35466)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- (append
- c-35468
- (list (cons '#(syntax-object
- doloop
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene
- guile))))))
- (hygiene
- guile))
- step-35487)))))))
- tmp-35489)
- (let ((tmp-35493
- ($sc-dispatch e1-35467 '(any . each-any))))
- (if tmp-35493
- (@apply
- (lambda (e1-35497 e2-35498)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-35434" "l-*-35435"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-35434" "l-*-35435"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (map list var-35463 init-35464)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-35434"
- "l-*-35435"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- e0-35466
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-35434"
- "l-*-35435"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- (cons e1-35497 e2-35498))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-35434"
- "l-*-35435"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- (append
- c-35468
- (list (cons '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("l-*-35434"
- "l-*-35435"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-35425"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-35410"
- "l-*-35411"
- "l-*-35412"
- "l-*-35413"
- "l-*-35414"
- "l-*-35415"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-35407"))
- #(ribcage
- (do)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- do
- ((top))
- (hygiene
- guile))))))
- (hygiene
- guile))
- step-35487)))))))
- tmp-35493)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e1-35467))))))
- tmp-35470)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-35469)))))
- tmp-35459)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- orig-x-35457))))))
+ (lambda (orig-x)
+ (let ((tmp-1 orig-x))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(_ #(each (any any . any)) (any . each-any) . each-any))))
+ (if tmp
+ (apply (lambda (var init step e0 e1 c)
+ (let ((tmp-1 (map (lambda (v s)
+ (let ((tmp-1 s))
+ (let ((tmp ($sc-dispatch tmp-1 '())))
+ (if tmp
+ (apply (lambda () v) tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(any))))
+ (if tmp
+ (apply (lambda (e) e) tmp)
+ (syntax-violation 'do "bad step expression" orig-x s)))))))
+ var
+ step)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (step)
+ (let ((tmp e1))
+ (let ((tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda ()
+ (list '#(syntax-object let ((top)) (hygiene guile))
+ '#(syntax-object doloop ((top)) (hygiene guile))
+ (map list var init)
+ (list '#(syntax-object if ((top)) (hygiene guile))
+ (list '#(syntax-object not ((top)) (hygiene guile)) e0)
+ (cons '#(syntax-object begin ((top)) (hygiene guile))
+ (append
+ c
+ (list (cons '#(syntax-object
+ doloop
+ ((top))
+ (hygiene guile))
+ step)))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2)
+ (list '#(syntax-object let ((top)) (hygiene guile))
+ '#(syntax-object doloop ((top)) (hygiene guile))
+ (map list var init)
+ (list '#(syntax-object if ((top)) (hygiene guile))
+ e0
+ (cons '#(syntax-object begin ((top)) (hygiene guile))
+ (cons e1 e2))
+ (cons '#(syntax-object begin ((top)) (hygiene guile))
+ (append
+ c
+ (list (cons '#(syntax-object
+ doloop
+ ((top))
+ (hygiene guile))
+ step)))))))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp)))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
(define quasiquote
(make-syntax-transformer
'quasiquote
'macro
(letrec*
- ((quasi-35779
- (lambda (p-35803 lev-35804)
- (let ((tmp-35806
- ($sc-dispatch
- p-35803
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- any))))
- (if tmp-35806
- (@apply
- (lambda (p-35810)
- (if (= lev-35804 0)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-35535"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- p-35810)
- (quasicons-35781
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-35535"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- unquote
- ((top)
- #(ribcage #(p) #((top)) #("l-*-35535"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (quasi-35779 (list p-35810) (#{1-}# lev-35804)))))
- tmp-35806)
- (let ((tmp-35813
- ($sc-dispatch
- p-35803
- '(#(free-id
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- any))))
- (if tmp-35813
- (@apply
- (lambda (p-35817)
- (quasicons-35781
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-35538"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage #(p) #((top)) #("l-*-35538"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (quasi-35779 (list p-35817) (#{1+}# lev-35804))))
- tmp-35813)
- (let ((tmp-35820 ($sc-dispatch p-35803 '(any . any))))
- (if tmp-35820
- (@apply
- (lambda (p-35824 q-35825)
- (let ((tmp-35827
- ($sc-dispatch
- p-35824
+ ((quasi (lambda (p lev)
+ (let ((tmp p))
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any))))
+ (if tmp-1
+ (apply (lambda (p)
+ (if (= lev 0)
+ (list "value" p)
+ (quasicons
+ '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
+ (quasi (list p) (- lev 1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
'(#(free-id
#(syntax-object
- unquote
+ quasiquote
((top)
#(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35541" "l-*-35542"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
+ #(quasiquote)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object quasiquote ((top)) (hygiene guile))))))
(hygiene guile)))
- .
- each-any))))
- (if tmp-35827
- (@apply
- (lambda (p-35831)
- (if (= lev-35804 0)
- (quasilist*-35783
- (map (lambda (tmp-35549-35870)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35547"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35541"
- "l-*-35542"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531"
- "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- tmp-35549-35870))
- p-35831)
- (quasi-35779 q-35825 lev-35804))
- (quasicons-35781
- (quasicons-35781
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35547"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35541" "l-*-35542"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- unquote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35547"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35541" "l-*-35542"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (quasi-35779
- p-35831
- (#{1-}# lev-35804)))
- (quasi-35779 q-35825 lev-35804))))
- tmp-35827)
- (let ((tmp-35875
- ($sc-dispatch
- p-35824
- '(#(free-id
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35541" "l-*-35542"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- .
- each-any))))
- (if tmp-35875
- (@apply
- (lambda (p-35879)
- (if (= lev-35804 0)
- (quasiappend-35782
- (map (lambda (tmp-35554-35882)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35552"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35541"
- "l-*-35542"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531"
- "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- tmp-35554-35882))
- p-35879)
- (quasi-35779 q-35825 lev-35804))
- (quasicons-35781
- (quasicons-35781
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35552"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35541" "l-*-35542"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35552"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35541" "l-*-35542"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (quasi-35779
- p-35879
- (#{1-}# lev-35804)))
- (quasi-35779 q-35825 lev-35804))))
- tmp-35875)
- (quasicons-35781
- (quasi-35779 p-35824 lev-35804)
- (quasi-35779 q-35825 lev-35804)))))))
- tmp-35820)
- (let ((tmp-35896
- ($sc-dispatch p-35803 '#(vector each-any))))
- (if tmp-35896
- (@apply
- (lambda (x-35900)
- (let ((x-35903
- (vquasi-35780 x-35900 lev-35804)))
- (let ((tmp-35905
- ($sc-dispatch
- x-35903
- '(#(atom "quote") each-any))))
- (if tmp-35905
- (@apply
- (lambda (x-35909)
- (list '#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(x)
- #((top))
- #("l-*-35653"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35650"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (list->vector x-35909)))
- tmp-35905)
- (letrec*
- ((f-35911
- (lambda (y-35923 k-35924)
- (let ((tmp-35926
- ($sc-dispatch
- y-35923
- '(#(atom "quote")
- each-any))))
- (if tmp-35926
- (@apply
- (lambda (y-35929)
- (k-35924
- (map (lambda (tmp-35678-35930)
- (list '#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(y)
- #((top))
- #("l-*-35676"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- y
- k)
- #((top)
- (top)
- (top))
- #("l-*-35658"
- "l-*-35659"
- "l-*-35660"))
- #(ribcage
- #(_)
- #((top))
- #("l-*-35656"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35650"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene
- guile))))))
- (hygiene
- guile))
- tmp-35678-35930))
- y-35929)))
- tmp-35926)
- (let ((tmp-35931
- ($sc-dispatch
- y-35923
- '(#(atom "list")
- .
- each-any))))
- (if tmp-35931
- (@apply
- (lambda (y-35934)
- (k-35924 y-35934))
- tmp-35931)
- (let ((tmp-35935
- ($sc-dispatch
- y-35923
- '(#(atom "list*")
- .
- #(each+
- any
- (any)
- ())))))
- (if tmp-35935
- (@apply
- (lambda (y-35938
- z-35939)
- (f-35911
- z-35939
- (lambda (ls-35940)
- (k-35924
- (append
- y-35938
- ls-35940)))))
- tmp-35935)
- (list '#(syntax-object
- "list->vector"
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(t-35693)
- #((m-*-35694
- top))
- #("l-*-35697"))
- #(ribcage
- #(else)
- #((top))
- #("l-*-35691"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f y k)
- #((top)
- (top)
- (top))
- #("l-*-35658"
- "l-*-35659"
- "l-*-35660"))
- #(ribcage
- #(_)
- #((top))
- #("l-*-35656"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35650"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene
- guile))))))
- (hygiene
- guile))
- x-35903))))))))))
- (f-35911
- x-35903
- (lambda (ls-35913)
- (let ((tmp-35915
- ($sc-dispatch
- ls-35913
- 'each-any)))
- (if tmp-35915
- (@apply
- (lambda (t-35666-35918)
- (cons '#(syntax-object
- "vector"
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(t-35666)
- #((m-*-35667
- top))
- #("l-*-35671"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(ls)
- #((top))
- #("l-*-35665"))
- #(ribcage
- #(_)
- #((top))
- #("l-*-35656"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35650"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- t-35666-35918))
- tmp-35915)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- ls-35913))))))))))
- tmp-35896)
- (list '#(syntax-object
- "quote"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-35562"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35531" "l-*-35532"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- p-35803)))))))))))
- (vquasi-35780
- (lambda (p-35968 lev-35969)
- (let ((tmp-35971 ($sc-dispatch p-35968 '(any . any))))
- (if tmp-35971
- (@apply
- (lambda (p-35975 q-35976)
- (let ((tmp-35978
- ($sc-dispatch
- p-35975
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35570" "l-*-35571"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566" "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- .
- each-any))))
- (if tmp-35978
- (@apply
- (lambda (p-35982)
- (if (= lev-35969 0)
- (quasilist*-35783
- (map (lambda (tmp-35578-36021)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35576"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35570" "l-*-35571"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566" "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- tmp-35578-36021))
- p-35982)
- (vquasi-35780 q-35976 lev-35969))
- (quasicons-35781
- (quasicons-35781
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-35576"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35570" "l-*-35571"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566" "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- unquote
- ((top)
- #(ribcage #(p) #((top)) #("l-*-35576"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35570" "l-*-35571"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566" "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (quasi-35779 p-35982 (#{1-}# lev-35969)))
- (vquasi-35780 q-35976 lev-35969))))
- tmp-35978)
- (let ((tmp-36028
- ($sc-dispatch
- p-35975
- '(#(free-id
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35570" "l-*-35571"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566" "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- .
- each-any))))
- (if tmp-36028
- (@apply
- (lambda (p-36032)
- (if (= lev-35969 0)
- (quasiappend-35782
- (map (lambda (tmp-35583-36035)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35581"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35570"
- "l-*-35571"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566"
- "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- tmp-35583-36035))
- p-36032)
- (vquasi-35780 q-35976 lev-35969))
- (quasicons-35781
- (quasicons-35781
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-35581"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35570" "l-*-35571"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566" "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
+ any))))
+ (if tmp-1
+ (apply (lambda (p)
+ (quasicons
+ '("quote"
#(syntax-object
- unquote-splicing
+ quasiquote
((top)
#(ribcage
- #(p)
+ #(quasiquote)
#((top))
- #("l-*-35581"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-35570" "l-*-35571"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566" "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (quasi-35779 p-36032 (#{1-}# lev-35969)))
- (vquasi-35780 q-35976 lev-35969))))
- tmp-36028)
- (quasicons-35781
- (quasi-35779 p-35975 lev-35969)
- (vquasi-35780 q-35976 lev-35969)))))))
- tmp-35971)
- (let ((tmp-36053 ($sc-dispatch p-35968 '())))
- (if tmp-36053
- (@apply
- (lambda ()
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-35566" "l-*-35567"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- ()))
- tmp-36053)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- p-35968)))))))
- (quasicons-35781
- (lambda (x-36066 y-36067)
- (let ((tmp-36068 (list x-36066 y-36067)))
- (let ((tmp-36069 ($sc-dispatch tmp-36068 '(any any))))
- (if tmp-36069
- (@apply
- (lambda (x-36071 y-36072)
- (let ((tmp-36074
- ($sc-dispatch y-36072 '(#(atom "quote") any))))
- (if tmp-36074
- (@apply
- (lambda (dy-36078)
- (let ((tmp-36080
- ($sc-dispatch
- x-36071
- '(#(atom "quote") any))))
- (if tmp-36080
- (@apply
- (lambda (dx-36084)
- (list '#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(dx)
- #((top))
- #("l-*-35605"))
- #(ribcage
- #(dy)
- #((top))
- #("l-*-35601"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35595" "l-*-35596"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35590" "l-*-35591"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons dx-36084 dy-36078)))
- tmp-36080)
- (if (null? dy-36078)
- (list '#(syntax-object
- "list"
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("l-*-35607"))
- #(ribcage
- #(dy)
- #((top))
- #("l-*-35601"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35595" "l-*-35596"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35590" "l-*-35591"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- x-36071)
- (list '#(syntax-object
- "list*"
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("l-*-35607"))
- #(ribcage
- #(dy)
- #((top))
- #("l-*-35601"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35595" "l-*-35596"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35590" "l-*-35591"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- x-36071
- y-36072)))))
- tmp-36074)
- (let ((tmp-36089
- ($sc-dispatch
- y-36072
- '(#(atom "list") . any))))
- (if tmp-36089
- (@apply
- (lambda (stuff-36093)
- (cons '#(syntax-object
- "list"
- ((top)
- #(ribcage
- #(stuff)
- #((top))
- #("l-*-35610"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35595" "l-*-35596"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35590" "l-*-35591"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
+ #(((hygiene guile)
.
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons x-36071 stuff-36093)))
- tmp-36089)
- (let ((tmp-36094
- ($sc-dispatch
- y-36072
- '(#(atom "list*") . any))))
- (if tmp-36094
- (@apply
- (lambda (stuff-36098)
- (cons '#(syntax-object
- "list*"
- ((top)
- #(ribcage
- #(stuff)
- #((top))
- #("l-*-35613"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35595" "l-*-35596"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35590" "l-*-35591"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons x-36071 stuff-36098)))
- tmp-36094)
- (list '#(syntax-object
- "list*"
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("l-*-35615"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35595" "l-*-35596"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35590" "l-*-35591"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
+ #(syntax-object quasiquote ((top)) (hygiene guile))))))
+ (hygiene guile)))
+ (quasi (list p) (+ lev 1))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (p q)
+ (let ((tmp-1 p))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
+ .
+ each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasilist*
+ (map (lambda (tmp) (list "value" tmp)) p)
+ (quasi q lev))
+ (quasicons
+ (quasicons
+ '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
+ (quasi p (- lev 1)))
+ (quasi q lev))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id
+ #(syntax-object unquote-splicing ((top)) (hygiene guile)))
+ .
+ each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasiappend
+ (map (lambda (tmp) (list "value" tmp)) p)
+ (quasi q lev))
+ (quasicons
+ (quasicons
+ '("quote"
+ #(syntax-object
+ unquote-splicing
+ ((top))
+ (hygiene guile)))
+ (quasi p (- lev 1)))
+ (quasi q lev))))
+ tmp)
+ (quasicons (quasi p lev) (quasi q lev))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
+ (if tmp-1
+ (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1)
+ (let ((p tmp)) (list "quote" p)))))))))))))
+ (vquasi
+ (lambda (p lev)
+ (let ((tmp p))
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (p q)
+ (let ((tmp-1 p))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
+ .
+ each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev))
+ (quasicons
+ (quasicons
+ '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
+ (quasi p (- lev 1)))
+ (vquasi q lev))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile)))
.
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- x-36071
- y-36072))))))))
- tmp-36069)
+ each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasiappend
+ (map (lambda (tmp) (list "value" tmp)) p)
+ (vquasi q lev))
+ (quasicons
+ (quasicons
+ '("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile)))
+ (quasi p (- lev 1)))
+ (vquasi q lev))))
+ tmp)
+ (quasicons (quasi p lev) (vquasi q lev))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () '("quote" ())) tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))
+ (quasicons
+ (lambda (x y)
+ (let ((tmp-1 (list x y)))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (x y)
+ (let ((tmp y))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
+ (if tmp-1
+ (apply (lambda (dy)
+ (let ((tmp x))
+ (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any))))
+ (if tmp
+ (apply (lambda (dx) (list "quote" (cons dx dy))) tmp)
+ (if (null? dy) (list "list" x) (list "list*" x y))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any))))
+ (if tmp-1
+ (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1)
+ (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any))))
+ (if tmp
+ (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp)
+ (list "list*" x y)))))))))
+ tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-36068))))))
- (quasiappend-35782
- (lambda (x-36109 y-36110)
- (let ((tmp-36112
- ($sc-dispatch y-36110 '(#(atom "quote") ()))))
- (if tmp-36112
- (@apply
- (lambda ()
- (if (null? x-36109)
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35619" "l-*-35620"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- ())
- (if (null? (cdr x-36109))
- (car x-36109)
- (let ((tmp-36117 ($sc-dispatch x-36109 'each-any)))
- (if tmp-36117
- (@apply
- (lambda (p-36121)
- (cons '#(syntax-object
- "append"
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p)
- #((top))
- #("l-*-35627"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35619" "l-*-35620"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- p-36121))
- tmp-36117)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-36109))))))
- tmp-36112)
- (if (null? x-36109)
- y-36110
- (let ((tmp-36129 (list x-36109 y-36110)))
- (let ((tmp-36130
- ($sc-dispatch tmp-36129 '(each-any any))))
- (if tmp-36130
- (@apply
- (lambda (p-36132 y-36133)
- (cons '#(syntax-object
- "append"
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p y)
- #((top) (top))
- #("l-*-35636" "l-*-35637"))
- #(ribcage #(_) #((top)) #("l-*-35630"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35619" "l-*-35620"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (append p-36132 (list y-36133))))
- tmp-36130)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-36129)))))))))
- (quasilist*-35783
- (lambda (x-36137 y-36138)
- (letrec*
- ((f-36139
- (lambda (x-36243)
- (if (null? x-36243)
- y-36138
- (quasicons-35781
- (car x-36243)
- (f-36139 (cdr x-36243)))))))
- (f-36139 x-36137))))
- (emit-35785
- (lambda (x-36246)
- (let ((tmp-36248
- ($sc-dispatch x-36246 '(#(atom "quote") any))))
- (if tmp-36248
- (@apply
- (lambda (x-36252)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage #(x) #((top)) #("l-*-35703"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-35700"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- x-36252))
- tmp-36248)
- (let ((tmp-36253
- ($sc-dispatch
- x-36246
- '(#(atom "list") . each-any))))
- (if tmp-36253
- (@apply
- (lambda (x-36257)
- (let ((tmp-36258 (map emit-35785 x-36257)))
- (let ((tmp-36259 ($sc-dispatch tmp-36258 'each-any)))
- (if tmp-36259
- (@apply
- (lambda (t-35708-36261)
- (cons '#(syntax-object
- list
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-35708)
- #((m-*-35709 top))
- #("l-*-35713"))
- #(ribcage
- #(x)
- #((top))
- #("l-*-35706"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35700"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- t-35708-36261))
- tmp-36259)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-36258)))))
- tmp-36253)
- (let ((tmp-36262
- ($sc-dispatch
- x-36246
- '(#(atom "list*") . #(each+ any (any) ())))))
- (if tmp-36262
- (@apply
- (lambda (x-36266 y-36267)
- (letrec*
- ((f-36268
- (lambda (x*-36271)
- (if (null? x*-36271)
- (emit-35785 y-36267)
- (let ((tmp-36272
- (list (emit-35785 (car x*-36271))
- (f-36268 (cdr x*-36271)))))
- (let ((tmp-36273
- ($sc-dispatch
- tmp-36272
- '(any any))))
- (if tmp-36273
- (@apply
- (lambda (t-35728-36275
- t-35727-36276)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-35728 t-35727)
- #((m-*-35729 top)
- (m-*-35729 top))
- #("l-*-35733"
- "l-*-35734"))
- #(ribcage () () ())
- #(ribcage
- #(f x*)
- #((top) (top))
- #("l-*-35722"
- "l-*-35723"))
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-35718"
- "l-*-35719"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35700"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- t-35728-36275
- t-35727-36276))
- tmp-36273)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-36272))))))))
- (f-36268 x-36266)))
- tmp-36262)
- (let ((tmp-36277
- ($sc-dispatch
- x-36246
- '(#(atom "append") . each-any))))
- (if tmp-36277
- (@apply
- (lambda (x-36281)
- (let ((tmp-36282 (map emit-35785 x-36281)))
- (let ((tmp-36283
- ($sc-dispatch tmp-36282 'each-any)))
- (if tmp-36283
- (@apply
- (lambda (t-35740-36285)
- (cons '#(syntax-object
- append
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-35740)
- #((m-*-35741 top))
- #("l-*-35745"))
- #(ribcage
- #(x)
- #((top))
- #("l-*-35738"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35700"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- t-35740-36285))
- tmp-36283)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-36282)))))
- tmp-36277)
- (let ((tmp-36286
- ($sc-dispatch
- x-36246
- '(#(atom "vector") . each-any))))
- (if tmp-36286
- (@apply
- (lambda (x-36290)
- (let ((tmp-36291 (map emit-35785 x-36290)))
- (let ((tmp-36292
- ($sc-dispatch
- tmp-36291
- 'each-any)))
- (if tmp-36292
- (@apply
- (lambda (t-35752-36294)
- (cons '#(syntax-object
- vector
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-35752)
- #((m-*-35753 top))
- #("l-*-35757"))
- #(ribcage
- #(x)
- #((top))
- #("l-*-35750"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35700"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- t-35752-36294))
- tmp-36292)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-36291)))))
- tmp-36286)
- (let ((tmp-36295
- ($sc-dispatch
- x-36246
- '(#(atom "list->vector") any))))
- (if tmp-36295
- (@apply
- (lambda (x-36299)
- (let ((tmp-36300 (emit-35785 x-36299)))
- (list '#(syntax-object
- list->vector
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-35764)
- #((m-*-35765 top))
- #("l-*-35768"))
- #(ribcage
- #(x)
- #((top))
- #("l-*-35762"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-35700"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-35527"
- "l-*-35525"
- "l-*-35523"
- "l-*-35521"
- "l-*-35519"
- "l-*-35517"
- "l-*-35515"))
- #(ribcage
- (quasiquote)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- quasiquote
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- tmp-36300)))
- tmp-36295)
- (let ((tmp-36303
- ($sc-dispatch
- x-36246
- '(#(atom "value") any))))
- (if tmp-36303
- (@apply
- (lambda (x-36307) x-36307)
- tmp-36303)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-36246))))))))))))))))))
- (lambda (x-35786)
- (let ((tmp-35788 ($sc-dispatch x-35786 '(_ any))))
- (if tmp-35788
- (@apply
- (lambda (e-35792)
- (emit-35785 (quasi-35779 e-35792 0)))
- tmp-35788)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-35786)))))))
+ tmp-1))))))
+ (quasiappend
+ (lambda (x y)
+ (let ((tmp y))
+ (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ()))))
+ (if tmp
+ (apply (lambda ()
+ (if (null? x)
+ '("quote" ())
+ (if (null? (cdr x))
+ (car x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (p) (cons "append" p)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ tmp)
+ (if (null? x)
+ y
+ (let ((tmp-1 (list x y)))
+ (let ((tmp ($sc-dispatch tmp-1 '(each-any any))))
+ (if tmp
+ (apply (lambda (p y) (cons "append" (append p (list y)))) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))))
+ (quasilist*
+ (lambda (x y)
+ (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x)))))))
+ (quasivector
+ (lambda (x)
+ (let ((tmp x))
+ (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any))))
+ (if tmp
+ (apply (lambda (x) (list "quote" (list->vector x))) tmp)
+ (let f ((y x)
+ (k (lambda (ls)
+ (let ((tmp-1 ls))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t) (cons "vector" t)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ (let ((tmp y))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
+ (if tmp-1
+ (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
+ (if tmp-1
+ (apply (lambda (y) (k y)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
+ (if tmp-1
+ (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
+ (let ((else tmp))
+ (let ((tmp x)) (let ((t tmp)) (list "list->vector" t)))))))))))))))))
+ (emit (lambda (x)
+ (let ((tmp x))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
+ (if tmp-1
+ (apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
+ (if tmp-1
+ (apply (lambda (x y)
+ (let f ((x* x))
+ (if (null? x*)
+ (emit y)
+ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (t-1 t)
+ (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t)
+ (cons '#(syntax-object append ((top)) (hygiene guile)) t))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t)
+ (cons '#(syntax-object vector ((top)) (hygiene guile)) t))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp (emit x)))
+ (let ((t tmp))
+ (list '#(syntax-object list->vector ((top)) (hygiene guile)) t))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
+ (if tmp-1
+ (apply (lambda (x) x) tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp)))))))))))))))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+ (if tmp
+ (apply (lambda (e) (emit (quasi e 0))) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
(define include
(make-syntax-transformer
'include
'macro
- (lambda (x-36363)
+ (lambda (x)
(letrec*
- ((read-file-36364
- (lambda (fn-36473 k-36474)
- (let ((p-36475 (open-input-file fn-36473)))
- (letrec*
- ((f-36476
- (lambda (x-36530 result-36531)
- (if (eof-object? x-36530)
- (begin
- (close-input-port p-36475)
- (reverse result-36531))
- (f-36476
- (read p-36475)
- (cons (datum->syntax k-36474 x-36530)
- result-36531))))))
- (f-36476 (read p-36475) '()))))))
- (let ((tmp-36366 ($sc-dispatch x-36363 '(any any))))
- (if tmp-36366
- (@apply
- (lambda (k-36370 filename-36371)
- (let ((fn-36372 (syntax->datum filename-36371)))
- (let ((tmp-36373
- (read-file-36364 fn-36372 filename-36371)))
- (let ((tmp-36374 ($sc-dispatch tmp-36373 'each-any)))
- (if tmp-36374
- (@apply
- (lambda (exp-36392)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage () () ())
- #(ribcage #(exp) #((top)) #("l-*-36360"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-36355"))
- #(ribcage
- #(k filename)
- #((top) (top))
- #("l-*-36351" "l-*-36352"))
- #(ribcage
- (read-file)
- ((top))
- ("l-*-36335"))
- #(ribcage #(x) #((top)) #("l-*-36334"))
- #(ribcage
- (include)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- include
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- exp-36392))
- tmp-36374)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-36373))))))
- tmp-36366)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-36363)))))))
+ ((read-file
+ (lambda (fn k)
+ (let ((p (open-input-file fn)))
+ (let f ((x (read p)) (result '()))
+ (if (eof-object? x)
+ (begin (close-input-port p) (reverse result))
+ (f (read p) (cons (datum->syntax k x) result))))))))
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (k filename)
+ (let ((fn (syntax->datum filename)))
+ (let ((tmp-1 (read-file fn filename)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (exp)
+ (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
(define include-from-path
(make-syntax-transformer
'include-from-path
'macro
- (lambda (x-36551)
- (let ((tmp-36553 ($sc-dispatch x-36551 '(any any))))
- (if tmp-36553
- (@apply
- (lambda (k-36557 filename-36558)
- (let ((fn-36559 (syntax->datum filename-36558)))
- (let ((tmp-36560
- (datum->syntax
- filename-36558
- (let ((t-36563 (%search-load-path fn-36559)))
- (if t-36563
- t-36563
- (syntax-violation
- 'include-from-path
- "file not found in path"
- x-36551
- filename-36558))))))
- (list '#(syntax-object
- include
- ((top)
- #(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-36545"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-36541"))
- #(ribcage
- #(k filename)
- #((top) (top))
- #("l-*-36537" "l-*-36538"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36534"))
- #(ribcage
- (include-from-path)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- include-from-path
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- tmp-36560))))
- tmp-36553)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-36551))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (k filename)
+ (let ((fn (syntax->datum filename)))
+ (let ((tmp (datum->syntax
+ filename
+ (let ((t (%search-load-path fn)))
+ (if t
+ t
+ (syntax-violation
+ 'include-from-path
+ "file not found in path"
+ x
+ filename))))))
+ (let ((fn tmp))
+ (list '#(syntax-object include ((top)) (hygiene guile)) fn)))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
(define unquote
(make-syntax-transformer
'unquote
'macro
- (lambda (x-36573)
+ (lambda (x)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- x-36573))))
+ x))))
(define unquote-splicing
(make-syntax-transformer
'unquote-splicing
'macro
- (lambda (x-36577)
+ (lambda (x)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- x-36577))))
+ x))))
(define case
(make-syntax-transformer
'case
'macro
- (lambda (x-36634)
- (let ((tmp-36636
- ($sc-dispatch x-36634 '(_ any any . each-any))))
- (if tmp-36636
- (@apply
- (lambda (e-36640 m1-36641 m2-36642)
- (let ((tmp-36643
- (letrec*
- ((f-36697
- (lambda (clause-36700 clauses-36701)
- (if (null? clauses-36701)
- (let ((tmp-36703
- ($sc-dispatch
- clause-36700
- '(#(free-id
- #(syntax-object
- else
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- any
- .
- each-any))))
- (if tmp-36703
- (@apply
- (lambda (e1-36707 e2-36708)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-36602" "l-*-36603"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any any . each-any))))
+ (if tmp
+ (apply (lambda (e m1 m2)
+ (let ((tmp (let f ((clause m1) (clauses m2))
+ (if (null? clauses)
+ (let ((tmp-1 clause))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id #(syntax-object else ((top)) (hygiene guile)))
+ any
.
- #(syntax-object
- case
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons e1-36707 e2-36708)))
- tmp-36703)
- (let ((tmp-36709
- ($sc-dispatch
- clause-36700
- '(each-any any . each-any))))
- (if tmp-36709
- (@apply
- (lambda (k-36713 e1-36714 e2-36715)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-36608"
- "l-*-36609"
- "l-*-36610"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-36608"
- "l-*-36609"
- "l-*-36610"))
- #(ribcage () () ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-36608"
- "l-*-36609"
- "l-*-36610"))
- #(ribcage () () ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-36608"
- "l-*-36609"
- "l-*-36610"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene
- guile))))))
- (hygiene
- guile))
- k-36713))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-36608"
- "l-*-36609"
- "l-*-36610"))
- #(ribcage () () ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- (cons e1-36714
- e2-36715))))
- tmp-36709)
- (syntax-violation
- 'case
- "bad clause"
- x-36634
- clause-36700)))))
- (let ((tmp-36723
- (f-36697
- (car clauses-36701)
- (cdr clauses-36701))))
- (let ((tmp-36726
- ($sc-dispatch
- clause-36700
- '(each-any any . each-any))))
- (if tmp-36726
- (@apply
- (lambda (k-36730 e1-36731 e2-36732)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-36624"
- "l-*-36625"
- "l-*-36626"))
- #(ribcage () () ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-36620"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-36624"
- "l-*-36625"
- "l-*-36626"))
- #(ribcage () () ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-36620"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-36624"
- "l-*-36625"
- "l-*-36626"))
- #(ribcage () () ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-36620"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-36624"
- "l-*-36625"
- "l-*-36626"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-36620"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene
- guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- k-36730))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-36624"
- "l-*-36625"
- "l-*-36626"))
- #(ribcage () () ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-36620"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-36593"
- "l-*-36594"
- "l-*-36595"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- (cons e1-36731 e2-36732))
- tmp-36723))
- tmp-36726)
- (syntax-violation
- 'case
- "bad clause"
- x-36634
- clause-36700))))))))
- (f-36697 m1-36641 m2-36642))))
- (let ((body-36644 tmp-36643))
- (list '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage #(body) #((top)) #("l-*-36591"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583" "l-*-36584" "l-*-36585"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(body)
- #((top))
- #("l-*-36591"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-36583"
- "l-*-36584"
- "l-*-36585"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36580"))
- #(ribcage
- (case)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- case
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- e-36640))
- body-36644))))
- tmp-36636)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-36634))))))
+ each-any))))
+ (if tmp
+ (apply (lambda (e1 e2)
+ (cons '#(syntax-object begin ((top)) (hygiene guile)) (cons e1 e2)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(each-any any . each-any))))
+ (if tmp
+ (apply (lambda (k e1 e2)
+ (list '#(syntax-object if ((top)) (hygiene guile))
+ (list '#(syntax-object memv ((top)) (hygiene guile))
+ '#(syntax-object t ((top)) (hygiene guile))
+ (list '#(syntax-object quote ((top)) (hygiene guile))
+ k))
+ (cons '#(syntax-object begin ((top)) (hygiene guile))
+ (cons e1 e2))))
+ tmp)
+ (syntax-violation 'case "bad clause" x clause))))))
+ (let ((tmp (f (car clauses) (cdr clauses))))
+ (let ((rest tmp))
+ (let ((tmp clause))
+ (let ((tmp ($sc-dispatch tmp '(each-any any . each-any))))
+ (if tmp
+ (apply (lambda (k e1 e2)
+ (list '#(syntax-object if ((top)) (hygiene guile))
+ (list '#(syntax-object memv ((top)) (hygiene guile))
+ '#(syntax-object t ((top)) (hygiene guile))
+ (list '#(syntax-object quote ((top)) (hygiene guile))
+ k))
+ (cons '#(syntax-object begin ((top)) (hygiene guile))
+ (cons e1 e2))
+ rest))
+ tmp)
+ (syntax-violation 'case "bad clause" x clause))))))))))
+ (let ((body tmp))
+ (list '#(syntax-object let ((top)) (hygiene guile))
+ (list (list '#(syntax-object t ((top)) (hygiene guile)) e))
+ body))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
(define make-variable-transformer
- (lambda (proc-36751)
- (if (procedure? proc-36751)
- (letrec*
- ((trans-36752
- (lambda (x-36754) (proc-36751 x-36754))))
- (begin
- (set-procedure-property!
- trans-36752
- 'variable-transformer
- #t)
- trans-36752))
- (error "variable transformer not a procedure"
- proc-36751))))
+ (lambda (proc)
+ (if (procedure? proc)
+ (let ((trans (lambda (x) (proc x))))
+ (set-procedure-property! trans 'variable-transformer #t)
+ trans)
+ (error "variable transformer not a procedure" proc))))
(define identifier-syntax
(make-syntax-transformer
'identifier-syntax
'macro
- (lambda (x-36791)
- (let ((tmp-36793 ($sc-dispatch x-36791 '(_ any))))
- (if tmp-36793
- (@apply
- (lambda (e-36797)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- '#((#(syntax-object
- macro-type
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
+ (lambda (xx)
+ (let ((tmp-1 xx))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+ (if tmp
+ (apply (lambda (e)
+ (list '#(syntax-object lambda ((top)) (hygiene guile))
+ '(#(syntax-object x ((top)) (hygiene guile)))
+ '#((#(syntax-object macro-type ((top)) (hygiene guile))
.
#(syntax-object
identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- .
- #(syntax-object
- identifier-syntax
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))))
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '#(syntax-object
- x
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '()
- (list '#(syntax-object
- id
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '(#(syntax-object
- identifier?
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (#(syntax-object
- syntax
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- id
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(e)
- #((top))
- #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- e-36797))
- (list '(#(syntax-object
- _
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- x
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage #(e) #((top)) #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(e)
- #((top))
- #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons e-36797
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(e)
- #((top))
- #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(e)
- #((top))
- #("l-*-36766"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile)))))))))
- tmp-36793)
- (let ((tmp-36798
- ($sc-dispatch
- x-36791
- '(_ (any any)
- ((#(free-id
- #(syntax-object
- set!
- ((top)
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- any
- any)
- any)))))
- (if (if tmp-36798
- (@apply
- (lambda (id-36802
- exp1-36803
- var-36804
- val-36805
- exp2-36806)
- (if (identifier? id-36802)
- (identifier? var-36804)
- #f))
- tmp-36798)
- #f)
- (@apply
- (lambda (id-36807
- exp1-36808
- var-36809
- val-36810
- exp2-36811)
- (list '#(syntax-object
- make-variable-transformer
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (list '#(syntax-object
- lambda
((top)
#(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
+ #(identifier-syntax)
+ #((top))
+ #(((hygiene guile)
.
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- '#((#(syntax-object
- macro-type
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- .
- #(syntax-object
- variable-transformer
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
+ #(syntax-object identifier-syntax ((top)) (hygiene guile))))))
+ (hygiene guile))))
+ (list '#(syntax-object syntax-case ((top)) (hygiene guile))
+ '#(syntax-object x ((top)) (hygiene guile))
+ '()
+ (list '#(syntax-object id ((top)) (hygiene guile))
+ '(#(syntax-object identifier? ((top)) (hygiene guile))
+ (#(syntax-object syntax ((top)) (hygiene guile))
+ #(syntax-object id ((top)) (hygiene guile))))
+ (list '#(syntax-object syntax ((top)) (hygiene guile)) e))
+ (list '(#(syntax-object _ ((top)) (hygiene guile))
+ #(syntax-object x ((top)) (hygiene guile))
+ #(syntax-object ... ((top)) (hygiene guile)))
+ (list '#(syntax-object syntax ((top)) (hygiene guile))
+ (cons e
+ '(#(syntax-object x ((top)) (hygiene guile))
+ #(syntax-object ... ((top)) (hygiene guile)))))))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(_ (any any)
+ ((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any)
+ any)))))
+ (if (if tmp
+ (apply (lambda (id exp1 var val exp2)
+ (if (identifier? id) (identifier? var) #f))
+ tmp)
+ #f)
+ (apply (lambda (id exp1 var val exp2)
+ (list '#(syntax-object make-variable-transformer ((top)) (hygiene guile))
+ (list '#(syntax-object lambda ((top)) (hygiene guile))
+ '(#(syntax-object x ((top)) (hygiene guile)))
+ '#((#(syntax-object macro-type ((top)) (hygiene guile))
.
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))))
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '#(syntax-object
- x
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- '(#(syntax-object
- set!
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile)))
- (list (list '#(syntax-object
- set!
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- var-36809
- val-36810)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- exp2-36811))
- (list (cons id-36807
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons exp1-36808
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))))))
- (list id-36807
- (list '#(syntax-object
- identifier?
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene
- guile))))))
- (hygiene guile))
- id-36807))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-36781"
- "l-*-36782"
- "l-*-36783"
- "l-*-36784"
- "l-*-36785"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-36763"))
- #(ribcage
- (identifier-syntax)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- identifier-syntax
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- exp1-36808))))))
- tmp-36798)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-36791))))))))
+ #(syntax-object variable-transformer ((top)) (hygiene guile))))
+ (list '#(syntax-object syntax-case ((top)) (hygiene guile))
+ '#(syntax-object x ((top)) (hygiene guile))
+ '(#(syntax-object set! ((top)) (hygiene guile)))
+ (list (list '#(syntax-object set! ((top)) (hygiene guile)) var val)
+ (list '#(syntax-object syntax ((top)) (hygiene guile)) exp2))
+ (list (cons id
+ '(#(syntax-object x ((top)) (hygiene guile))
+ #(syntax-object ... ((top)) (hygiene guile))))
+ (list '#(syntax-object syntax ((top)) (hygiene guile))
+ (cons exp1
+ '(#(syntax-object x ((top)) (hygiene guile))
+ #(syntax-object ... ((top)) (hygiene guile))))))
+ (list id
+ (list '#(syntax-object identifier? ((top)) (hygiene guile))
+ (list '#(syntax-object syntax ((top)) (hygiene guile)) id))
+ (list '#(syntax-object syntax ((top)) (hygiene guile)) exp1))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
(define define*
(make-syntax-transformer
'define*
'macro
- (lambda (x-36844)
- (let ((tmp-36846
- ($sc-dispatch
- x-36844
- '(_ (any . any) any . each-any))))
- (if tmp-36846
- (@apply
- (lambda (id-36850 args-36851 b0-36852 b1-36853)
- (list '#(syntax-object
- define
- ((top)
- #(ribcage
- #(id args b0 b1)
- #((top) (top) (top) (top))
- #("l-*-36826"
- "l-*-36827"
- "l-*-36828"
- "l-*-36829"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36823"))
- #(ribcage
- (define*)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define*
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- id-36850
- (cons '#(syntax-object
- lambda*
- ((top)
- #(ribcage
- #(id args b0 b1)
- #((top) (top) (top) (top))
- #("l-*-36826"
- "l-*-36827"
- "l-*-36828"
- "l-*-36829"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36823"))
- #(ribcage
- (define*)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define*
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- (cons args-36851 (cons b0-36852 b1-36853)))))
- tmp-36846)
- (let ((tmp-36854 ($sc-dispatch x-36844 '(_ any any))))
- (if (if tmp-36854
- (@apply
- (lambda (id-36858 val-36859)
- (identifier?
- '#(syntax-object
- x
- ((top)
- #(ribcage
- #(id val)
- #((top) (top))
- #("l-*-36836" "l-*-36837"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36823"))
- #(ribcage
- (define*)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define*
- ((top))
- (hygiene guile))))))
- (hygiene guile))))
- tmp-36854)
- #f)
- (@apply
- (lambda (id-36860 val-36861)
- (list '#(syntax-object
- define
- ((top)
- #(ribcage
- #(id val)
- #((top) (top))
- #("l-*-36840" "l-*-36841"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-36823"))
- #(ribcage
- (define*)
- ((top))
- (((hygiene guile)
- .
- #(syntax-object
- define*
- ((top))
- (hygiene guile))))))
- (hygiene guile))
- id-36860
- val-36861))
- tmp-36854)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-36844))))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+ (if tmp
+ (apply (lambda (id args b0 b1)
+ (list '#(syntax-object define ((top)) (hygiene guile))
+ id
+ (cons '#(syntax-object lambda* ((top)) (hygiene guile))
+ (cons args (cons b0 b1)))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
+ (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
+ (apply (lambda (id val)
+ (list '#(syntax-object define ((top)) (hygiene guile)) id val))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 0323c1e3e..760f8252f 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2529,7 +2529,7 @@
(if (and (id? #'pat)
(and-map (lambda (x) (not (free-id=? #'pat x)))
(cons #'(... ...) keys)))
- (if (free-id=? #'pad #'_)
+ (if (free-id=? #'pat #'_)
(expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
@@ -2856,8 +2856,8 @@
((out ...) (let () e1 e2 ...)))))))
(define-syntax syntax-rules
- (lambda (x)
- (syntax-case x ()
+ (lambda (xx)
+ (syntax-case xx ()
((_ (k ...) ((keyword . pattern) template) ...)
#'(lambda (x)
;; embed patterns as procedure metadata
@@ -3108,8 +3108,8 @@
(error "variable transformer not a procedure" proc)))
(define-syntax identifier-syntax
- (lambda (x)
- (syntax-case x (set!)
+ (lambda (xx)
+ (syntax-case xx (set!)
((_ e)
#'(lambda (x)
#((macro-type . identifier-syntax))
@@ -3134,5 +3134,5 @@
(syntax-case x ()
((_ (id . args) b0 b1 ...)
#'(define id (lambda* args b0 b1 ...)))
- ((_ id val) (identifier? #'x)
+ ((_ id val) (identifier? #'id)
#'(define id val)))))