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* + ((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* - ((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) + ((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* - ((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) - (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) - #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) - #f - name-23602) - (make-struct/no-tail - (vector-ref %expanded-vtables 1) - #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 - #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))) + ((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 - "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 + "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* - ((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) - (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) - #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) - (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 - 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) - #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) - (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) - (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 - (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 - (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))) - (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) - (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) - (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) - (call-with-values - (lambda () - (cvt*-14453 (cdr p*-15252) n-15253 ids-15254)) - (lambda (y-15257 ids-15258) - (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) - (call-with-values - (lambda () - (cvt*-14453 - ys-14687 - n-14459 - ids-14460)) - (lambda (ys-15172 ids-15173) - (call-with-values - (lambda () - (cvt-14455 - x-14685 - (#{1+}# n-14459) - ids-15173)) - (lambda (x-15174 ids-15175) - (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) - (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) - (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) - (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 + ((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 - (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 + "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) '(()) - (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) + 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 + "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 + "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 + "sequence of zero expressions" + (source-wrap e w s mod))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + 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 "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) - (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 + tmp-1)))) + ((memv key + '(define-form define-syntax-form define-syntax-parameter-form)) + (syntax-violation + #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 + "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 + "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)) '() - 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+) + 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 + #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 () (parse-req req opt rest kw (cons e1 e2))) + (lambda (meta req opt rest kw inits vars body) + (call-with-values + (lambda () + (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 () (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 () (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 () (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" + 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* (cdr p*) n ids)) + (lambda (y ids) + (call-with-values + (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 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* ys n ids)) + (lambda (ys ids) + (call-with-values + (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 y n ids)) + (lambda (y ids) + (call-with-values + (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 () + (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 () (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) + (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)) - . - #(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) - . - #(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) - . - #(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)))))))) + #(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) + #(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") + any)))) + (if tmp-1 + (apply (lambda (p) + (quasicons + '("quote" + #(syntax-object + quasiquote + ((top) + #(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-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") + (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-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) + (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) - . - #(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)) - #(syntax-object - unquote-splicing - ((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))) - (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))) + (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)) - (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)) - 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)))) + (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)) - . - #(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) - #(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))))) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm index 9243f4e6a..f5bb699b2 100644 --- a/module/language/scheme/decompile-tree-il.scm +++ b/module/language/scheme/decompile-tree-il.scm @@ -1,6 +1,6 @@ ;;; Guile VM code converters -;; Copyright (C) 2001,2009 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 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 @@ -20,7 +20,804 @@ (define-module (language scheme decompile-tree-il) #:use-module (language tree-il) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 receive) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (system base syntax) #:export (decompile-tree-il)) -(define (decompile-tree-il x env opts) - (values (tree-il->scheme x) env)) +(define (decompile-tree-il e env opts) + (apply do-decompile e env opts)) + +(define* (do-decompile e env + #:key + (use-derived-syntax? #t) + (avoid-lambda? #t) + (use-case? #t) + (strip-numeric-suffixes? #f) + #:allow-other-keys) + + (receive (output-name-table occurrence-count-table) + (choose-output-names e use-derived-syntax? strip-numeric-suffixes?) + + (define (output-name s) (hashq-ref output-name-table s)) + (define (occurrence-count s) (hashq-ref occurrence-count-table s)) + + (define (const x) (lambda (_) x)) + (define (atom? x) (not (or (pair? x) (vector? x)))) + + (define (build-void) '(if #f #f)) + + (define (build-begin es) + (match es + (() (build-void)) + ((e) e) + (_ `(begin ,@es)))) + + (define (build-lambda-body e) + (match e + (('let () body ...) body) + (('begin es ...) es) + (_ (list e)))) + + (define (build-begin-body e) + (match e + (('begin es ...) es) + (_ (list e)))) + + (define (build-define name e) + (match e + ((? (const avoid-lambda?) + ('lambda formals body ...)) + `(define (,name ,@formals) ,@body)) + ((? (const avoid-lambda?) + ('lambda* formals body ...)) + `(define* (,name ,@formals) ,@body)) + (_ `(define ,name ,e)))) + + (define (build-let names vals body) + (match `(let ,(map list names vals) + ,@(build-lambda-body body)) + ((_ () e) e) + ((_ (b) ('let* (bs ...) body ...)) + `(let* (,b ,@bs) ,@body)) + ((? (const use-derived-syntax?) + (_ (b1) ('let (b2) body ...))) + `(let* (,b1 ,b2) ,@body)) + (e e))) + + (define (build-letrec in-order? names vals body) + (match `(,(if in-order? 'letrec* 'letrec) + ,(map list names vals) + ,@(build-lambda-body body)) + ((_ () e) e) + ((_ () body ...) `(let () ,@body)) + ((_ ((name ('lambda (formals ...) body ...))) + (name args ...)) + (=> failure) + (if (= (length formals) (length args)) + `(let ,name ,(map list formals args) ,@body) + (failure))) + ((? (const avoid-lambda?) + ('letrec* _ body ...)) + `(let () + ,@(map build-define names vals) + ,@body)) + (e e))) + + (define (build-if test consequent alternate) + (match alternate + (('if #f _) `(if ,test ,consequent)) + (_ `(if ,test ,consequent ,alternate)))) + + (define (build-and xs) + (match xs + (() #t) + ((x) x) + (_ `(and ,@xs)))) + + (define (build-or xs) + (match xs + (() #f) + ((x) x) + (_ `(or ,@xs)))) + + (define (case-test-var test) + (match test + (('memv (? atom? v) ('quote (datums ...))) + v) + (('eqv? (? atom? v) ('quote datum)) + v) + (_ #f))) + + (define (test->datums v test) + (match (cons v test) + ((v 'memv v ('quote (xs ...))) + xs) + ((v 'eqv? v ('quote x)) + (list x)) + (_ #f))) + + (define (build-else-tail e) + (match e + (('if #f _) '()) + (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x)) + (else #f))) + (_ `((else ,@(build-begin-body e)))))) + + (define (build-cond-else-tail e) + (match e + (('cond clauses ...) clauses) + (_ (build-else-tail e)))) + + (define (build-case-else-tail v e) + (match (cons v e) + ((v 'case v clauses ...) + clauses) + ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*) + `((,xs ,@(build-begin-body consequent)) + ,@(build-case-else-tail v (build-begin alternate*)))) + ((v 'if ('eqv? v ('quote x)) consequent . alternate*) + `(((,x) ,@(build-begin-body consequent)) + ,@(build-case-else-tail v (build-begin alternate*)))) + (_ (build-else-tail e)))) + + (define (clauses+tail clauses) + (match clauses + ((cs ... (and c ('else . _))) (values cs (list c))) + (_ (values clauses '())))) + + (define (build-cond tests consequents alternate) + (case (length tests) + ((0) alternate) + ((1) (build-if (car tests) (car consequents) alternate)) + (else `(cond ,@(map (lambda (test consequent) + `(,test ,@(build-begin-body consequent))) + tests consequents) + ,@(build-cond-else-tail alternate))))) + + (define (build-cond-or-case tests consequents alternate) + (if (not use-case?) + (build-cond tests consequents alternate) + (let* ((v (and (not (null? tests)) + (case-test-var (car tests)))) + (datum-lists (take-while identity + (map (cut test->datums v <>) + tests))) + (n (length datum-lists)) + (tail (build-case-else-tail v (build-cond + (drop tests n) + (drop consequents n) + alternate)))) + (receive (clauses tail) (clauses+tail tail) + (let ((n (+ n (length clauses))) + (datum-lists (append datum-lists + (map car clauses))) + (consequents (append consequents + (map build-begin + (map cdr clauses))))) + (if (< n 2) + (build-cond tests consequents alternate) + `(case ,v + ,@(map cons datum-lists (map build-begin-body + (take consequents n))) + ,@tail))))))) + + (define (recurse e) + + (define (recurse-body e) + (build-lambda-body (recurse e))) + + (record-case e + (() + (build-void)) + + (( exp) + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + `(quote ,exp))) + + (( head tail) + (build-begin (cons (recurse head) + (build-begin-body + (recurse tail))))) + + (( proc args) + (match `(,(recurse proc) ,@(map recurse args)) + ((('lambda (formals ...) body ...) args ...) + (=> failure) + (if (= (length formals) (length args)) + (build-let formals args (build-begin body)) + (failure))) + (e e))) + + (( name args) + `(,name ,@(map recurse args))) + + (( name) + name) + + (( gensym) + (output-name gensym)) + + (( gensym exp) + `(set! ,(output-name gensym) ,(recurse exp))) + + (( mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + (( mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp))) + + (( name) + name) + + (( name exp) + `(set! ,name ,(recurse exp))) + + (( name exp) + (build-define name (recurse exp))) + + (( meta body) + (let ((body (recurse body)) + (doc (assq-ref meta 'documentation))) + (if (not doc) + body + (match body + (('lambda formals body ...) + `(lambda ,formals ,doc ,@body)) + (('lambda* formals body ...) + `(lambda* ,formals ,doc ,@body)) + (('case-lambda (formals body ...) clauses ...) + `(case-lambda (,formals ,doc ,@body) ,@clauses)) + (('case-lambda* (formals body ...) clauses ...) + `(case-lambda* (,formals ,doc ,@body) ,@clauses)) + (e e))))) + + (( req opt rest kw inits gensyms body alternate) + (let ((names (map output-name gensyms))) + (cond + ((and (not opt) (not kw) (not alternate)) + `(lambda ,(if rest (apply cons* names) names) + ,@(recurse-body body))) + ((and (not opt) (not kw)) + (let ((alt-expansion (recurse alternate)) + (formals (if rest (apply cons* names) names))) + (case (car alt-expansion) + ((lambda) + `(case-lambda (,formals ,@(recurse-body body)) + ,(cdr alt-expansion))) + ((lambda*) + `(case-lambda* (,formals ,@(recurse-body body)) + ,(cdr alt-expansion))) + ((case-lambda) + `(case-lambda (,formals ,@(recurse-body body)) + ,@(cdr alt-expansion))) + ((case-lambda*) + `(case-lambda* (,formals ,@(recurse-body body)) + ,@(cdr alt-expansion)))))) + (else + (let* ((alt-expansion (and alternate (recurse alternate))) + (nreq (length req)) + (nopt (if opt (length opt) 0)) + (restargs (if rest (list-ref names (+ nreq nopt)) '())) + (reqargs (list-head names nreq)) + (optargs (if opt + `(#:optional + ,@(map list + (list-head (list-tail names nreq) nopt) + (map recurse + (list-head inits nopt)))) + '())) + (kwargs (if kw + `(#:key + ,@(map list + (map output-name (map caddr (cdr kw))) + (map recurse + (list-tail inits nopt)) + (map car (cdr kw))) + ,@(if (car kw) + '(#:allow-other-keys) + '())) + '())) + (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs))) + (if (not alt-expansion) + `(lambda* ,formals ,@(recurse-body body)) + (case (car alt-expansion) + ((lambda lambda*) + `(case-lambda* (,formals ,@(recurse-body body)) + ,(cdr alt-expansion))) + ((case-lambda case-lambda*) + `(case-lambda* (,formals ,@(recurse-body body)) + ,@(cdr alt-expansion)))))))))) + + (( test consequent alternate) + (define (simplify-test e) + (match e + (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b))) + `(memv ,v '(,a ,b))) + (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...)))) + `(memv ,v '(,a ,@bs))) + (('case (? atom? v) + ((datum) #t) ... + ('else ('eqv? v ('quote last-datum)))) + `(memv ,v '(,@datum ,last-datum))) + (_ e))) + (match `(if ,(simplify-test (recurse test)) + ,(recurse consequent) + ,@(if (void? alternate) '() + (list (recurse alternate)))) + (('if test ('if ('and xs ...) consequent)) + (build-if (build-and (cons test xs)) + consequent + (build-void))) + ((? (const use-derived-syntax?) + ('if test1 ('if test2 consequent))) + (build-if (build-and (list test1 test2)) + consequent + (build-void))) + (('if (? atom? x) x ('or ys ...)) + (build-or (cons x ys))) + ((? (const use-derived-syntax?) + ('if (? atom? x) x y)) + (build-or (list x y))) + (('if test consequent) + `(if ,test ,consequent)) + (('if test ('and xs ...) #f) + (build-and (cons test xs))) + ((? (const use-derived-syntax?) + ('if test consequent #f)) + (build-and (list test consequent))) + ((? (const use-derived-syntax?) + ('if test1 consequent1 + ('if test2 consequent2 . alternate*))) + (build-cond-or-case (list test1 test2) + (list consequent1 consequent2) + (build-begin alternate*))) + (('if test consequent ('cond clauses ...)) + `(cond (,test ,@(build-begin-body consequent)) + ,@clauses)) + (('if ('memv (? atom? v) ('quote (xs ...))) consequent + ('case v clauses ...)) + `(case ,v (,xs ,@(build-begin-body consequent)) + ,@clauses)) + (('if ('eqv? (? atom? v) ('quote x)) consequent + ('case v clauses ...)) + `(case ,v ((,x) ,@(build-begin-body consequent)) + ,@clauses)) + (e e))) + + (( gensyms vals body) + (match (build-let (map output-name gensyms) + (map recurse vals) + (recurse body)) + (('let ((v e)) ('or v xs ...)) + (=> failure) + (if (and (not (null? gensyms)) + (= 3 (occurrence-count (car gensyms)))) + `(or ,e ,@xs) + (failure))) + (('let ((v e)) ('case v clauses ...)) + (=> failure) + (if (and (not (null? gensyms)) + ;; FIXME: This fails if any of the 'memv's were + ;; optimized into multiple 'eqv?'s, because the + ;; occurrence count will be higher than we expect. + (= (occurrence-count (car gensyms)) + (1+ (length (clauses+tail clauses))))) + `(case ,e ,@clauses) + (failure))) + (e e))) + + (( in-order? gensyms vals body) + (build-letrec in-order? + (map output-name gensyms) + (map recurse vals) + (recurse body))) + + (( gensyms vals body) + ;; not a typo, we really do translate back to letrec. use letrec* since it + ;; doesn't matter, and the naive letrec* transformation does not require an + ;; inner let. + (build-letrec #t + (map output-name gensyms) + (map recurse vals) + (recurse body))) + + (( exp body) + `(call-with-values (lambda () ,@(recurse-body exp)) + ,(recurse (make-lambda #f '() body)))) + + (( body winder unwinder) + `(dynamic-wind ,(recurse winder) + (lambda () ,@(recurse-body body)) + ,(recurse unwinder))) + + (( fluids vals body) + `(with-fluids ,(map list + (map recurse fluids) + (map recurse vals)) + ,@(recurse-body body))) + + (( fluid) + `(fluid-ref ,(recurse fluid))) + + (( fluid exp) + `(fluid-set! ,(recurse fluid) ,(recurse exp))) + + (( tag body handler) + `(call-with-prompt + ,(recurse tag) + (lambda () ,@(recurse-body body)) + ,(recurse handler))) + + + (( tag args tail) + `(apply abort ,(recurse tag) ,@(map recurse args) + ,(recurse tail))))) + (values (recurse e) env))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Algorithm for choosing better variable names +;; ============================================ +;; +;; First we perform an analysis pass, collecting the following +;; information: +;; +;; * For each gensym: how many occurrences will occur in the output? +;; +;; * For each gensym A: which gensyms does A conflict with? Gensym A +;; and gensym B conflict if they have the same base name (usually the +;; same as the source name, but see below), and if giving them the +;; same name would cause a bad variable reference due to unintentional +;; variable capture. +;; +;; The occurrence counter is indexed by gensym and is global (within each +;; invocation of the algorithm), implemented using a hash table. We also +;; keep a global mapping from gensym to source name as provided by the +;; binding construct (we prefer not to trust the source names in the +;; lexical ref or set). +;; +;; As we recurse down into lexical binding forms, we keep track of a +;; mapping from base name to an ordered list of bindings, innermost +;; first. When we encounter a variable occurrence, we increment the +;; counter, look up the base name (preferring not to trust the 'name' in +;; the lexical ref or set), and then look up the bindings currently in +;; effect for that base name. Hopefully our gensym will be the first +;; (innermost) binding. If not, we register a conflict between the +;; referenced gensym and the other bound gensyms with the same base name +;; that shadow the binding we want. These are simply the gensyms on the +;; binding list that come before our gensym. +;; +;; Top-level bindings are treated specially. Whenever top-level +;; references are found, they conflict with every lexical binding +;; currently in effect with the same base name. They are guaranteed to +;; be assigned to their source names. For purposes of recording +;; conflicts (which are normally keyed on gensyms) top-level identifiers +;; are assigned a pseudo-gensym that is an interned pair of the form +;; (top-level . ). This allows them to be compared using 'eq?' +;; like other gensyms. +;; +;; The base name is normally just the source name. However, if the +;; source name has a suffix of the form "-N" (where N is a positive +;; integer without leading zeroes), then we strip that suffix (multiple +;; times if necessary) to form the base name. We must do this because +;; we add suffixes of that form in order to resolve conflicts, and we +;; must ensure that only identifiers with the same base name can +;; possibly conflict with each other. +;; +;; XXX FIXME: Currently, primitives are treated exactly like top-level +;; bindings. This handles conflicting lexical bindings properly, but +;; does _not_ handle the case where top-level bindings conflict with the +;; needed primitives. +;; +;; Also note that this requires that 'choose-output-names' be kept in +;; sync with 'tree-il->scheme'. Primitives that are introduced by +;; 'tree-il->scheme' must be anticipated by 'choose-output-name'. +;; +;; We also ensure that lexically-bound identifiers found in operator +;; position will never be assigned one of the standard primitive names. +;; This is needed because 'tree-il->scheme' recognizes primitive names +;; in operator position and assumes that they have the standard +;; bindings. +;; +;; +;; How we assign an output name to each gensym +;; =========================================== +;; +;; We process the gensyms in order of decreasing occurrence count, with +;; each gensym choosing the best output name possible, as long as it +;; isn't the same name as any of the previously-chosen output names of +;; conflicting gensyms. +;; + + +;; +;; 'choose-output-names' analyzes the top-level form e, chooses good +;; variable names that are as close as possible to the source names, +;; and returns two values: +;; +;; * a hash table mapping gensym to output name +;; * a hash table mapping gensym to number of occurrences +;; +(define choose-output-names + (let () + (define primitive? + ;; This is a list of primitives that 'tree-il->scheme' assumes + ;; will have the standard bindings when found in operator + ;; position. + (let* ((primitives '(if quote @ @@ set! define define* + begin let let* letrec letrec* + and or cond case + lambda lambda* case-lambda case-lambda* + apply call-with-values dynamic-wind + with-fluids fluid-ref fluid-set! + call-with-prompt abort memv eqv?)) + (table (make-hash-table (length primitives)))) + (for-each (cut hashq-set! table <> #t) primitives) + (lambda (name) (hashq-ref table name)))) + + ;; Repeatedly strip suffix of the form "-N", where N is a string + ;; that could be produced by number->string given a positive + ;; integer. In other words, the first digit of N may not be 0. + (define compute-base-name + (let ((digits (string->char-set "0123456789"))) + (define (base-name-string str) + (let ((i (string-skip-right str digits))) + (if (and i (< (1+ i) (string-length str)) + (eq? #\- (string-ref str i)) + (not (eq? #\0 (string-ref str (1+ i))))) + (base-name-string (substring str 0 i)) + str))) + (lambda (sym) + (string->symbol (base-name-string (symbol->string sym)))))) + + ;; choose-output-names + (lambda (e use-derived-syntax? strip-numeric-suffixes?) + + (define lexical-gensyms '()) + + (define top-level-intern! + (let ((table (make-hash-table))) + (lambda (name) + (let ((h (hashq-create-handle! table name #f))) + (or (cdr h) (begin (set-cdr! h (cons 'top-level name)) + (cdr h))))))) + (define (top-level? s) (pair? s)) + (define (top-level-name s) (cdr s)) + + (define occurrence-count-table (make-hash-table)) + (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0)) + (define (increment-occurrence-count! s) + (let ((h (hashq-create-handle! occurrence-count-table s 0))) + (if (zero? (cdr h)) + (set! lexical-gensyms (cons s lexical-gensyms))) + (set-cdr! h (1+ (cdr h))))) + + (define base-name + (let ((table (make-hash-table))) + (lambda (name) + (let ((h (hashq-create-handle! table name #f))) + (or (cdr h) (begin (set-cdr! h (compute-base-name name)) + (cdr h))))))) + + (define source-name-table (make-hash-table)) + (define (set-source-name! s name) + (if (not (top-level? s)) + (let ((name (if strip-numeric-suffixes? + (base-name name) + name))) + (hashq-set! source-name-table s name)))) + (define (source-name s) + (if (top-level? s) + (top-level-name s) + (hashq-ref source-name-table s))) + + (define conflict-table (make-hash-table)) + (define (conflicts s) (or (hashq-ref conflict-table s) '())) + (define (add-conflict! a b) + (define (add! a b) + (if (not (top-level? a)) + (let ((h (hashq-create-handle! conflict-table a '()))) + (if (not (memq b (cdr h))) + (set-cdr! h (cons b (cdr h))))))) + (add! a b) + (add! b a)) + + (let recurse-with-bindings ((e e) (bindings vlist-null)) + (let recurse ((e e)) + + ;; We call this whenever we encounter a top-level ref or set + (define (top-level name) + (let ((bname (base-name name))) + (let ((s (top-level-intern! name)) + (conflicts (vhash-foldq* cons '() bname bindings))) + (for-each (cut add-conflict! s <>) conflicts)))) + + ;; We call this whenever we encounter a primitive reference. + ;; We must also call it for every primitive that might be + ;; inserted by 'tree-il->scheme'. It is okay to call this + ;; even when 'tree-il->scheme' will not insert the named + ;; primitive; the worst that will happen is for a lexical + ;; variable of the same name to be renamed unnecessarily. + (define (primitive name) (top-level name)) + + ;; We call this whenever we encounter a lexical ref or set. + (define (lexical s) + (increment-occurrence-count! s) + (let ((conflicts + (take-while + (lambda (s*) (not (eq? s s*))) + (reverse! (vhash-foldq* cons + '() + (base-name (source-name s)) + bindings))))) + (for-each (cut add-conflict! s <>) conflicts))) + + (record-case e + (() (primitive 'if)) ; (if #f #f) + (() (primitive 'quote)) + + (( proc args) + (if (lexical-ref? proc) + (let* ((gensym (lexical-ref-gensym proc)) + (name (source-name gensym))) + ;; If the operator position contains a bare variable + ;; reference with the same source name as a standard + ;; primitive, we must ensure that it will be given a + ;; different name, so that 'tree-il->scheme' will not + ;; misinterpret the resulting expression. + (if (primitive? name) + (add-conflict! gensym (top-level-intern! name))))) + (recurse proc) + (for-each recurse args)) + + (( name) (primitive name)) + (( name args) (primitive name) (for-each recurse args)) + + (( gensym) (lexical gensym)) + (( gensym exp) + (primitive 'set!) (lexical gensym) (recurse exp)) + + (( public?) (primitive (if public? '@ '@@))) + (( public? exp) + (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp)) + + (( name) (top-level name)) + (( name exp) + (primitive 'set!) (top-level name) (recurse exp)) + (( name exp) (top-level name) (recurse exp)) + + (( test consequent alternate) + (cond (use-derived-syntax? + (primitive 'and) (primitive 'or) + (primitive 'cond) (primitive 'case) + (primitive 'else) (primitive '=>))) + (primitive 'if) + (recurse test) (recurse consequent) (recurse alternate)) + + (( head tail) + (primitive 'begin) (recurse head) (recurse tail)) + + (( body) (recurse body)) + + (( req opt rest kw inits gensyms body alternate) + (primitive 'lambda) + (cond ((or opt kw alternate) + (primitive 'lambda*) + (primitive 'case-lambda) + (primitive 'case-lambda*))) + (primitive 'let) + (if use-derived-syntax? (primitive 'let*)) + (let* ((names (append req (or opt '()) (if rest (list rest) '()) + (map cadr (if kw (cdr kw) '())))) + (base-names (map base-name names)) + (body-bindings + (fold vhash-consq bindings base-names gensyms))) + (for-each increment-occurrence-count! gensyms) + (for-each set-source-name! gensyms names) + (for-each recurse inits) + (recurse-with-bindings body body-bindings) + (if alternate (recurse alternate)))) + + (( names gensyms vals body) + (primitive 'let) + (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) + (for-each increment-occurrence-count! gensyms) + (for-each set-source-name! gensyms names) + (for-each recurse vals) + (recurse-with-bindings + body (fold vhash-consq bindings (map base-name names) gensyms))) + + (( in-order? names gensyms vals body) + (primitive 'let) + (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) + (primitive (if in-order? 'letrec* 'letrec)) + (for-each increment-occurrence-count! gensyms) + (for-each set-source-name! gensyms names) + (let* ((base-names (map base-name names)) + (bindings (fold vhash-consq bindings base-names gensyms))) + (for-each (cut recurse-with-bindings <> bindings) vals) + (recurse-with-bindings body bindings))) + + (( names gensyms vals body) + (primitive 'let) + (primitive 'letrec*) + (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) + (for-each increment-occurrence-count! gensyms) + (for-each set-source-name! gensyms names) + (let* ((base-names (map base-name names)) + (bindings (fold vhash-consq bindings base-names gensyms))) + (for-each (cut recurse-with-bindings <> bindings) vals) + (recurse-with-bindings body bindings))) + + (( exp body) + (primitive 'call-with-values) + (recurse exp) (recurse body)) + + (( winder body unwinder) + (primitive 'dynamic-wind) + (recurse winder) (recurse body) (recurse unwinder)) + + (( fluids vals body) + (primitive 'with-fluids) + (for-each recurse fluids) + (for-each recurse vals) + (recurse body)) + + (( fluid) (primitive 'fluid-ref) (recurse fluid)) + (( fluid exp) + (primitive 'fluid-set!) (recurse fluid) (recurse exp)) + + (( tag body handler) + (primitive 'call-with-prompt) + (primitive 'lambda) + (recurse tag) (recurse body) (recurse handler)) + + (( tag args tail) + (primitive 'apply) + (primitive 'abort) + (recurse tag) (for-each recurse args) (recurse tail))))) + + (let () + (define output-name-table (make-hash-table)) + (define (set-output-name! s name) + (hashq-set! output-name-table s name)) + (define (output-name s) + (if (top-level? s) + (top-level-name s) + (hashq-ref output-name-table s))) + + (define sorted-lexical-gensyms + (sort-list lexical-gensyms + (lambda (a b) (> (occurrence-count a) + (occurrence-count b))))) + + (for-each (lambda (s) + (set-output-name! + s + (let ((the-conflicts (conflicts s)) + (the-source-name (source-name s))) + (define (not-yet-taken? name) + (not (any (lambda (s*) + (and=> (output-name s*) + (cut eq? name <>))) + the-conflicts))) + (if (not-yet-taken? the-source-name) + the-source-name + (let ((prefix (string-append + (symbol->string the-source-name) + "-"))) + (let loop ((i 1) (name the-source-name)) + (if (not-yet-taken? name) + name + (loop (+ i 1) + (string->symbol + (string-append + prefix + (number->string i))))))))))) + sorted-lexical-gensyms) + (values output-name-table occurrence-count-table))))) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 69af8d65a..fb58a027e 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 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 @@ -36,7 +36,7 @@ conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate call? make-call call-src call-proc call-args primcall? make-primcall primcall-src primcall-name primcall-args - seq? make-seq seq-head seq-tail + seq? make-seq seq-src seq-head seq-tail lambda? make-lambda lambda-src lambda-meta lambda-body lambda-case? make-lambda-case lambda-case-src lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw @@ -356,165 +356,10 @@ `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args) ,(unparse-tree-il tail))))) -(define (tree-il->scheme e) - (record-case e - (() - '(if #f #f)) - - (( proc args) - `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) - - (( name args) - `(,name ,@(map tree-il->scheme args))) - - (( test consequent alternate) - (if (void? alternate) - `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent)) - `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent) ,(tree-il->scheme alternate)))) - - (( name) - name) - - (( gensym) - gensym) - - (( gensym exp) - `(set! ,gensym ,(tree-il->scheme exp))) - - (( mod name public?) - `(,(if public? '@ '@@) ,mod ,name)) - - (( mod name public? exp) - `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) - - (( name) - name) - - (( name exp) - `(set! ,name ,(tree-il->scheme exp))) - - (( name exp) - `(define ,name ,(tree-il->scheme exp))) - - (( meta body) - ;; fixme: put in docstring - (tree-il->scheme body)) - - (( req opt rest kw inits gensyms body alternate) - (cond - ((and (not opt) (not kw) (not alternate)) - `(lambda ,(if rest (apply cons* gensyms) gensyms) - ,(tree-il->scheme body))) - ((and (not opt) (not kw)) - (let ((alt-expansion (tree-il->scheme alternate)) - (formals (if rest (apply cons* gensyms) gensyms))) - (case (car alt-expansion) - ((lambda) - `(case-lambda (,formals ,(tree-il->scheme body)) - ,(cdr alt-expansion))) - ((lambda*) - `(case-lambda* (,formals ,(tree-il->scheme body)) - ,(cdr alt-expansion))) - ((case-lambda) - `(case-lambda (,formals ,(tree-il->scheme body)) - ,@(cdr alt-expansion))) - ((case-lambda*) - `(case-lambda* (,formals ,(tree-il->scheme body)) - ,@(cdr alt-expansion)))))) - (else - (let* ((alt-expansion (and alternate (tree-il->scheme alternate))) - (nreq (length req)) - (nopt (if opt (length opt) 0)) - (restargs (if rest (list-ref gensyms (+ nreq nopt)) '())) - (reqargs (list-head gensyms nreq)) - (optargs (if opt - `(#:optional - ,@(map list - (list-head (list-tail gensyms nreq) nopt) - (map tree-il->scheme - (list-head inits nopt)))) - '())) - (kwargs (if kw - `(#:key - ,@(map list - (map caddr (cdr kw)) - (map tree-il->scheme - (list-tail inits nopt)) - (map car (cdr kw))) - ,@(if (car kw) - '(#:allow-other-keys) - '())) - '())) - (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs))) - (if (not alt-expansion) - `(lambda* ,formals ,(tree-il->scheme body)) - (case (car alt-expansion) - ((lambda lambda*) - `(case-lambda* (,formals ,(tree-il->scheme body)) - ,(cdr alt-expansion))) - ((case-lambda case-lambda*) - `(case-lambda* (,formals ,(tree-il->scheme body)) - ,@(cdr alt-expansion))))))))) - - (( exp) - (if (and (self-evaluating? exp) (not (vector? exp))) - exp - (list 'quote exp))) - - (( head tail) - `(begin ,(tree-il->scheme head) - ,@(unfold (lambda (x) (not (seq? x))) - (lambda (x) (tree-il->scheme (seq-head x))) - seq-tail - tail - (lambda (x) - (list (tree-il->scheme x)))))) - - (( gensyms vals body) - `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) - - (( in-order? gensyms vals body) - `(,(if in-order? 'letrec* 'letrec) - ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) - - (( gensyms vals body) - ;; not a typo, we really do translate back to letrec. use letrec* since it - ;; doesn't matter, and the naive letrec* transformation does not require an - ;; inner let. - `(letrec* ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) - - (( exp body) - `(call-with-values (lambda () ,(tree-il->scheme exp)) - ,(tree-il->scheme (make-lambda #f '() body)))) - - (( winder body unwinder) - `(dynamic-wind ,(tree-il->scheme winder) - (lambda () ,(tree-il->scheme body)) - ,(tree-il->scheme unwinder))) - - (( fluids vals body) - `(with-fluids ,(map list - (map tree-il->scheme fluids) - (map tree-il->scheme vals)) - ,(tree-il->scheme body))) - - (( fluid) - `(fluid-ref ,(tree-il->scheme fluid))) - - (( fluid exp) - `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp))) - - (( tag body handler) - `(call-with-prompt - ,(tree-il->scheme tag) - (lambda () ,(tree-il->scheme body)) - ,(tree-il->scheme handler))) - - - (( tag args tail) - `(apply abort-to-prompt - ,(tree-il->scheme tag) ,@(map tree-il->scheme args) - ,(tree-il->scheme tail))))) +(define* (tree-il->scheme e #:optional (env #f) (opts '())) + (values ((@ (language scheme decompile-tree-il) + decompile-tree-il) + e env opts))) (define (tree-il-fold leaf down up seed tree)