diff --git a/libguile/debug.c b/libguile/debug.c index 20c8d4e6b..5042fbb73 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -400,6 +400,21 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0, + (SCM proc), + "Return the module that was current when @var{proc} was defined.") +#define FUNC_NAME s_scm_procedure_module +{ + SCM_VALIDATE_PROC (SCM_ARG1, proc); + + if (scm_is_true (scm_program_p (proc))) + return scm_program_module (proc); + else + return scm_env_module (scm_procedure_environment (proc)); +} +#undef FUNC_NAME + + /* Eval in a local environment. We would like to have the ability to diff --git a/libguile/debug.h b/libguile/debug.h index 4e94b3c15..4d16fd83a 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -140,6 +140,7 @@ SCM_API SCM scm_local_eval (SCM exp, SCM env); SCM_API SCM scm_reverse_lookup (SCM env, SCM data); SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk); SCM_API SCM scm_procedure_environment (SCM proc); +SCM_API SCM scm_procedure_module (SCM proc); SCM_API SCM scm_procedure_source (SCM proc); SCM_API SCM scm_procedure_name (SCM proc); SCM_API SCM scm_memoized_environment (SCM m); diff --git a/libguile/eval.c b/libguile/eval.c index 48b229903..4c79b166c 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -306,6 +306,9 @@ syntax_error (const char* const msg, const SCM form, const SCM expr) { if (SCM_UNLIKELY (!(cond))) \ syntax_error (message, form, expr); } +static void error_unbound_variable (SCM symbol) SCM_NORETURN; +static void error_defined_variable (SCM symbol) SCM_NORETURN; + /* {Ilocs} @@ -1976,6 +1979,48 @@ unmemoize_set_x (const SCM expr, const SCM env) /* Start of the memoizers for non-R5RS builtin macros. */ +SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at); +SCM_GLOBAL_SYMBOL (scm_sym_at, s_at); + +SCM +scm_m_at (SCM expr, SCM env SCM_UNUSED) +{ + SCM mod, var; + ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr); + + mod = scm_resolve_module (scm_cadr (expr)); + if (scm_is_false (mod)) + error_unbound_variable (expr); + var = scm_module_variable (scm_module_public_interface (mod), scm_caddr (expr)); + if (scm_is_false (var)) + error_unbound_variable (expr); + + return var; +} + +SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat); +SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat); + +SCM +scm_m_atat (SCM expr, SCM env SCM_UNUSED) +{ + SCM mod, var; + ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr); + + mod = scm_resolve_module (scm_cadr (expr)); + if (scm_is_false (mod)) + error_unbound_variable (expr); + var = scm_module_variable (mod, scm_caddr (expr)); + if (scm_is_false (var)) + error_unbound_variable (expr); + + return var; +} + SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply); SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); @@ -2662,9 +2707,6 @@ scm_ilookup (SCM iloc, SCM env) SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); -static void error_unbound_variable (SCM symbol) SCM_NORETURN; -static void error_defined_variable (SCM symbol) SCM_NORETURN; - /* Call this for variables that are unfound. */ static void diff --git a/libguile/eval.h b/libguile/eval.h index 333265263..f3ec2e19c 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -94,6 +94,8 @@ SCM_API SCM scm_sym_quasiquote; SCM_API SCM scm_sym_unquote; SCM_API SCM scm_sym_uq_splicing; +SCM_API SCM scm_sym_at; +SCM_API SCM scm_sym_atat; SCM_API SCM scm_sym_atapply; SCM_API SCM scm_sym_atcall_cc; SCM_API SCM scm_sym_at_call_with_values; @@ -131,6 +133,8 @@ SCM_API SCM scm_m_future (SCM xorig, SCM env); SCM_API SCM scm_m_define (SCM x, SCM env); SCM_API SCM scm_m_letrec (SCM xorig, SCM env); SCM_API SCM scm_m_let (SCM xorig, SCM env); +SCM_API SCM scm_m_at (SCM xorig, SCM env); +SCM_API SCM scm_m_atat (SCM xorig, SCM env); SCM_API SCM scm_m_apply (SCM xorig, SCM env); SCM_API SCM scm_m_cont (SCM xorig, SCM env); #if SCM_ENABLE_ELISP diff --git a/libguile/modules.c b/libguile/modules.c index beee0e2a5..428cb607d 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -544,6 +544,21 @@ SCM_DEFINE (scm_standard_interface_eval_closure, } #undef FUNC_NAME +SCM_DEFINE (scm_eval_closure_module, + "eval-closure-module", 1, 0, 0, + (SCM eval_closure), + "Return the module associated with this eval closure.") +/* the idea is that eval closures are really not the way to do things, they're + superfluous given our module system. this function lets mmacros migrate away + from eval closures. */ +#define FUNC_NAME s_scm_eval_closure_module +{ + SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P, + "eval-closure"); + return SCM_SMOB_OBJECT (eval_closure); +} +#undef FUNC_NAME + SCM scm_module_lookup_closure (SCM module) { diff --git a/libguile/modules.h b/libguile/modules.h index 4f42e1888..3cd090476 100644 --- a/libguile/modules.h +++ b/libguile/modules.h @@ -109,6 +109,7 @@ SCM_API SCM scm_current_module_transformer (void); SCM_API SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep); SCM_API SCM scm_standard_eval_closure (SCM module); SCM_API SCM scm_standard_interface_eval_closure (SCM module); +SCM_API SCM scm_eval_closure_module (SCM eval_closure); /* deprecated already */ SCM_API SCM scm_get_pre_modules_obarray (void); SCM_API SCM scm_lookup_closure_module (SCM proc); diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 303ef315d..5468604d2 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -284,7 +284,13 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1) /* might longjmp */ what = scm_module_lookup (mod, what); else - what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + { + SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + if (scm_is_false (v)) + SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what)); + else + what = v; + } } else { @@ -367,7 +373,13 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) /* might longjmp */ what = scm_module_lookup (mod, what); else - what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + { + SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); + if (scm_is_false (v)) + SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what)); + else + what = v; + } } else { diff --git a/module/ice-9/Makefile.am b/module/ice-9/Makefile.am index 8c94d8320..a93ec817b 100644 --- a/module/ice-9/Makefile.am +++ b/module/ice-9/Makefile.am @@ -30,7 +30,7 @@ modpath = ice-9 # and forth between interpreted and compiled code, we end up using more # of the C stack than the interpreter would have; so avoid that by # putting these core modules first. -SOURCES = psyntax-pp.scm annotate.scm boot-9.scm \ +SOURCES = psyntax-pp.scm expand-support.scm boot-9.scm \ and-let-star.scm calling.scm common-list.scm \ debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ format.scm getopt-long.scm hcons.scm i18n.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 29c89b1f9..03d876907 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2936,31 +2936,6 @@ module '(ice-9 q) '(make-q q-length))}." (define load load-module) -;; The following macro allows one to write, for example, -;; -;; (@ (ice-9 pretty-print) pretty-print) -;; -;; to refer directly to the pretty-print variable in module (ice-9 -;; pretty-print). It works by looking up the variable and inserting -;; it directly into the code. This is understood by the evaluator. -;; Indeed, all references to global variables are memoized into such -;; variable objects. - -(define-macro (@ mod-name var-name) - (let ((var (module-variable (resolve-interface mod-name) var-name))) - (if (not var) - (error "no such public variable" (list '@ mod-name var-name))) - var)) - -;; The '@@' macro is like '@' but it can also access bindings that -;; have not been explicitely exported. - -(define-macro (@@ mod-name var-name) - (let ((var (module-variable (resolve-module mod-name) var-name))) - (if (not var) - (error "no such variable" (list '@@ mod-name var-name))) - var)) - ;;; {Compiler interface} diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index a2fe77546..10a307be1 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -12,16 +12,16 @@ (let ((in (open-input-file source)) (out (open-output-file (string-append target ".tmp")))) - (with-fluids ((expansion-eval-closure - (module-eval-closure (current-module)))) - (let loop ((x (read in))) - (if (eof-object? x) - (begin - (close-port out) - (close-port in)) - (begin - (write (sc-expand3 x 'c '(compile load eval)) out) - (newline out) - (loop (read in))))))) + (let loop ((x (read in))) + (if (eof-object? x) + (begin + (close-port out) + (close-port in)) + (begin + (write (strip-expansion-structures + (sc-expand3 x 'c '(compile load eval))) + out) + (newline out) + (loop (read in)))))) (system (format #f "mv -f ~s.tmp ~s" target target)) diff --git a/module/ice-9/annotate.scm b/module/ice-9/expand-support.scm similarity index 52% rename from module/ice-9/annotate.scm rename to module/ice-9/expand-support.scm index 30f49d710..63ea2d2b1 100644 --- a/module/ice-9/annotate.scm +++ b/module/ice-9/expand-support.scm @@ -16,11 +16,19 @@ ;;;; -(define-module (ice-9 annotate) +(define-module (ice-9 expand-support) :export ( annotation? annotate deannotate make-annotation annotation-expression annotation-source annotation-stripped set-annotation-stripped! - deannotate/source-properties)) + deannotate/source-properties + + make-module-ref + module-ref-symbol module-ref-modname module-ref-public? + + make-lexical + lexical-name lexical-gensym + + strip-expansion-structures)) (define (make-vtable "prprpw" @@ -78,3 +86,78 @@ (set-source-properties! e source)) e)) (else e))) + + + +(define + (make-vtable "prprpr" + (lambda (struct port) + (display "#<" port) + (display (if (module-ref-public? struct) "@ " "@@ ") port) + (display (module-ref-modname struct) port) + (display " " port) + (display (module-ref-symbol struct) port) + (display ">" port)))) + +(define (module-ref? x) + (and (struct? x) (eq? (struct-vtable x) ))) + +(define (make-module-ref modname symbol public?) + (make-struct 0 modname symbol public?)) + +(define (module-ref-modname a) + (struct-ref a 0)) +(define (module-ref-symbol a) + (struct-ref a 1)) +(define (module-ref-public? a) + (struct-ref a 2)) + + + +(define + (make-vtable "prpr" + (lambda (struct port) + (display "#" port)))) + +(define (lexical? x) + (and (struct? x) (eq? (struct-vtable x) ))) + +(define (make-lexical name gensym) + (make-struct 0 name gensym)) + +(define (lexical-name a) + (struct-ref a 0)) +(define (lexical-gensym a) + (struct-ref a 1)) + + + +(define (strip-expansion-structures e) + (cond ((list? e) + (map strip-expansion-structures e)) + ((pair? e) + (cons (strip-expansion-structures (car e)) + (strip-expansion-structures (cdr e)))) + ((annotation? e) + (let ((e (strip-expansion-structures (annotation-expression e))) + (source (annotation-source e))) + (if (pair? e) + (set-source-properties! e source)) + e)) + ((module-ref? e) + (if (and (module-ref-modname e) + (not (eq? (module-ref-modname e) + (module-name (current-module))))) + `(,(if (module-ref-public? e) '@ '@@) + ,(module-ref-modname e) + ,(module-ref-symbol e)) + (module-ref-symbol e))) + ((lexical? e) + (lexical-gensym e)) + ((record? e) + (error "unexpected record in expansion" e)) + (else e))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 1fde489a8..0ae942270 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,11 @@ -(letrec ((syntmp-lambda-var-list-151 (lambda (syntmp-vars-536) (let syntmp-lvl-537 ((syntmp-vars-538 syntmp-vars-536) (syntmp-ls-539 (quote ())) (syntmp-w-540 (quote (())))) (cond ((pair? syntmp-vars-538) (syntmp-lvl-537 (cdr syntmp-vars-538) (cons (syntmp-wrap-130 (car syntmp-vars-538) syntmp-w-540) syntmp-ls-539) syntmp-w-540)) ((syntmp-id?-102 syntmp-vars-538) (cons (syntmp-wrap-130 syntmp-vars-538 syntmp-w-540) syntmp-ls-539)) ((null? syntmp-vars-538) syntmp-ls-539) ((syntmp-syntax-object?-88 syntmp-vars-538) (syntmp-lvl-537 (syntmp-syntax-object-expression-89 syntmp-vars-538) syntmp-ls-539 (syntmp-join-wraps-121 syntmp-w-540 (syntmp-syntax-object-wrap-90 syntmp-vars-538)))) ((annotation? syntmp-vars-538) (syntmp-lvl-537 (annotation-expression syntmp-vars-538) syntmp-ls-539 syntmp-w-540)) (else (cons syntmp-vars-538 syntmp-ls-539)))))) (syntmp-gen-var-150 (lambda (syntmp-id-541) (let ((syntmp-id-542 (if (syntmp-syntax-object?-88 syntmp-id-541) (syntmp-syntax-object-expression-89 syntmp-id-541) syntmp-id-541))) (if (annotation? syntmp-id-542) (syntmp-build-annotated-81 (annotation-source syntmp-id-542) (gensym (symbol->string (annotation-expression syntmp-id-542)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-542))))))) (syntmp-strip-149 (lambda (syntmp-x-543 syntmp-w-544) (if (memq (quote top) (syntmp-wrap-marks-105 syntmp-w-544)) (if (or (annotation? syntmp-x-543) (and (pair? syntmp-x-543) (annotation? (car syntmp-x-543)))) (syntmp-strip-annotation-148 syntmp-x-543 #f) syntmp-x-543) (let syntmp-f-545 ((syntmp-x-546 syntmp-x-543)) (cond ((syntmp-syntax-object?-88 syntmp-x-546) (syntmp-strip-149 (syntmp-syntax-object-expression-89 syntmp-x-546) (syntmp-syntax-object-wrap-90 syntmp-x-546))) ((pair? syntmp-x-546) (let ((syntmp-a-547 (syntmp-f-545 (car syntmp-x-546))) (syntmp-d-548 (syntmp-f-545 (cdr syntmp-x-546)))) (if (and (eq? syntmp-a-547 (car syntmp-x-546)) (eq? syntmp-d-548 (cdr syntmp-x-546))) syntmp-x-546 (cons syntmp-a-547 syntmp-d-548)))) ((vector? syntmp-x-546) (let ((syntmp-old-549 (vector->list syntmp-x-546))) (let ((syntmp-new-550 (map syntmp-f-545 syntmp-old-549))) (if (andmap eq? syntmp-old-549 syntmp-new-550) syntmp-x-546 (list->vector syntmp-new-550))))) (else syntmp-x-546)))))) (syntmp-strip-annotation-148 (lambda (syntmp-x-551 syntmp-parent-552) (cond ((pair? syntmp-x-551) (let ((syntmp-new-553 (cons #f #f))) (begin (if syntmp-parent-552 (set-annotation-stripped! syntmp-parent-552 syntmp-new-553)) (set-car! syntmp-new-553 (syntmp-strip-annotation-148 (car syntmp-x-551) #f)) (set-cdr! syntmp-new-553 (syntmp-strip-annotation-148 (cdr syntmp-x-551) #f)) syntmp-new-553))) ((annotation? syntmp-x-551) (or (annotation-stripped syntmp-x-551) (syntmp-strip-annotation-148 (annotation-expression syntmp-x-551) syntmp-x-551))) ((vector? syntmp-x-551) (let ((syntmp-new-554 (make-vector (vector-length syntmp-x-551)))) (begin (if syntmp-parent-552 (set-annotation-stripped! syntmp-parent-552 syntmp-new-554)) (let syntmp-loop-555 ((syntmp-i-556 (- (vector-length syntmp-x-551) 1))) (unless (syntmp-fx<-75 syntmp-i-556 0) (vector-set! syntmp-new-554 syntmp-i-556 (syntmp-strip-annotation-148 (vector-ref syntmp-x-551 syntmp-i-556) #f)) (syntmp-loop-555 (syntmp-fx--73 syntmp-i-556 1)))) syntmp-new-554))) (else syntmp-x-551)))) (syntmp-ellipsis?-147 (lambda (syntmp-x-557) (and (syntmp-nonsymbol-id?-101 syntmp-x-557) (syntmp-free-id=?-125 syntmp-x-557 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-146 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-145 (lambda (syntmp-expanded-558) (let ((syntmp-p-559 (syntmp-local-eval-hook-77 syntmp-expanded-558))) (if (procedure? syntmp-p-559) syntmp-p-559 (syntax-error syntmp-p-559 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-144 (lambda (syntmp-rec?-560 syntmp-e-561 syntmp-r-562 syntmp-w-563 syntmp-s-564 syntmp-k-565) ((lambda (syntmp-tmp-566) ((lambda (syntmp-tmp-567) (if syntmp-tmp-567 (apply (lambda (syntmp-_-568 syntmp-id-569 syntmp-val-570 syntmp-e1-571 syntmp-e2-572) (let ((syntmp-ids-573 syntmp-id-569)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-573)) (syntax-error syntmp-e-561 "duplicate bound keyword in") (let ((syntmp-labels-575 (syntmp-gen-labels-108 syntmp-ids-573))) (let ((syntmp-new-w-576 (syntmp-make-binding-wrap-119 syntmp-ids-573 syntmp-labels-575 syntmp-w-563))) (syntmp-k-565 (cons syntmp-e1-571 syntmp-e2-572) (syntmp-extend-env-96 syntmp-labels-575 (let ((syntmp-w-578 (if syntmp-rec?-560 syntmp-new-w-576 syntmp-w-563)) (syntmp-trans-r-579 (syntmp-macros-only-env-98 syntmp-r-562))) (map (lambda (syntmp-x-580) (cons (quote macro) (syntmp-eval-local-transformer-145 (syntmp-chi-138 syntmp-x-580 syntmp-trans-r-579 syntmp-w-578)))) syntmp-val-570)) syntmp-r-562) syntmp-new-w-576 syntmp-s-564)))))) syntmp-tmp-567) ((lambda (syntmp-_-582) (syntax-error (syntmp-source-wrap-131 syntmp-e-561 syntmp-w-563 syntmp-s-564))) syntmp-tmp-566))) (syntax-dispatch syntmp-tmp-566 (quote (any #(each (any any)) any . each-any))))) syntmp-e-561))) (syntmp-chi-lambda-clause-143 (lambda (syntmp-e-583 syntmp-c-584 syntmp-r-585 syntmp-w-586 syntmp-k-587) ((lambda (syntmp-tmp-588) ((lambda (syntmp-tmp-589) (if syntmp-tmp-589 (apply (lambda (syntmp-id-590 syntmp-e1-591 syntmp-e2-592) (let ((syntmp-ids-593 syntmp-id-590)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-593)) (syntax-error syntmp-e-583 "invalid parameter list in") (let ((syntmp-labels-595 (syntmp-gen-labels-108 syntmp-ids-593)) (syntmp-new-vars-596 (map syntmp-gen-var-150 syntmp-ids-593))) (syntmp-k-587 syntmp-new-vars-596 (syntmp-chi-body-142 (cons syntmp-e1-591 syntmp-e2-592) syntmp-e-583 (syntmp-extend-var-env-97 syntmp-labels-595 syntmp-new-vars-596 syntmp-r-585) (syntmp-make-binding-wrap-119 syntmp-ids-593 syntmp-labels-595 syntmp-w-586))))))) syntmp-tmp-589) ((lambda (syntmp-tmp-598) (if syntmp-tmp-598 (apply (lambda (syntmp-ids-599 syntmp-e1-600 syntmp-e2-601) (let ((syntmp-old-ids-602 (syntmp-lambda-var-list-151 syntmp-ids-599))) (if (not (syntmp-valid-bound-ids?-127 syntmp-old-ids-602)) (syntax-error syntmp-e-583 "invalid parameter list in") (let ((syntmp-labels-603 (syntmp-gen-labels-108 syntmp-old-ids-602)) (syntmp-new-vars-604 (map syntmp-gen-var-150 syntmp-old-ids-602))) (syntmp-k-587 (let syntmp-f-605 ((syntmp-ls1-606 (cdr syntmp-new-vars-604)) (syntmp-ls2-607 (car syntmp-new-vars-604))) (if (null? syntmp-ls1-606) syntmp-ls2-607 (syntmp-f-605 (cdr syntmp-ls1-606) (cons (car syntmp-ls1-606) syntmp-ls2-607)))) (syntmp-chi-body-142 (cons syntmp-e1-600 syntmp-e2-601) syntmp-e-583 (syntmp-extend-var-env-97 syntmp-labels-603 syntmp-new-vars-604 syntmp-r-585) (syntmp-make-binding-wrap-119 syntmp-old-ids-602 syntmp-labels-603 syntmp-w-586))))))) syntmp-tmp-598) ((lambda (syntmp-_-609) (syntax-error syntmp-e-583)) syntmp-tmp-588))) (syntax-dispatch syntmp-tmp-588 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-588 (quote (each-any any . each-any))))) syntmp-c-584))) (syntmp-chi-body-142 (lambda (syntmp-body-610 syntmp-outer-form-611 syntmp-r-612 syntmp-w-613) (let ((syntmp-r-614 (cons (quote ("placeholder" placeholder)) syntmp-r-612))) (let ((syntmp-ribcage-615 (syntmp-make-ribcage-109 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-616 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w-613) (cons syntmp-ribcage-615 (syntmp-wrap-subst-106 syntmp-w-613))))) (let syntmp-parse-617 ((syntmp-body-618 (map (lambda (syntmp-x-624) (cons syntmp-r-614 (syntmp-wrap-130 syntmp-x-624 syntmp-w-616))) syntmp-body-610)) (syntmp-ids-619 (quote ())) (syntmp-labels-620 (quote ())) (syntmp-vars-621 (quote ())) (syntmp-vals-622 (quote ())) (syntmp-bindings-623 (quote ()))) (if (null? syntmp-body-618) (syntax-error syntmp-outer-form-611 "no expressions in body") (let ((syntmp-e-625 (cdar syntmp-body-618)) (syntmp-er-626 (caar syntmp-body-618))) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-625 syntmp-er-626 (quote (())) #f syntmp-ribcage-615)) (lambda (syntmp-type-627 syntmp-value-628 syntmp-e-629 syntmp-w-630 syntmp-s-631) (let ((syntmp-t-632 syntmp-type-627)) (if (memv syntmp-t-632 (quote (define-form))) (let ((syntmp-id-633 (syntmp-wrap-130 syntmp-value-628 syntmp-w-630)) (syntmp-label-634 (syntmp-gen-label-107))) (let ((syntmp-var-635 (syntmp-gen-var-150 syntmp-id-633))) (begin (syntmp-extend-ribcage!-118 syntmp-ribcage-615 syntmp-id-633 syntmp-label-634) (syntmp-parse-617 (cdr syntmp-body-618) (cons syntmp-id-633 syntmp-ids-619) (cons syntmp-label-634 syntmp-labels-620) (cons syntmp-var-635 syntmp-vars-621) (cons (cons syntmp-er-626 (syntmp-wrap-130 syntmp-e-629 syntmp-w-630)) syntmp-vals-622) (cons (cons (quote lexical) syntmp-var-635) syntmp-bindings-623))))) (if (memv syntmp-t-632 (quote (define-syntax-form))) (let ((syntmp-id-636 (syntmp-wrap-130 syntmp-value-628 syntmp-w-630)) (syntmp-label-637 (syntmp-gen-label-107))) (begin (syntmp-extend-ribcage!-118 syntmp-ribcage-615 syntmp-id-636 syntmp-label-637) (syntmp-parse-617 (cdr syntmp-body-618) (cons syntmp-id-636 syntmp-ids-619) (cons syntmp-label-637 syntmp-labels-620) syntmp-vars-621 syntmp-vals-622 (cons (cons (quote macro) (cons syntmp-er-626 (syntmp-wrap-130 syntmp-e-629 syntmp-w-630))) syntmp-bindings-623)))) (if (memv syntmp-t-632 (quote (begin-form))) ((lambda (syntmp-tmp-638) ((lambda (syntmp-tmp-639) (if syntmp-tmp-639 (apply (lambda (syntmp-_-640 syntmp-e1-641) (syntmp-parse-617 (let syntmp-f-642 ((syntmp-forms-643 syntmp-e1-641)) (if (null? syntmp-forms-643) (cdr syntmp-body-618) (cons (cons syntmp-er-626 (syntmp-wrap-130 (car syntmp-forms-643) syntmp-w-630)) (syntmp-f-642 (cdr syntmp-forms-643))))) syntmp-ids-619 syntmp-labels-620 syntmp-vars-621 syntmp-vals-622 syntmp-bindings-623)) syntmp-tmp-639) (syntax-error syntmp-tmp-638))) (syntax-dispatch syntmp-tmp-638 (quote (any . each-any))))) syntmp-e-629) (if (memv syntmp-t-632 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-628 syntmp-e-629 syntmp-er-626 syntmp-w-630 syntmp-s-631 (lambda (syntmp-forms-645 syntmp-er-646 syntmp-w-647 syntmp-s-648) (syntmp-parse-617 (let syntmp-f-649 ((syntmp-forms-650 syntmp-forms-645)) (if (null? syntmp-forms-650) (cdr syntmp-body-618) (cons (cons syntmp-er-646 (syntmp-wrap-130 (car syntmp-forms-650) syntmp-w-647)) (syntmp-f-649 (cdr syntmp-forms-650))))) syntmp-ids-619 syntmp-labels-620 syntmp-vars-621 syntmp-vals-622 syntmp-bindings-623))) (if (null? syntmp-ids-619) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-651) (syntmp-chi-138 (cdr syntmp-x-651) (car syntmp-x-651) (quote (())))) (cons (cons syntmp-er-626 (syntmp-source-wrap-131 syntmp-e-629 syntmp-w-630 syntmp-s-631)) (cdr syntmp-body-618)))) (begin (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-619)) (syntax-error syntmp-outer-form-611 "invalid or duplicate identifier in definition")) (let syntmp-loop-652 ((syntmp-bs-653 syntmp-bindings-623) (syntmp-er-cache-654 #f) (syntmp-r-cache-655 #f)) (if (not (null? syntmp-bs-653)) (let ((syntmp-b-656 (car syntmp-bs-653))) (if (eq? (car syntmp-b-656) (quote macro)) (let ((syntmp-er-657 (cadr syntmp-b-656))) (let ((syntmp-r-cache-658 (if (eq? syntmp-er-657 syntmp-er-cache-654) syntmp-r-cache-655 (syntmp-macros-only-env-98 syntmp-er-657)))) (begin (set-cdr! syntmp-b-656 (syntmp-eval-local-transformer-145 (syntmp-chi-138 (cddr syntmp-b-656) syntmp-r-cache-658 (quote (()))))) (syntmp-loop-652 (cdr syntmp-bs-653) syntmp-er-657 syntmp-r-cache-658)))) (syntmp-loop-652 (cdr syntmp-bs-653) syntmp-er-cache-654 syntmp-r-cache-655))))) (set-cdr! syntmp-r-614 (syntmp-extend-env-96 syntmp-labels-620 syntmp-bindings-623 (cdr syntmp-r-614))) (syntmp-build-letrec-86 #f syntmp-vars-621 (map (lambda (syntmp-x-659) (syntmp-chi-138 (cdr syntmp-x-659) (car syntmp-x-659) (quote (())))) syntmp-vals-622) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-660) (syntmp-chi-138 (cdr syntmp-x-660) (car syntmp-x-660) (quote (())))) (cons (cons syntmp-er-626 (syntmp-source-wrap-131 syntmp-e-629 syntmp-w-630 syntmp-s-631)) (cdr syntmp-body-618)))))))))))))))))))))) (syntmp-chi-macro-141 (lambda (syntmp-p-661 syntmp-e-662 syntmp-r-663 syntmp-w-664 syntmp-rib-665) (letrec ((syntmp-rebuild-macro-output-666 (lambda (syntmp-x-667 syntmp-m-668) (cond ((pair? syntmp-x-667) (cons (syntmp-rebuild-macro-output-666 (car syntmp-x-667) syntmp-m-668) (syntmp-rebuild-macro-output-666 (cdr syntmp-x-667) syntmp-m-668))) ((syntmp-syntax-object?-88 syntmp-x-667) (let ((syntmp-w-669 (syntmp-syntax-object-wrap-90 syntmp-x-667))) (let ((syntmp-ms-670 (syntmp-wrap-marks-105 syntmp-w-669)) (syntmp-s-671 (syntmp-wrap-subst-106 syntmp-w-669))) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-667) (if (and (pair? syntmp-ms-670) (eq? (car syntmp-ms-670) #f)) (syntmp-make-wrap-104 (cdr syntmp-ms-670) (if syntmp-rib-665 (cons syntmp-rib-665 (cdr syntmp-s-671)) (cdr syntmp-s-671))) (syntmp-make-wrap-104 (cons syntmp-m-668 syntmp-ms-670) (if syntmp-rib-665 (cons syntmp-rib-665 (cons (quote shift) syntmp-s-671)) (cons (quote shift) syntmp-s-671)))))))) ((vector? syntmp-x-667) (let ((syntmp-n-672 (vector-length syntmp-x-667))) (let ((syntmp-v-673 (make-vector syntmp-n-672))) (let syntmp-doloop-674 ((syntmp-i-675 0)) (if (syntmp-fx=-74 syntmp-i-675 syntmp-n-672) syntmp-v-673 (begin (vector-set! syntmp-v-673 syntmp-i-675 (syntmp-rebuild-macro-output-666 (vector-ref syntmp-x-667 syntmp-i-675) syntmp-m-668)) (syntmp-doloop-674 (syntmp-fx+-72 syntmp-i-675 1)))))))) ((symbol? syntmp-x-667) (syntax-error syntmp-x-667 "encountered raw symbol in macro output")) (else syntmp-x-667))))) (syntmp-rebuild-macro-output-666 (syntmp-p-661 (syntmp-wrap-130 syntmp-e-662 (syntmp-anti-mark-117 syntmp-w-664))) (string #\m))))) (syntmp-chi-application-140 (lambda (syntmp-x-676 syntmp-e-677 syntmp-r-678 syntmp-w-679 syntmp-s-680) ((lambda (syntmp-tmp-681) ((lambda (syntmp-tmp-682) (if syntmp-tmp-682 (apply (lambda (syntmp-e0-683 syntmp-e1-684) (syntmp-build-annotated-81 syntmp-s-680 (cons syntmp-x-676 (map (lambda (syntmp-e-685) (syntmp-chi-138 syntmp-e-685 syntmp-r-678 syntmp-w-679)) syntmp-e1-684)))) syntmp-tmp-682) (syntax-error syntmp-tmp-681))) (syntax-dispatch syntmp-tmp-681 (quote (any . each-any))))) syntmp-e-677))) (syntmp-chi-expr-139 (lambda (syntmp-type-687 syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (let ((syntmp-t-693 syntmp-type-687)) (if (memv syntmp-t-693 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-692 syntmp-value-688) (if (memv syntmp-t-693 (quote (core external-macro))) (syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (lexical-call))) (syntmp-chi-application-140 (syntmp-build-annotated-81 (syntmp-source-annotation-93 (car syntmp-e-689)) syntmp-value-688) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (global-call))) (syntmp-chi-application-140 (syntmp-build-annotated-81 (syntmp-source-annotation-93 (car syntmp-e-689)) syntmp-value-688) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (constant))) (syntmp-build-data-82 syntmp-s-692 (syntmp-strip-149 (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) (quote (())))) (if (memv syntmp-t-693 (quote (global))) (syntmp-build-annotated-81 syntmp-s-692 syntmp-value-688) (if (memv syntmp-t-693 (quote (call))) (syntmp-chi-application-140 (syntmp-chi-138 (car syntmp-e-689) syntmp-r-690 syntmp-w-691) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (begin-form))) ((lambda (syntmp-tmp-694) ((lambda (syntmp-tmp-695) (if syntmp-tmp-695 (apply (lambda (syntmp-_-696 syntmp-e1-697 syntmp-e2-698) (syntmp-chi-sequence-132 (cons syntmp-e1-697 syntmp-e2-698) syntmp-r-690 syntmp-w-691 syntmp-s-692)) syntmp-tmp-695) (syntax-error syntmp-tmp-694))) (syntax-dispatch syntmp-tmp-694 (quote (any any . each-any))))) syntmp-e-689) (if (memv syntmp-t-693 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692 syntmp-chi-sequence-132) (if (memv syntmp-t-693 (quote (eval-when-form))) ((lambda (syntmp-tmp-700) ((lambda (syntmp-tmp-701) (if syntmp-tmp-701 (apply (lambda (syntmp-_-702 syntmp-x-703 syntmp-e1-704 syntmp-e2-705) (let ((syntmp-when-list-706 (syntmp-chi-when-list-135 syntmp-e-689 syntmp-x-703 syntmp-w-691))) (if (memq (quote eval) syntmp-when-list-706) (syntmp-chi-sequence-132 (cons syntmp-e1-704 syntmp-e2-705) syntmp-r-690 syntmp-w-691 syntmp-s-692) (syntmp-chi-void-146)))) syntmp-tmp-701) (syntax-error syntmp-tmp-700))) (syntax-dispatch syntmp-tmp-700 (quote (any each-any any . each-any))))) syntmp-e-689) (if (memv syntmp-t-693 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-130 syntmp-value-688 syntmp-w-691) "invalid context for definition of") (if (memv syntmp-t-693 (quote (syntax))) (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) "reference to pattern variable outside syntax form") (if (memv syntmp-t-693 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692)))))))))))))))))) (syntmp-chi-138 (lambda (syntmp-e-709 syntmp-r-710 syntmp-w-711) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-709 syntmp-r-710 syntmp-w-711 #f #f)) (lambda (syntmp-type-712 syntmp-value-713 syntmp-e-714 syntmp-w-715 syntmp-s-716) (syntmp-chi-expr-139 syntmp-type-712 syntmp-value-713 syntmp-e-714 syntmp-r-710 syntmp-w-715 syntmp-s-716))))) (syntmp-chi-top-137 (lambda (syntmp-e-717 syntmp-r-718 syntmp-w-719 syntmp-m-720 syntmp-esew-721) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-717 syntmp-r-718 syntmp-w-719 #f #f)) (lambda (syntmp-type-734 syntmp-value-735 syntmp-e-736 syntmp-w-737 syntmp-s-738) (let ((syntmp-t-739 syntmp-type-734)) (if (memv syntmp-t-739 (quote (begin-form))) ((lambda (syntmp-tmp-740) ((lambda (syntmp-tmp-741) (if syntmp-tmp-741 (apply (lambda (syntmp-_-742) (syntmp-chi-void-146)) syntmp-tmp-741) ((lambda (syntmp-tmp-743) (if syntmp-tmp-743 (apply (lambda (syntmp-_-744 syntmp-e1-745 syntmp-e2-746) (syntmp-chi-top-sequence-133 (cons syntmp-e1-745 syntmp-e2-746) syntmp-r-718 syntmp-w-737 syntmp-s-738 syntmp-m-720 syntmp-esew-721)) syntmp-tmp-743) (syntax-error syntmp-tmp-740))) (syntax-dispatch syntmp-tmp-740 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-740 (quote (any))))) syntmp-e-736) (if (memv syntmp-t-739 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-735 syntmp-e-736 syntmp-r-718 syntmp-w-737 syntmp-s-738 (lambda (syntmp-body-748 syntmp-r-749 syntmp-w-750 syntmp-s-751) (syntmp-chi-top-sequence-133 syntmp-body-748 syntmp-r-749 syntmp-w-750 syntmp-s-751 syntmp-m-720 syntmp-esew-721))) (if (memv syntmp-t-739 (quote (eval-when-form))) ((lambda (syntmp-tmp-752) ((lambda (syntmp-tmp-753) (if syntmp-tmp-753 (apply (lambda (syntmp-_-754 syntmp-x-755 syntmp-e1-756 syntmp-e2-757) (let ((syntmp-when-list-758 (syntmp-chi-when-list-135 syntmp-e-736 syntmp-x-755 syntmp-w-737)) (syntmp-body-759 (cons syntmp-e1-756 syntmp-e2-757))) (cond ((eq? syntmp-m-720 (quote e)) (if (memq (quote eval) syntmp-when-list-758) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote e) (quote (eval))) (syntmp-chi-void-146))) ((memq (quote load) syntmp-when-list-758) (if (or (memq (quote compile) syntmp-when-list-758) (and (eq? syntmp-m-720 (quote c&e)) (memq (quote eval) syntmp-when-list-758))) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote c&e) (quote (compile load))) (if (memq syntmp-m-720 (quote (c c&e))) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote c) (quote (load))) (syntmp-chi-void-146)))) ((or (memq (quote compile) syntmp-when-list-758) (and (eq? syntmp-m-720 (quote c&e)) (memq (quote eval) syntmp-when-list-758))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote e) (quote (eval)))) (syntmp-chi-void-146)) (else (syntmp-chi-void-146))))) syntmp-tmp-753) (syntax-error syntmp-tmp-752))) (syntax-dispatch syntmp-tmp-752 (quote (any each-any any . each-any))))) syntmp-e-736) (if (memv syntmp-t-739 (quote (define-syntax-form))) (let ((syntmp-n-762 (syntmp-id-var-name-124 syntmp-value-735 syntmp-w-737)) (syntmp-r-763 (syntmp-macros-only-env-98 syntmp-r-718))) (let ((syntmp-t-764 syntmp-m-720)) (if (memv syntmp-t-764 (quote (c))) (if (memq (quote compile) syntmp-esew-721) (let ((syntmp-e-765 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-765) (if (memq (quote load) syntmp-esew-721) syntmp-e-765 (syntmp-chi-void-146)))) (if (memq (quote load) syntmp-esew-721) (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)) (syntmp-chi-void-146))) (if (memv syntmp-t-764 (quote (c&e))) (let ((syntmp-e-766 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-766) syntmp-e-766)) (begin (if (memq (quote eval) syntmp-esew-721) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (syntmp-chi-void-146)))))) (if (memv syntmp-t-739 (quote (define-form))) (let ((syntmp-n-767 (syntmp-id-var-name-124 syntmp-value-735 syntmp-w-737))) (let ((syntmp-type-768 (syntmp-binding-type-94 (syntmp-lookup-99 syntmp-n-767 syntmp-r-718)))) (let ((syntmp-t-769 syntmp-type-768)) (if (memv syntmp-t-769 (quote (global))) (let ((syntmp-x-770 (syntmp-build-annotated-81 syntmp-s-738 (list (quote define) syntmp-n-767 (syntmp-chi-138 syntmp-e-736 syntmp-r-718 syntmp-w-737))))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-770)) syntmp-x-770)) (if (memv syntmp-t-769 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-130 syntmp-value-735 syntmp-w-737) "identifier out of context") (if (eq? syntmp-type-768 (quote external-macro)) (let ((syntmp-x-771 (syntmp-build-annotated-81 syntmp-s-738 (list (quote define) syntmp-n-767 (syntmp-chi-138 syntmp-e-736 syntmp-r-718 syntmp-w-737))))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-771)) syntmp-x-771)) (syntax-error (syntmp-wrap-130 syntmp-value-735 syntmp-w-737) "cannot define keyword at top level"))))))) (let ((syntmp-x-772 (syntmp-chi-expr-139 syntmp-type-734 syntmp-value-735 syntmp-e-736 syntmp-r-718 syntmp-w-737 syntmp-s-738))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-772)) syntmp-x-772)))))))))))) (syntmp-syntax-type-136 (lambda (syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-rib-777) (cond ((symbol? syntmp-e-773) (let ((syntmp-n-778 (syntmp-id-var-name-124 syntmp-e-773 syntmp-w-775))) (let ((syntmp-b-779 (syntmp-lookup-99 syntmp-n-778 syntmp-r-774))) (let ((syntmp-type-780 (syntmp-binding-type-94 syntmp-b-779))) (let ((syntmp-t-781 syntmp-type-780)) (if (memv syntmp-t-781 (quote (lexical))) (values syntmp-type-780 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-781 (quote (global))) (values syntmp-type-780 syntmp-n-778 syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-781 (quote (macro))) (syntmp-syntax-type-136 (syntmp-chi-macro-141 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-rib-777) syntmp-r-774 (quote (())) syntmp-s-776 syntmp-rib-777) (values syntmp-type-780 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-w-775 syntmp-s-776))))))))) ((pair? syntmp-e-773) (let ((syntmp-first-782 (car syntmp-e-773))) (if (syntmp-id?-102 syntmp-first-782) (let ((syntmp-n-783 (syntmp-id-var-name-124 syntmp-first-782 syntmp-w-775))) (let ((syntmp-b-784 (syntmp-lookup-99 syntmp-n-783 syntmp-r-774))) (let ((syntmp-type-785 (syntmp-binding-type-94 syntmp-b-784))) (let ((syntmp-t-786 syntmp-type-785)) (if (memv syntmp-t-786 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (global))) (values (quote global-call) syntmp-n-783 syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (macro))) (syntmp-syntax-type-136 (syntmp-chi-macro-141 (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-rib-777) syntmp-r-774 (quote (())) syntmp-s-776 syntmp-rib-777) (if (memv syntmp-t-786 (quote (core external-macro))) (values syntmp-type-785 (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (begin))) (values (quote begin-form) #f syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (define))) ((lambda (syntmp-tmp-787) ((lambda (syntmp-tmp-788) (if (if syntmp-tmp-788 (apply (lambda (syntmp-_-789 syntmp-name-790 syntmp-val-791) (syntmp-id?-102 syntmp-name-790)) syntmp-tmp-788) #f) (apply (lambda (syntmp-_-792 syntmp-name-793 syntmp-val-794) (values (quote define-form) syntmp-name-793 syntmp-val-794 syntmp-w-775 syntmp-s-776)) syntmp-tmp-788) ((lambda (syntmp-tmp-795) (if (if syntmp-tmp-795 (apply (lambda (syntmp-_-796 syntmp-name-797 syntmp-args-798 syntmp-e1-799 syntmp-e2-800) (and (syntmp-id?-102 syntmp-name-797) (syntmp-valid-bound-ids?-127 (syntmp-lambda-var-list-151 syntmp-args-798)))) syntmp-tmp-795) #f) (apply (lambda (syntmp-_-801 syntmp-name-802 syntmp-args-803 syntmp-e1-804 syntmp-e2-805) (values (quote define-form) (syntmp-wrap-130 syntmp-name-802 syntmp-w-775) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-130 (cons syntmp-args-803 (cons syntmp-e1-804 syntmp-e2-805)) syntmp-w-775)) (quote (())) syntmp-s-776)) syntmp-tmp-795) ((lambda (syntmp-tmp-807) (if (if syntmp-tmp-807 (apply (lambda (syntmp-_-808 syntmp-name-809) (syntmp-id?-102 syntmp-name-809)) syntmp-tmp-807) #f) (apply (lambda (syntmp-_-810 syntmp-name-811) (values (quote define-form) (syntmp-wrap-130 syntmp-name-811 syntmp-w-775) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-776)) syntmp-tmp-807) (syntax-error syntmp-tmp-787))) (syntax-dispatch syntmp-tmp-787 (quote (any any)))))) (syntax-dispatch syntmp-tmp-787 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-787 (quote (any any any))))) syntmp-e-773) (if (memv syntmp-t-786 (quote (define-syntax))) ((lambda (syntmp-tmp-812) ((lambda (syntmp-tmp-813) (if (if syntmp-tmp-813 (apply (lambda (syntmp-_-814 syntmp-name-815 syntmp-val-816) (syntmp-id?-102 syntmp-name-815)) syntmp-tmp-813) #f) (apply (lambda (syntmp-_-817 syntmp-name-818 syntmp-val-819) (values (quote define-syntax-form) syntmp-name-818 syntmp-val-819 syntmp-w-775 syntmp-s-776)) syntmp-tmp-813) (syntax-error syntmp-tmp-812))) (syntax-dispatch syntmp-tmp-812 (quote (any any any))))) syntmp-e-773) (values (quote call) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)))))))))))))) (values (quote call) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)))) ((syntmp-syntax-object?-88 syntmp-e-773) (syntmp-syntax-type-136 (syntmp-syntax-object-expression-89 syntmp-e-773) syntmp-r-774 (syntmp-join-wraps-121 syntmp-w-775 (syntmp-syntax-object-wrap-90 syntmp-e-773)) #f syntmp-rib-777)) ((annotation? syntmp-e-773) (syntmp-syntax-type-136 (annotation-expression syntmp-e-773) syntmp-r-774 syntmp-w-775 (annotation-source syntmp-e-773) syntmp-rib-777)) ((self-evaluating? syntmp-e-773) (values (quote constant) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)) (else (values (quote other) #f syntmp-e-773 syntmp-w-775 syntmp-s-776))))) (syntmp-chi-when-list-135 (lambda (syntmp-e-820 syntmp-when-list-821 syntmp-w-822) (let syntmp-f-823 ((syntmp-when-list-824 syntmp-when-list-821) (syntmp-situations-825 (quote ()))) (if (null? syntmp-when-list-824) syntmp-situations-825 (syntmp-f-823 (cdr syntmp-when-list-824) (cons (let ((syntmp-x-826 (car syntmp-when-list-824))) (cond ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-130 syntmp-x-826 syntmp-w-822) "invalid eval-when situation")))) syntmp-situations-825)))))) (syntmp-chi-install-global-134 (lambda (syntmp-name-827 syntmp-e-828) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-827) syntmp-e-828)))) (syntmp-chi-top-sequence-133 (lambda (syntmp-body-829 syntmp-r-830 syntmp-w-831 syntmp-s-832 syntmp-m-833 syntmp-esew-834) (syntmp-build-sequence-83 syntmp-s-832 (let syntmp-dobody-835 ((syntmp-body-836 syntmp-body-829) (syntmp-r-837 syntmp-r-830) (syntmp-w-838 syntmp-w-831) (syntmp-m-839 syntmp-m-833) (syntmp-esew-840 syntmp-esew-834)) (if (null? syntmp-body-836) (quote ()) (let ((syntmp-first-841 (syntmp-chi-top-137 (car syntmp-body-836) syntmp-r-837 syntmp-w-838 syntmp-m-839 syntmp-esew-840))) (cons syntmp-first-841 (syntmp-dobody-835 (cdr syntmp-body-836) syntmp-r-837 syntmp-w-838 syntmp-m-839 syntmp-esew-840)))))))) (syntmp-chi-sequence-132 (lambda (syntmp-body-842 syntmp-r-843 syntmp-w-844 syntmp-s-845) (syntmp-build-sequence-83 syntmp-s-845 (let syntmp-dobody-846 ((syntmp-body-847 syntmp-body-842) (syntmp-r-848 syntmp-r-843) (syntmp-w-849 syntmp-w-844)) (if (null? syntmp-body-847) (quote ()) (let ((syntmp-first-850 (syntmp-chi-138 (car syntmp-body-847) syntmp-r-848 syntmp-w-849))) (cons syntmp-first-850 (syntmp-dobody-846 (cdr syntmp-body-847) syntmp-r-848 syntmp-w-849)))))))) (syntmp-source-wrap-131 (lambda (syntmp-x-851 syntmp-w-852 syntmp-s-853) (syntmp-wrap-130 (if syntmp-s-853 (make-annotation syntmp-x-851 syntmp-s-853 #f) syntmp-x-851) syntmp-w-852))) (syntmp-wrap-130 (lambda (syntmp-x-854 syntmp-w-855) (cond ((and (null? (syntmp-wrap-marks-105 syntmp-w-855)) (null? (syntmp-wrap-subst-106 syntmp-w-855))) syntmp-x-854) ((syntmp-syntax-object?-88 syntmp-x-854) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-854) (syntmp-join-wraps-121 syntmp-w-855 (syntmp-syntax-object-wrap-90 syntmp-x-854)))) ((null? syntmp-x-854) syntmp-x-854) (else (syntmp-make-syntax-object-87 syntmp-x-854 syntmp-w-855))))) (syntmp-bound-id-member?-129 (lambda (syntmp-x-856 syntmp-list-857) (and (not (null? syntmp-list-857)) (or (syntmp-bound-id=?-126 syntmp-x-856 (car syntmp-list-857)) (syntmp-bound-id-member?-129 syntmp-x-856 (cdr syntmp-list-857)))))) (syntmp-distinct-bound-ids?-128 (lambda (syntmp-ids-858) (let syntmp-distinct?-859 ((syntmp-ids-860 syntmp-ids-858)) (or (null? syntmp-ids-860) (and (not (syntmp-bound-id-member?-129 (car syntmp-ids-860) (cdr syntmp-ids-860))) (syntmp-distinct?-859 (cdr syntmp-ids-860))))))) (syntmp-valid-bound-ids?-127 (lambda (syntmp-ids-861) (and (let syntmp-all-ids?-862 ((syntmp-ids-863 syntmp-ids-861)) (or (null? syntmp-ids-863) (and (syntmp-id?-102 (car syntmp-ids-863)) (syntmp-all-ids?-862 (cdr syntmp-ids-863))))) (syntmp-distinct-bound-ids?-128 syntmp-ids-861)))) (syntmp-bound-id=?-126 (lambda (syntmp-i-864 syntmp-j-865) (if (and (syntmp-syntax-object?-88 syntmp-i-864) (syntmp-syntax-object?-88 syntmp-j-865)) (and (eq? (let ((syntmp-e-866 (syntmp-syntax-object-expression-89 syntmp-i-864))) (if (annotation? syntmp-e-866) (annotation-expression syntmp-e-866) syntmp-e-866)) (let ((syntmp-e-867 (syntmp-syntax-object-expression-89 syntmp-j-865))) (if (annotation? syntmp-e-867) (annotation-expression syntmp-e-867) syntmp-e-867))) (syntmp-same-marks?-123 (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-i-864)) (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-j-865)))) (eq? (let ((syntmp-e-868 syntmp-i-864)) (if (annotation? syntmp-e-868) (annotation-expression syntmp-e-868) syntmp-e-868)) (let ((syntmp-e-869 syntmp-j-865)) (if (annotation? syntmp-e-869) (annotation-expression syntmp-e-869) syntmp-e-869)))))) (syntmp-free-id=?-125 (lambda (syntmp-i-870 syntmp-j-871) (and (eq? (let ((syntmp-x-872 syntmp-i-870)) (let ((syntmp-e-873 (if (syntmp-syntax-object?-88 syntmp-x-872) (syntmp-syntax-object-expression-89 syntmp-x-872) syntmp-x-872))) (if (annotation? syntmp-e-873) (annotation-expression syntmp-e-873) syntmp-e-873))) (let ((syntmp-x-874 syntmp-j-871)) (let ((syntmp-e-875 (if (syntmp-syntax-object?-88 syntmp-x-874) (syntmp-syntax-object-expression-89 syntmp-x-874) syntmp-x-874))) (if (annotation? syntmp-e-875) (annotation-expression syntmp-e-875) syntmp-e-875)))) (eq? (syntmp-id-var-name-124 syntmp-i-870 (quote (()))) (syntmp-id-var-name-124 syntmp-j-871 (quote (()))))))) (syntmp-id-var-name-124 (lambda (syntmp-id-876 syntmp-w-877) (letrec ((syntmp-search-vector-rib-880 (lambda (syntmp-sym-891 syntmp-subst-892 syntmp-marks-893 syntmp-symnames-894 syntmp-ribcage-895) (let ((syntmp-n-896 (vector-length syntmp-symnames-894))) (let syntmp-f-897 ((syntmp-i-898 0)) (cond ((syntmp-fx=-74 syntmp-i-898 syntmp-n-896) (syntmp-search-878 syntmp-sym-891 (cdr syntmp-subst-892) syntmp-marks-893)) ((and (eq? (vector-ref syntmp-symnames-894 syntmp-i-898) syntmp-sym-891) (syntmp-same-marks?-123 syntmp-marks-893 (vector-ref (syntmp-ribcage-marks-112 syntmp-ribcage-895) syntmp-i-898))) (values (vector-ref (syntmp-ribcage-labels-113 syntmp-ribcage-895) syntmp-i-898) syntmp-marks-893)) (else (syntmp-f-897 (syntmp-fx+-72 syntmp-i-898 1)))))))) (syntmp-search-list-rib-879 (lambda (syntmp-sym-899 syntmp-subst-900 syntmp-marks-901 syntmp-symnames-902 syntmp-ribcage-903) (let syntmp-f-904 ((syntmp-symnames-905 syntmp-symnames-902) (syntmp-i-906 0)) (cond ((null? syntmp-symnames-905) (syntmp-search-878 syntmp-sym-899 (cdr syntmp-subst-900) syntmp-marks-901)) ((and (eq? (car syntmp-symnames-905) syntmp-sym-899) (syntmp-same-marks?-123 syntmp-marks-901 (list-ref (syntmp-ribcage-marks-112 syntmp-ribcage-903) syntmp-i-906))) (values (list-ref (syntmp-ribcage-labels-113 syntmp-ribcage-903) syntmp-i-906) syntmp-marks-901)) (else (syntmp-f-904 (cdr syntmp-symnames-905) (syntmp-fx+-72 syntmp-i-906 1))))))) (syntmp-search-878 (lambda (syntmp-sym-907 syntmp-subst-908 syntmp-marks-909) (if (null? syntmp-subst-908) (values #f syntmp-marks-909) (let ((syntmp-fst-910 (car syntmp-subst-908))) (if (eq? syntmp-fst-910 (quote shift)) (syntmp-search-878 syntmp-sym-907 (cdr syntmp-subst-908) (cdr syntmp-marks-909)) (let ((syntmp-symnames-911 (syntmp-ribcage-symnames-111 syntmp-fst-910))) (if (vector? syntmp-symnames-911) (syntmp-search-vector-rib-880 syntmp-sym-907 syntmp-subst-908 syntmp-marks-909 syntmp-symnames-911 syntmp-fst-910) (syntmp-search-list-rib-879 syntmp-sym-907 syntmp-subst-908 syntmp-marks-909 syntmp-symnames-911 syntmp-fst-910))))))))) (cond ((symbol? syntmp-id-876) (or (call-with-values (lambda () (syntmp-search-878 syntmp-id-876 (syntmp-wrap-subst-106 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w-877))) (lambda (syntmp-x-913 . syntmp-ignore-912) syntmp-x-913)) syntmp-id-876)) ((syntmp-syntax-object?-88 syntmp-id-876) (let ((syntmp-id-914 (let ((syntmp-e-916 (syntmp-syntax-object-expression-89 syntmp-id-876))) (if (annotation? syntmp-e-916) (annotation-expression syntmp-e-916) syntmp-e-916))) (syntmp-w1-915 (syntmp-syntax-object-wrap-90 syntmp-id-876))) (let ((syntmp-marks-917 (syntmp-join-marks-122 (syntmp-wrap-marks-105 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w1-915)))) (call-with-values (lambda () (syntmp-search-878 syntmp-id-914 (syntmp-wrap-subst-106 syntmp-w-877) syntmp-marks-917)) (lambda (syntmp-new-id-918 syntmp-marks-919) (or syntmp-new-id-918 (call-with-values (lambda () (syntmp-search-878 syntmp-id-914 (syntmp-wrap-subst-106 syntmp-w1-915) syntmp-marks-919)) (lambda (syntmp-x-921 . syntmp-ignore-920) syntmp-x-921)) syntmp-id-914)))))) ((annotation? syntmp-id-876) (let ((syntmp-id-922 (let ((syntmp-e-923 syntmp-id-876)) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)))) (or (call-with-values (lambda () (syntmp-search-878 syntmp-id-922 (syntmp-wrap-subst-106 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w-877))) (lambda (syntmp-x-925 . syntmp-ignore-924) syntmp-x-925)) syntmp-id-922))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-876)))))) (syntmp-same-marks?-123 (lambda (syntmp-x-926 syntmp-y-927) (or (eq? syntmp-x-926 syntmp-y-927) (and (not (null? syntmp-x-926)) (not (null? syntmp-y-927)) (eq? (car syntmp-x-926) (car syntmp-y-927)) (syntmp-same-marks?-123 (cdr syntmp-x-926) (cdr syntmp-y-927)))))) (syntmp-join-marks-122 (lambda (syntmp-m1-928 syntmp-m2-929) (syntmp-smart-append-120 syntmp-m1-928 syntmp-m2-929))) (syntmp-join-wraps-121 (lambda (syntmp-w1-930 syntmp-w2-931) (let ((syntmp-m1-932 (syntmp-wrap-marks-105 syntmp-w1-930)) (syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w1-930))) (if (null? syntmp-m1-932) (if (null? syntmp-s1-933) syntmp-w2-931 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w2-931) (syntmp-smart-append-120 syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w2-931)))) (syntmp-make-wrap-104 (syntmp-smart-append-120 syntmp-m1-932 (syntmp-wrap-marks-105 syntmp-w2-931)) (syntmp-smart-append-120 syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w2-931))))))) (syntmp-smart-append-120 (lambda (syntmp-m1-934 syntmp-m2-935) (if (null? syntmp-m2-935) syntmp-m1-934 (append syntmp-m1-934 syntmp-m2-935)))) (syntmp-make-binding-wrap-119 (lambda (syntmp-ids-936 syntmp-labels-937 syntmp-w-938) (if (null? syntmp-ids-936) syntmp-w-938 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w-938) (cons (let ((syntmp-labelvec-939 (list->vector syntmp-labels-937))) (let ((syntmp-n-940 (vector-length syntmp-labelvec-939))) (let ((syntmp-symnamevec-941 (make-vector syntmp-n-940)) (syntmp-marksvec-942 (make-vector syntmp-n-940))) (begin (let syntmp-f-943 ((syntmp-ids-944 syntmp-ids-936) (syntmp-i-945 0)) (if (not (null? syntmp-ids-944)) (call-with-values (lambda () (syntmp-id-sym-name&marks-103 (car syntmp-ids-944) syntmp-w-938)) (lambda (syntmp-symname-946 syntmp-marks-947) (begin (vector-set! syntmp-symnamevec-941 syntmp-i-945 syntmp-symname-946) (vector-set! syntmp-marksvec-942 syntmp-i-945 syntmp-marks-947) (syntmp-f-943 (cdr syntmp-ids-944) (syntmp-fx+-72 syntmp-i-945 1))))))) (syntmp-make-ribcage-109 syntmp-symnamevec-941 syntmp-marksvec-942 syntmp-labelvec-939))))) (syntmp-wrap-subst-106 syntmp-w-938)))))) (syntmp-extend-ribcage!-118 (lambda (syntmp-ribcage-948 syntmp-id-949 syntmp-label-950) (begin (syntmp-set-ribcage-symnames!-114 syntmp-ribcage-948 (cons (let ((syntmp-e-951 (syntmp-syntax-object-expression-89 syntmp-id-949))) (if (annotation? syntmp-e-951) (annotation-expression syntmp-e-951) syntmp-e-951)) (syntmp-ribcage-symnames-111 syntmp-ribcage-948))) (syntmp-set-ribcage-marks!-115 syntmp-ribcage-948 (cons (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-id-949)) (syntmp-ribcage-marks-112 syntmp-ribcage-948))) (syntmp-set-ribcage-labels!-116 syntmp-ribcage-948 (cons syntmp-label-950 (syntmp-ribcage-labels-113 syntmp-ribcage-948)))))) (syntmp-anti-mark-117 (lambda (syntmp-w-952) (syntmp-make-wrap-104 (cons #f (syntmp-wrap-marks-105 syntmp-w-952)) (cons (quote shift) (syntmp-wrap-subst-106 syntmp-w-952))))) (syntmp-set-ribcage-labels!-116 (lambda (syntmp-x-953 syntmp-update-954) (vector-set! syntmp-x-953 3 syntmp-update-954))) (syntmp-set-ribcage-marks!-115 (lambda (syntmp-x-955 syntmp-update-956) (vector-set! syntmp-x-955 2 syntmp-update-956))) (syntmp-set-ribcage-symnames!-114 (lambda (syntmp-x-957 syntmp-update-958) (vector-set! syntmp-x-957 1 syntmp-update-958))) (syntmp-ribcage-labels-113 (lambda (syntmp-x-959) (vector-ref syntmp-x-959 3))) (syntmp-ribcage-marks-112 (lambda (syntmp-x-960) (vector-ref syntmp-x-960 2))) (syntmp-ribcage-symnames-111 (lambda (syntmp-x-961) (vector-ref syntmp-x-961 1))) (syntmp-ribcage?-110 (lambda (syntmp-x-962) (and (vector? syntmp-x-962) (= (vector-length syntmp-x-962) 4) (eq? (vector-ref syntmp-x-962 0) (quote ribcage))))) (syntmp-make-ribcage-109 (lambda (syntmp-symnames-963 syntmp-marks-964 syntmp-labels-965) (vector (quote ribcage) syntmp-symnames-963 syntmp-marks-964 syntmp-labels-965))) (syntmp-gen-labels-108 (lambda (syntmp-ls-966) (if (null? syntmp-ls-966) (quote ()) (cons (syntmp-gen-label-107) (syntmp-gen-labels-108 (cdr syntmp-ls-966)))))) (syntmp-gen-label-107 (lambda () (string #\i))) (syntmp-wrap-subst-106 cdr) (syntmp-wrap-marks-105 car) (syntmp-make-wrap-104 cons) (syntmp-id-sym-name&marks-103 (lambda (syntmp-x-967 syntmp-w-968) (if (syntmp-syntax-object?-88 syntmp-x-967) (values (let ((syntmp-e-969 (syntmp-syntax-object-expression-89 syntmp-x-967))) (if (annotation? syntmp-e-969) (annotation-expression syntmp-e-969) syntmp-e-969)) (syntmp-join-marks-122 (syntmp-wrap-marks-105 syntmp-w-968) (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-x-967)))) (values (let ((syntmp-e-970 syntmp-x-967)) (if (annotation? syntmp-e-970) (annotation-expression syntmp-e-970) syntmp-e-970)) (syntmp-wrap-marks-105 syntmp-w-968))))) (syntmp-id?-102 (lambda (syntmp-x-971) (cond ((symbol? syntmp-x-971) #t) ((syntmp-syntax-object?-88 syntmp-x-971) (symbol? (let ((syntmp-e-972 (syntmp-syntax-object-expression-89 syntmp-x-971))) (if (annotation? syntmp-e-972) (annotation-expression syntmp-e-972) syntmp-e-972)))) ((annotation? syntmp-x-971) (symbol? (annotation-expression syntmp-x-971))) (else #f)))) (syntmp-nonsymbol-id?-101 (lambda (syntmp-x-973) (and (syntmp-syntax-object?-88 syntmp-x-973) (symbol? (let ((syntmp-e-974 (syntmp-syntax-object-expression-89 syntmp-x-973))) (if (annotation? syntmp-e-974) (annotation-expression syntmp-e-974) syntmp-e-974)))))) (syntmp-global-extend-100 (lambda (syntmp-type-975 syntmp-sym-976 syntmp-val-977) (syntmp-put-global-definition-hook-79 syntmp-sym-976 (cons syntmp-type-975 syntmp-val-977)))) (syntmp-lookup-99 (lambda (syntmp-x-978 syntmp-r-979) (cond ((assq syntmp-x-978 syntmp-r-979) => cdr) ((symbol? syntmp-x-978) (or (syntmp-get-global-definition-hook-80 syntmp-x-978) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-98 (lambda (syntmp-r-980) (if (null? syntmp-r-980) (quote ()) (let ((syntmp-a-981 (car syntmp-r-980))) (if (eq? (cadr syntmp-a-981) (quote macro)) (cons syntmp-a-981 (syntmp-macros-only-env-98 (cdr syntmp-r-980))) (syntmp-macros-only-env-98 (cdr syntmp-r-980))))))) (syntmp-extend-var-env-97 (lambda (syntmp-labels-982 syntmp-vars-983 syntmp-r-984) (if (null? syntmp-labels-982) syntmp-r-984 (syntmp-extend-var-env-97 (cdr syntmp-labels-982) (cdr syntmp-vars-983) (cons (cons (car syntmp-labels-982) (cons (quote lexical) (car syntmp-vars-983))) syntmp-r-984))))) (syntmp-extend-env-96 (lambda (syntmp-labels-985 syntmp-bindings-986 syntmp-r-987) (if (null? syntmp-labels-985) syntmp-r-987 (syntmp-extend-env-96 (cdr syntmp-labels-985) (cdr syntmp-bindings-986) (cons (cons (car syntmp-labels-985) (car syntmp-bindings-986)) syntmp-r-987))))) (syntmp-binding-value-95 cdr) (syntmp-binding-type-94 car) (syntmp-source-annotation-93 (lambda (syntmp-x-988) (cond ((annotation? syntmp-x-988) (annotation-source syntmp-x-988)) ((syntmp-syntax-object?-88 syntmp-x-988) (syntmp-source-annotation-93 (syntmp-syntax-object-expression-89 syntmp-x-988))) (else #f)))) (syntmp-set-syntax-object-wrap!-92 (lambda (syntmp-x-989 syntmp-update-990) (vector-set! syntmp-x-989 2 syntmp-update-990))) (syntmp-set-syntax-object-expression!-91 (lambda (syntmp-x-991 syntmp-update-992) (vector-set! syntmp-x-991 1 syntmp-update-992))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-993) (vector-ref syntmp-x-993 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-994) (vector-ref syntmp-x-994 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (= (vector-length syntmp-x-995) 3) (eq? (vector-ref syntmp-x-995 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-996 syntmp-wrap-997) (vector (quote syntax-object) syntmp-expression-996 syntmp-wrap-997))) (syntmp-build-letrec-86 (lambda (syntmp-src-998 syntmp-vars-999 syntmp-val-exps-1000 syntmp-body-exp-1001) (if (null? syntmp-vars-999) (syntmp-build-annotated-81 syntmp-src-998 syntmp-body-exp-1001) (syntmp-build-annotated-81 syntmp-src-998 (list (quote letrec) (map list syntmp-vars-999 syntmp-val-exps-1000) syntmp-body-exp-1001))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1002 syntmp-vars-1003 syntmp-val-exps-1004 syntmp-body-exp-1005) (if (null? syntmp-vars-1003) (syntmp-build-annotated-81 syntmp-src-1002 syntmp-body-exp-1005) (syntmp-build-annotated-81 syntmp-src-1002 (list (quote let) (car syntmp-vars-1003) (map list (cdr syntmp-vars-1003) syntmp-val-exps-1004) syntmp-body-exp-1005))))) (syntmp-build-let-84 (lambda (syntmp-src-1006 syntmp-vars-1007 syntmp-val-exps-1008 syntmp-body-exp-1009) (if (null? syntmp-vars-1007) (syntmp-build-annotated-81 syntmp-src-1006 syntmp-body-exp-1009) (syntmp-build-annotated-81 syntmp-src-1006 (list (quote let) (map list syntmp-vars-1007 syntmp-val-exps-1008) syntmp-body-exp-1009))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1010 syntmp-exps-1011) (if (null? (cdr syntmp-exps-1011)) (syntmp-build-annotated-81 syntmp-src-1010 (car syntmp-exps-1011)) (syntmp-build-annotated-81 syntmp-src-1010 (cons (quote begin) syntmp-exps-1011))))) (syntmp-build-data-82 (lambda (syntmp-src-1012 syntmp-exp-1013) (if (and (self-evaluating? syntmp-exp-1013) (not (vector? syntmp-exp-1013))) (syntmp-build-annotated-81 syntmp-src-1012 syntmp-exp-1013) (syntmp-build-annotated-81 syntmp-src-1012 (list (quote quote) syntmp-exp-1013))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1014 syntmp-exp-1015) (if (and syntmp-src-1014 (not (annotation? syntmp-exp-1015))) (make-annotation syntmp-exp-1015 syntmp-src-1014 #t) syntmp-exp-1015))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1016) (getprop syntmp-symbol-1016 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1017 syntmp-binding-1018) (putprop syntmp-symbol-1017 (quote *sc-expander*) syntmp-binding-1018))) (syntmp-error-hook-78 (lambda (syntmp-who-1019 syntmp-why-1020 syntmp-what-1021) (error syntmp-who-1019 "~a ~s" syntmp-why-1020 syntmp-what-1021))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1022) (eval (list syntmp-noexpand-71 syntmp-x-1022) (interaction-environment)))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1023) (eval (list syntmp-noexpand-71 syntmp-x-1023) (interaction-environment)))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-100 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-100 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-100 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1024 syntmp-r-1025 syntmp-w-1026 syntmp-s-1027) ((lambda (syntmp-tmp-1028) ((lambda (syntmp-tmp-1029) (if (if syntmp-tmp-1029 (apply (lambda (syntmp-_-1030 syntmp-var-1031 syntmp-val-1032 syntmp-e1-1033 syntmp-e2-1034) (syntmp-valid-bound-ids?-127 syntmp-var-1031)) syntmp-tmp-1029) #f) (apply (lambda (syntmp-_-1036 syntmp-var-1037 syntmp-val-1038 syntmp-e1-1039 syntmp-e2-1040) (let ((syntmp-names-1041 (map (lambda (syntmp-x-1042) (syntmp-id-var-name-124 syntmp-x-1042 syntmp-w-1026)) syntmp-var-1037))) (begin (for-each (lambda (syntmp-id-1044 syntmp-n-1045) (let ((syntmp-t-1046 (syntmp-binding-type-94 (syntmp-lookup-99 syntmp-n-1045 syntmp-r-1025)))) (if (memv syntmp-t-1046 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-131 syntmp-id-1044 syntmp-w-1026 syntmp-s-1027) "identifier out of context")))) syntmp-var-1037 syntmp-names-1041) (syntmp-chi-body-142 (cons syntmp-e1-1039 syntmp-e2-1040) (syntmp-source-wrap-131 syntmp-e-1024 syntmp-w-1026 syntmp-s-1027) (syntmp-extend-env-96 syntmp-names-1041 (let ((syntmp-trans-r-1049 (syntmp-macros-only-env-98 syntmp-r-1025))) (map (lambda (syntmp-x-1050) (cons (quote macro) (syntmp-eval-local-transformer-145 (syntmp-chi-138 syntmp-x-1050 syntmp-trans-r-1049 syntmp-w-1026)))) syntmp-val-1038)) syntmp-r-1025) syntmp-w-1026)))) syntmp-tmp-1029) ((lambda (syntmp-_-1052) (syntax-error (syntmp-source-wrap-131 syntmp-e-1024 syntmp-w-1026 syntmp-s-1027))) syntmp-tmp-1028))) (syntax-dispatch syntmp-tmp-1028 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1024))) (syntmp-global-extend-100 (quote core) (quote quote) (lambda (syntmp-e-1053 syntmp-r-1054 syntmp-w-1055 syntmp-s-1056) ((lambda (syntmp-tmp-1057) ((lambda (syntmp-tmp-1058) (if syntmp-tmp-1058 (apply (lambda (syntmp-_-1059 syntmp-e-1060) (syntmp-build-data-82 syntmp-s-1056 (syntmp-strip-149 syntmp-e-1060 syntmp-w-1055))) syntmp-tmp-1058) ((lambda (syntmp-_-1061) (syntax-error (syntmp-source-wrap-131 syntmp-e-1053 syntmp-w-1055 syntmp-s-1056))) syntmp-tmp-1057))) (syntax-dispatch syntmp-tmp-1057 (quote (any any))))) syntmp-e-1053))) (syntmp-global-extend-100 (quote core) (quote syntax) (letrec ((syntmp-regen-1069 (lambda (syntmp-x-1070) (let ((syntmp-t-1071 (car syntmp-x-1070))) (if (memv syntmp-t-1071 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1070) (syntmp-regen-1069 (caddr syntmp-x-1070)))) (if (memv syntmp-t-1071 (quote (map))) (let ((syntmp-ls-1072 (map syntmp-regen-1069 (cdr syntmp-x-1070)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1072) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1072))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1070)) (map syntmp-regen-1069 (cdr syntmp-x-1070)))))))))))) (syntmp-gen-vector-1068 (lambda (syntmp-x-1073) (cond ((eq? (car syntmp-x-1073) (quote list)) (cons (quote vector) (cdr syntmp-x-1073))) ((eq? (car syntmp-x-1073) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1073)))) (else (list (quote list->vector) syntmp-x-1073))))) (syntmp-gen-append-1067 (lambda (syntmp-x-1074 syntmp-y-1075) (if (equal? syntmp-y-1075 (quote (quote ()))) syntmp-x-1074 (list (quote append) syntmp-x-1074 syntmp-y-1075)))) (syntmp-gen-cons-1066 (lambda (syntmp-x-1076 syntmp-y-1077) (let ((syntmp-t-1078 (car syntmp-y-1077))) (if (memv syntmp-t-1078 (quote (quote))) (if (eq? (car syntmp-x-1076) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1076) (cadr syntmp-y-1077))) (if (eq? (cadr syntmp-y-1077) (quote ())) (list (quote list) syntmp-x-1076) (list (quote cons) syntmp-x-1076 syntmp-y-1077))) (if (memv syntmp-t-1078 (quote (list))) (cons (quote list) (cons syntmp-x-1076 (cdr syntmp-y-1077))) (list (quote cons) syntmp-x-1076 syntmp-y-1077)))))) (syntmp-gen-map-1065 (lambda (syntmp-e-1079 syntmp-map-env-1080) (let ((syntmp-formals-1081 (map cdr syntmp-map-env-1080)) (syntmp-actuals-1082 (map (lambda (syntmp-x-1083) (list (quote ref) (car syntmp-x-1083))) syntmp-map-env-1080))) (cond ((eq? (car syntmp-e-1079) (quote ref)) (car syntmp-actuals-1082)) ((andmap (lambda (syntmp-x-1084) (and (eq? (car syntmp-x-1084) (quote ref)) (memq (cadr syntmp-x-1084) syntmp-formals-1081))) (cdr syntmp-e-1079)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1079)) (map (let ((syntmp-r-1085 (map cons syntmp-formals-1081 syntmp-actuals-1082))) (lambda (syntmp-x-1086) (cdr (assq (cadr syntmp-x-1086) syntmp-r-1085)))) (cdr syntmp-e-1079))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1081 syntmp-e-1079) syntmp-actuals-1082))))))) (syntmp-gen-mappend-1064 (lambda (syntmp-e-1087 syntmp-map-env-1088) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1065 syntmp-e-1087 syntmp-map-env-1088)))) (syntmp-gen-ref-1063 (lambda (syntmp-src-1089 syntmp-var-1090 syntmp-level-1091 syntmp-maps-1092) (if (syntmp-fx=-74 syntmp-level-1091 0) (values syntmp-var-1090 syntmp-maps-1092) (if (null? syntmp-maps-1092) (syntax-error syntmp-src-1089 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1063 syntmp-src-1089 syntmp-var-1090 (syntmp-fx--73 syntmp-level-1091 1) (cdr syntmp-maps-1092))) (lambda (syntmp-outer-var-1093 syntmp-outer-maps-1094) (let ((syntmp-b-1095 (assq syntmp-outer-var-1093 (car syntmp-maps-1092)))) (if syntmp-b-1095 (values (cdr syntmp-b-1095) syntmp-maps-1092) (let ((syntmp-inner-var-1096 (syntmp-gen-var-150 (quote tmp)))) (values syntmp-inner-var-1096 (cons (cons (cons syntmp-outer-var-1093 syntmp-inner-var-1096) (car syntmp-maps-1092)) syntmp-outer-maps-1094))))))))))) (syntmp-gen-syntax-1062 (lambda (syntmp-src-1097 syntmp-e-1098 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101) (if (syntmp-id?-102 syntmp-e-1098) (let ((syntmp-label-1102 (syntmp-id-var-name-124 syntmp-e-1098 (quote (()))))) (let ((syntmp-b-1103 (syntmp-lookup-99 syntmp-label-1102 syntmp-r-1099))) (if (eq? (syntmp-binding-type-94 syntmp-b-1103) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1104 (syntmp-binding-value-95 syntmp-b-1103))) (syntmp-gen-ref-1063 syntmp-src-1097 (car syntmp-var.lev-1104) (cdr syntmp-var.lev-1104) syntmp-maps-1100))) (lambda (syntmp-var-1105 syntmp-maps-1106) (values (list (quote ref) syntmp-var-1105) syntmp-maps-1106))) (if (syntmp-ellipsis?-1101 syntmp-e-1098) (syntax-error syntmp-src-1097 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1098) syntmp-maps-1100))))) ((lambda (syntmp-tmp-1107) ((lambda (syntmp-tmp-1108) (if (if syntmp-tmp-1108 (apply (lambda (syntmp-dots-1109 syntmp-e-1110) (syntmp-ellipsis?-1101 syntmp-dots-1109)) syntmp-tmp-1108) #f) (apply (lambda (syntmp-dots-1111 syntmp-e-1112) (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-e-1112 syntmp-r-1099 syntmp-maps-1100 (lambda (syntmp-x-1113) #f))) syntmp-tmp-1108) ((lambda (syntmp-tmp-1114) (if (if syntmp-tmp-1114 (apply (lambda (syntmp-x-1115 syntmp-dots-1116 syntmp-y-1117) (syntmp-ellipsis?-1101 syntmp-dots-1116)) syntmp-tmp-1114) #f) (apply (lambda (syntmp-x-1118 syntmp-dots-1119 syntmp-y-1120) (let syntmp-f-1121 ((syntmp-y-1122 syntmp-y-1120) (syntmp-k-1123 (lambda (syntmp-maps-1124) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-x-1118 syntmp-r-1099 (cons (quote ()) syntmp-maps-1124) syntmp-ellipsis?-1101)) (lambda (syntmp-x-1125 syntmp-maps-1126) (if (null? (car syntmp-maps-1126)) (syntax-error syntmp-src-1097 "extra ellipsis in syntax form") (values (syntmp-gen-map-1065 syntmp-x-1125 (car syntmp-maps-1126)) (cdr syntmp-maps-1126)))))))) ((lambda (syntmp-tmp-1127) ((lambda (syntmp-tmp-1128) (if (if syntmp-tmp-1128 (apply (lambda (syntmp-dots-1129 syntmp-y-1130) (syntmp-ellipsis?-1101 syntmp-dots-1129)) syntmp-tmp-1128) #f) (apply (lambda (syntmp-dots-1131 syntmp-y-1132) (syntmp-f-1121 syntmp-y-1132 (lambda (syntmp-maps-1133) (call-with-values (lambda () (syntmp-k-1123 (cons (quote ()) syntmp-maps-1133))) (lambda (syntmp-x-1134 syntmp-maps-1135) (if (null? (car syntmp-maps-1135)) (syntax-error syntmp-src-1097 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1064 syntmp-x-1134 (car syntmp-maps-1135)) (cdr syntmp-maps-1135)))))))) syntmp-tmp-1128) ((lambda (syntmp-_-1136) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-y-1122 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-y-1137 syntmp-maps-1138) (call-with-values (lambda () (syntmp-k-1123 syntmp-maps-1138)) (lambda (syntmp-x-1139 syntmp-maps-1140) (values (syntmp-gen-append-1067 syntmp-x-1139 syntmp-y-1137) syntmp-maps-1140)))))) syntmp-tmp-1127))) (syntax-dispatch syntmp-tmp-1127 (quote (any . any))))) syntmp-y-1122))) syntmp-tmp-1114) ((lambda (syntmp-tmp-1141) (if syntmp-tmp-1141 (apply (lambda (syntmp-x-1142 syntmp-y-1143) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-x-1142 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-x-1144 syntmp-maps-1145) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-y-1143 syntmp-r-1099 syntmp-maps-1145 syntmp-ellipsis?-1101)) (lambda (syntmp-y-1146 syntmp-maps-1147) (values (syntmp-gen-cons-1066 syntmp-x-1144 syntmp-y-1146) syntmp-maps-1147)))))) syntmp-tmp-1141) ((lambda (syntmp-tmp-1148) (if syntmp-tmp-1148 (apply (lambda (syntmp-e1-1149 syntmp-e2-1150) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 (cons syntmp-e1-1149 syntmp-e2-1150) syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-e-1152 syntmp-maps-1153) (values (syntmp-gen-vector-1068 syntmp-e-1152) syntmp-maps-1153)))) syntmp-tmp-1148) ((lambda (syntmp-_-1154) (values (list (quote quote) syntmp-e-1098) syntmp-maps-1100)) syntmp-tmp-1107))) (syntax-dispatch syntmp-tmp-1107 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1107 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1107 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1107 (quote (any any))))) syntmp-e-1098))))) (lambda (syntmp-e-1155 syntmp-r-1156 syntmp-w-1157 syntmp-s-1158) (let ((syntmp-e-1159 (syntmp-source-wrap-131 syntmp-e-1155 syntmp-w-1157 syntmp-s-1158))) ((lambda (syntmp-tmp-1160) ((lambda (syntmp-tmp-1161) (if syntmp-tmp-1161 (apply (lambda (syntmp-_-1162 syntmp-x-1163) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-e-1159 syntmp-x-1163 syntmp-r-1156 (quote ()) syntmp-ellipsis?-147)) (lambda (syntmp-e-1164 syntmp-maps-1165) (syntmp-regen-1069 syntmp-e-1164)))) syntmp-tmp-1161) ((lambda (syntmp-_-1166) (syntax-error syntmp-e-1159)) syntmp-tmp-1160))) (syntax-dispatch syntmp-tmp-1160 (quote (any any))))) syntmp-e-1159))))) (syntmp-global-extend-100 (quote core) (quote lambda) (lambda (syntmp-e-1167 syntmp-r-1168 syntmp-w-1169 syntmp-s-1170) ((lambda (syntmp-tmp-1171) ((lambda (syntmp-tmp-1172) (if syntmp-tmp-1172 (apply (lambda (syntmp-_-1173 syntmp-c-1174) (syntmp-chi-lambda-clause-143 (syntmp-source-wrap-131 syntmp-e-1167 syntmp-w-1169 syntmp-s-1170) syntmp-c-1174 syntmp-r-1168 syntmp-w-1169 (lambda (syntmp-vars-1175 syntmp-body-1176) (syntmp-build-annotated-81 syntmp-s-1170 (list (quote lambda) syntmp-vars-1175 syntmp-body-1176))))) syntmp-tmp-1172) (syntax-error syntmp-tmp-1171))) (syntax-dispatch syntmp-tmp-1171 (quote (any . any))))) syntmp-e-1167))) (syntmp-global-extend-100 (quote core) (quote let) (letrec ((syntmp-chi-let-1177 (lambda (syntmp-e-1178 syntmp-r-1179 syntmp-w-1180 syntmp-s-1181 syntmp-constructor-1182 syntmp-ids-1183 syntmp-vals-1184 syntmp-exps-1185) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-1183)) (syntax-error syntmp-e-1178 "duplicate bound variable in") (let ((syntmp-labels-1186 (syntmp-gen-labels-108 syntmp-ids-1183)) (syntmp-new-vars-1187 (map syntmp-gen-var-150 syntmp-ids-1183))) (let ((syntmp-nw-1188 (syntmp-make-binding-wrap-119 syntmp-ids-1183 syntmp-labels-1186 syntmp-w-1180)) (syntmp-nr-1189 (syntmp-extend-var-env-97 syntmp-labels-1186 syntmp-new-vars-1187 syntmp-r-1179))) (syntmp-constructor-1182 syntmp-s-1181 syntmp-new-vars-1187 (map (lambda (syntmp-x-1190) (syntmp-chi-138 syntmp-x-1190 syntmp-r-1179 syntmp-w-1180)) syntmp-vals-1184) (syntmp-chi-body-142 syntmp-exps-1185 (syntmp-source-wrap-131 syntmp-e-1178 syntmp-nw-1188 syntmp-s-1181) syntmp-nr-1189 syntmp-nw-1188)))))))) (lambda (syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194) ((lambda (syntmp-tmp-1195) ((lambda (syntmp-tmp-1196) (if syntmp-tmp-1196 (apply (lambda (syntmp-_-1197 syntmp-id-1198 syntmp-val-1199 syntmp-e1-1200 syntmp-e2-1201) (syntmp-chi-let-1177 syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194 syntmp-build-let-84 syntmp-id-1198 syntmp-val-1199 (cons syntmp-e1-1200 syntmp-e2-1201))) syntmp-tmp-1196) ((lambda (syntmp-tmp-1205) (if (if syntmp-tmp-1205 (apply (lambda (syntmp-_-1206 syntmp-f-1207 syntmp-id-1208 syntmp-val-1209 syntmp-e1-1210 syntmp-e2-1211) (syntmp-id?-102 syntmp-f-1207)) syntmp-tmp-1205) #f) (apply (lambda (syntmp-_-1212 syntmp-f-1213 syntmp-id-1214 syntmp-val-1215 syntmp-e1-1216 syntmp-e2-1217) (syntmp-chi-let-1177 syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194 syntmp-build-named-let-85 (cons syntmp-f-1213 syntmp-id-1214) syntmp-val-1215 (cons syntmp-e1-1216 syntmp-e2-1217))) syntmp-tmp-1205) ((lambda (syntmp-_-1221) (syntax-error (syntmp-source-wrap-131 syntmp-e-1191 syntmp-w-1193 syntmp-s-1194))) syntmp-tmp-1195))) (syntax-dispatch syntmp-tmp-1195 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1195 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1191)))) (syntmp-global-extend-100 (quote core) (quote letrec) (lambda (syntmp-e-1222 syntmp-r-1223 syntmp-w-1224 syntmp-s-1225) ((lambda (syntmp-tmp-1226) ((lambda (syntmp-tmp-1227) (if syntmp-tmp-1227 (apply (lambda (syntmp-_-1228 syntmp-id-1229 syntmp-val-1230 syntmp-e1-1231 syntmp-e2-1232) (let ((syntmp-ids-1233 syntmp-id-1229)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-1233)) (syntax-error syntmp-e-1222 "duplicate bound variable in") (let ((syntmp-labels-1235 (syntmp-gen-labels-108 syntmp-ids-1233)) (syntmp-new-vars-1236 (map syntmp-gen-var-150 syntmp-ids-1233))) (let ((syntmp-w-1237 (syntmp-make-binding-wrap-119 syntmp-ids-1233 syntmp-labels-1235 syntmp-w-1224)) (syntmp-r-1238 (syntmp-extend-var-env-97 syntmp-labels-1235 syntmp-new-vars-1236 syntmp-r-1223))) (syntmp-build-letrec-86 syntmp-s-1225 syntmp-new-vars-1236 (map (lambda (syntmp-x-1239) (syntmp-chi-138 syntmp-x-1239 syntmp-r-1238 syntmp-w-1237)) syntmp-val-1230) (syntmp-chi-body-142 (cons syntmp-e1-1231 syntmp-e2-1232) (syntmp-source-wrap-131 syntmp-e-1222 syntmp-w-1237 syntmp-s-1225) syntmp-r-1238 syntmp-w-1237))))))) syntmp-tmp-1227) ((lambda (syntmp-_-1242) (syntax-error (syntmp-source-wrap-131 syntmp-e-1222 syntmp-w-1224 syntmp-s-1225))) syntmp-tmp-1226))) (syntax-dispatch syntmp-tmp-1226 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1222))) (syntmp-global-extend-100 (quote core) (quote set!) (lambda (syntmp-e-1243 syntmp-r-1244 syntmp-w-1245 syntmp-s-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-id-1250 syntmp-val-1251) (syntmp-id?-102 syntmp-id-1250)) syntmp-tmp-1248) #f) (apply (lambda (syntmp-_-1252 syntmp-id-1253 syntmp-val-1254) (let ((syntmp-val-1255 (syntmp-chi-138 syntmp-val-1254 syntmp-r-1244 syntmp-w-1245)) (syntmp-n-1256 (syntmp-id-var-name-124 syntmp-id-1253 syntmp-w-1245))) (let ((syntmp-b-1257 (syntmp-lookup-99 syntmp-n-1256 syntmp-r-1244))) (let ((syntmp-t-1258 (syntmp-binding-type-94 syntmp-b-1257))) (if (memv syntmp-t-1258 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1246 (list (quote set!) (syntmp-binding-value-95 syntmp-b-1257) syntmp-val-1255)) (if (memv syntmp-t-1258 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1246 (list (quote set!) syntmp-n-1256 syntmp-val-1255)) (if (memv syntmp-t-1258 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-130 syntmp-id-1253 syntmp-w-1245) "identifier out of context") (syntax-error (syntmp-source-wrap-131 syntmp-e-1243 syntmp-w-1245 syntmp-s-1246))))))))) syntmp-tmp-1248) ((lambda (syntmp-tmp-1259) (if syntmp-tmp-1259 (apply (lambda (syntmp-_-1260 syntmp-getter-1261 syntmp-arg-1262 syntmp-val-1263) (syntmp-build-annotated-81 syntmp-s-1246 (cons (syntmp-chi-138 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1261) syntmp-r-1244 syntmp-w-1245) (map (lambda (syntmp-e-1264) (syntmp-chi-138 syntmp-e-1264 syntmp-r-1244 syntmp-w-1245)) (append syntmp-arg-1262 (list syntmp-val-1263)))))) syntmp-tmp-1259) ((lambda (syntmp-_-1266) (syntax-error (syntmp-source-wrap-131 syntmp-e-1243 syntmp-w-1245 syntmp-s-1246))) syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1247 (quote (any any any))))) syntmp-e-1243))) (syntmp-global-extend-100 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-100 (quote define) (quote define) (quote ())) (syntmp-global-extend-100 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-100 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-100 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1270 (lambda (syntmp-x-1271 syntmp-keys-1272 syntmp-clauses-1273 syntmp-r-1274) (if (null? syntmp-clauses-1273) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1271)) ((lambda (syntmp-tmp-1275) ((lambda (syntmp-tmp-1276) (if syntmp-tmp-1276 (apply (lambda (syntmp-pat-1277 syntmp-exp-1278) (if (and (syntmp-id?-102 syntmp-pat-1277) (andmap (lambda (syntmp-x-1279) (not (syntmp-free-id=?-125 syntmp-pat-1277 syntmp-x-1279))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1272))) (let ((syntmp-labels-1280 (list (syntmp-gen-label-107))) (syntmp-var-1281 (syntmp-gen-var-150 syntmp-pat-1277))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1281) (syntmp-chi-138 syntmp-exp-1278 (syntmp-extend-env-96 syntmp-labels-1280 (list (cons (quote syntax) (cons syntmp-var-1281 0))) syntmp-r-1274) (syntmp-make-binding-wrap-119 (list syntmp-pat-1277) syntmp-labels-1280 (quote (())))))) syntmp-x-1271))) (syntmp-gen-clause-1269 syntmp-x-1271 syntmp-keys-1272 (cdr syntmp-clauses-1273) syntmp-r-1274 syntmp-pat-1277 #t syntmp-exp-1278))) syntmp-tmp-1276) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-pat-1283 syntmp-fender-1284 syntmp-exp-1285) (syntmp-gen-clause-1269 syntmp-x-1271 syntmp-keys-1272 (cdr syntmp-clauses-1273) syntmp-r-1274 syntmp-pat-1283 syntmp-fender-1284 syntmp-exp-1285)) syntmp-tmp-1282) ((lambda (syntmp-_-1286) (syntax-error (car syntmp-clauses-1273) "invalid syntax-case clause")) syntmp-tmp-1275))) (syntax-dispatch syntmp-tmp-1275 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1275 (quote (any any))))) (car syntmp-clauses-1273))))) (syntmp-gen-clause-1269 (lambda (syntmp-x-1287 syntmp-keys-1288 syntmp-clauses-1289 syntmp-r-1290 syntmp-pat-1291 syntmp-fender-1292 syntmp-exp-1293) (call-with-values (lambda () (syntmp-convert-pattern-1267 syntmp-pat-1291 syntmp-keys-1288)) (lambda (syntmp-p-1294 syntmp-pvars-1295) (cond ((not (syntmp-distinct-bound-ids?-128 (map car syntmp-pvars-1295))) (syntax-error syntmp-pat-1291 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1296) (not (syntmp-ellipsis?-147 (car syntmp-x-1296)))) syntmp-pvars-1295)) (syntax-error syntmp-pat-1291 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1297 (syntmp-gen-var-150 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1297) (let ((syntmp-y-1298 (syntmp-build-annotated-81 #f syntmp-y-1297))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1299) ((lambda (syntmp-tmp-1300) (if syntmp-tmp-1300 (apply (lambda () syntmp-y-1298) syntmp-tmp-1300) ((lambda (syntmp-_-1301) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1298 (syntmp-build-dispatch-call-1268 syntmp-pvars-1295 syntmp-fender-1292 syntmp-y-1298 syntmp-r-1290) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1299))) (syntax-dispatch syntmp-tmp-1299 (quote #(atom #t))))) syntmp-fender-1292) (syntmp-build-dispatch-call-1268 syntmp-pvars-1295 syntmp-exp-1293 syntmp-y-1298 syntmp-r-1290) (syntmp-gen-syntax-case-1270 syntmp-x-1287 syntmp-keys-1288 syntmp-clauses-1289 syntmp-r-1290)))))) (if (eq? syntmp-p-1294 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1287)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1287 (syntmp-build-data-82 #f syntmp-p-1294))))))))))))) (syntmp-build-dispatch-call-1268 (lambda (syntmp-pvars-1302 syntmp-exp-1303 syntmp-y-1304 syntmp-r-1305) (let ((syntmp-ids-1306 (map car syntmp-pvars-1302)) (syntmp-levels-1307 (map cdr syntmp-pvars-1302))) (let ((syntmp-labels-1308 (syntmp-gen-labels-108 syntmp-ids-1306)) (syntmp-new-vars-1309 (map syntmp-gen-var-150 syntmp-ids-1306))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1309 (syntmp-chi-138 syntmp-exp-1303 (syntmp-extend-env-96 syntmp-labels-1308 (map (lambda (syntmp-var-1310 syntmp-level-1311) (cons (quote syntax) (cons syntmp-var-1310 syntmp-level-1311))) syntmp-new-vars-1309 (map cdr syntmp-pvars-1302)) syntmp-r-1305) (syntmp-make-binding-wrap-119 syntmp-ids-1306 syntmp-labels-1308 (quote (())))))) syntmp-y-1304)))))) (syntmp-convert-pattern-1267 (lambda (syntmp-pattern-1312 syntmp-keys-1313) (let syntmp-cvt-1314 ((syntmp-p-1315 syntmp-pattern-1312) (syntmp-n-1316 0) (syntmp-ids-1317 (quote ()))) (if (syntmp-id?-102 syntmp-p-1315) (if (syntmp-bound-id-member?-129 syntmp-p-1315 syntmp-keys-1313) (values (vector (quote free-id) syntmp-p-1315) syntmp-ids-1317) (values (quote any) (cons (cons syntmp-p-1315 syntmp-n-1316) syntmp-ids-1317))) ((lambda (syntmp-tmp-1318) ((lambda (syntmp-tmp-1319) (if (if syntmp-tmp-1319 (apply (lambda (syntmp-x-1320 syntmp-dots-1321) (syntmp-ellipsis?-147 syntmp-dots-1321)) syntmp-tmp-1319) #f) (apply (lambda (syntmp-x-1322 syntmp-dots-1323) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1322 (syntmp-fx+-72 syntmp-n-1316 1) syntmp-ids-1317)) (lambda (syntmp-p-1324 syntmp-ids-1325) (values (if (eq? syntmp-p-1324 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1324)) syntmp-ids-1325)))) syntmp-tmp-1319) ((lambda (syntmp-tmp-1326) (if syntmp-tmp-1326 (apply (lambda (syntmp-x-1327 syntmp-y-1328) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-y-1328 syntmp-n-1316 syntmp-ids-1317)) (lambda (syntmp-y-1329 syntmp-ids-1330) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1327 syntmp-n-1316 syntmp-ids-1330)) (lambda (syntmp-x-1331 syntmp-ids-1332) (values (cons syntmp-x-1331 syntmp-y-1329) syntmp-ids-1332)))))) syntmp-tmp-1326) ((lambda (syntmp-tmp-1333) (if syntmp-tmp-1333 (apply (lambda () (values (quote ()) syntmp-ids-1317)) syntmp-tmp-1333) ((lambda (syntmp-tmp-1334) (if syntmp-tmp-1334 (apply (lambda (syntmp-x-1335) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1335 syntmp-n-1316 syntmp-ids-1317)) (lambda (syntmp-p-1337 syntmp-ids-1338) (values (vector (quote vector) syntmp-p-1337) syntmp-ids-1338)))) syntmp-tmp-1334) ((lambda (syntmp-x-1339) (values (vector (quote atom) (syntmp-strip-149 syntmp-p-1315 (quote (())))) syntmp-ids-1317)) syntmp-tmp-1318))) (syntax-dispatch syntmp-tmp-1318 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1318 (quote ()))))) (syntax-dispatch syntmp-tmp-1318 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1318 (quote (any any))))) syntmp-p-1315)))))) (lambda (syntmp-e-1340 syntmp-r-1341 syntmp-w-1342 syntmp-s-1343) (let ((syntmp-e-1344 (syntmp-source-wrap-131 syntmp-e-1340 syntmp-w-1342 syntmp-s-1343))) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if syntmp-tmp-1346 (apply (lambda (syntmp-_-1347 syntmp-val-1348 syntmp-key-1349 syntmp-m-1350) (if (andmap (lambda (syntmp-x-1351) (and (syntmp-id?-102 syntmp-x-1351) (not (syntmp-ellipsis?-147 syntmp-x-1351)))) syntmp-key-1349) (let ((syntmp-x-1353 (syntmp-gen-var-150 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1343 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1353) (syntmp-gen-syntax-case-1270 (syntmp-build-annotated-81 #f syntmp-x-1353) syntmp-key-1349 syntmp-m-1350 syntmp-r-1341))) (syntmp-chi-138 syntmp-val-1348 syntmp-r-1341 (quote (())))))) (syntax-error syntmp-e-1344 "invalid literals list in"))) syntmp-tmp-1346) (syntax-error syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any any each-any . each-any))))) syntmp-e-1344))))) (set! sc-expand (let ((syntmp-m-1356 (quote e)) (syntmp-esew-1357 (quote (eval)))) (lambda (syntmp-x-1358) (if (and (pair? syntmp-x-1358) (equal? (car syntmp-x-1358) syntmp-noexpand-71)) (cadr syntmp-x-1358) (syntmp-chi-top-137 syntmp-x-1358 (quote ()) (quote ((top))) syntmp-m-1356 syntmp-esew-1357))))) (set! sc-expand3 (let ((syntmp-m-1359 (quote e)) (syntmp-esew-1360 (quote (eval)))) (lambda (syntmp-x-1362 . syntmp-rest-1361) (if (and (pair? syntmp-x-1362) (equal? (car syntmp-x-1362) syntmp-noexpand-71)) (cadr syntmp-x-1362) (syntmp-chi-top-137 syntmp-x-1362 (quote ()) (quote ((top))) (if (null? syntmp-rest-1361) syntmp-m-1359 (car syntmp-rest-1361)) (if (or (null? syntmp-rest-1361) (null? (cdr syntmp-rest-1361))) syntmp-esew-1360 (cadr syntmp-rest-1361))))))) (set! identifier? (lambda (syntmp-x-1363) (syntmp-nonsymbol-id?-101 syntmp-x-1363))) (set! datum->syntax-object (lambda (syntmp-id-1364 syntmp-datum-1365) (syntmp-make-syntax-object-87 syntmp-datum-1365 (syntmp-syntax-object-wrap-90 syntmp-id-1364)))) (set! syntax-object->datum (lambda (syntmp-x-1366) (syntmp-strip-149 syntmp-x-1366 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1367) (begin (let ((syntmp-x-1368 syntmp-ls-1367)) (if (not (list? syntmp-x-1368)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1368))) (map (lambda (syntmp-x-1369) (syntmp-wrap-130 (gensym) (quote ((top))))) syntmp-ls-1367)))) (set! free-identifier=? (lambda (syntmp-x-1370 syntmp-y-1371) (begin (let ((syntmp-x-1372 syntmp-x-1370)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1372)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1372))) (let ((syntmp-x-1373 syntmp-y-1371)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1373)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1373))) (syntmp-free-id=?-125 syntmp-x-1370 syntmp-y-1371)))) (set! bound-identifier=? (lambda (syntmp-x-1374 syntmp-y-1375) (begin (let ((syntmp-x-1376 syntmp-x-1374)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1376)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1376))) (let ((syntmp-x-1377 syntmp-y-1375)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1377)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1377))) (syntmp-bound-id=?-126 syntmp-x-1374 syntmp-y-1375)))) (set! syntax-error (lambda (syntmp-object-1379 . syntmp-messages-1378) (begin (for-each (lambda (syntmp-x-1380) (let ((syntmp-x-1381 syntmp-x-1380)) (if (not (string? syntmp-x-1381)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1381)))) syntmp-messages-1378) (let ((syntmp-message-1382 (if (null? syntmp-messages-1378) "invalid syntax" (apply string-append syntmp-messages-1378)))) (syntmp-error-hook-78 #f syntmp-message-1382 (syntmp-strip-149 syntmp-object-1379 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1383 syntmp-v-1384) (begin (let ((syntmp-x-1385 syntmp-sym-1383)) (if (not (symbol? syntmp-x-1385)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1385))) (let ((syntmp-x-1386 syntmp-v-1384)) (if (not (procedure? syntmp-x-1386)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1386))) (syntmp-global-extend-100 (quote macro) syntmp-sym-1383 syntmp-v-1384)))) (letrec ((syntmp-match-1391 (lambda (syntmp-e-1392 syntmp-p-1393 syntmp-w-1394 syntmp-r-1395) (cond ((not syntmp-r-1395) #f) ((eq? syntmp-p-1393 (quote any)) (cons (syntmp-wrap-130 syntmp-e-1392 syntmp-w-1394) syntmp-r-1395)) ((syntmp-syntax-object?-88 syntmp-e-1392) (syntmp-match*-1390 (let ((syntmp-e-1396 (syntmp-syntax-object-expression-89 syntmp-e-1392))) (if (annotation? syntmp-e-1396) (annotation-expression syntmp-e-1396) syntmp-e-1396)) syntmp-p-1393 (syntmp-join-wraps-121 syntmp-w-1394 (syntmp-syntax-object-wrap-90 syntmp-e-1392)) syntmp-r-1395)) (else (syntmp-match*-1390 (let ((syntmp-e-1397 syntmp-e-1392)) (if (annotation? syntmp-e-1397) (annotation-expression syntmp-e-1397) syntmp-e-1397)) syntmp-p-1393 syntmp-w-1394 syntmp-r-1395))))) (syntmp-match*-1390 (lambda (syntmp-e-1398 syntmp-p-1399 syntmp-w-1400 syntmp-r-1401) (cond ((null? syntmp-p-1399) (and (null? syntmp-e-1398) syntmp-r-1401)) ((pair? syntmp-p-1399) (and (pair? syntmp-e-1398) (syntmp-match-1391 (car syntmp-e-1398) (car syntmp-p-1399) syntmp-w-1400 (syntmp-match-1391 (cdr syntmp-e-1398) (cdr syntmp-p-1399) syntmp-w-1400 syntmp-r-1401)))) ((eq? syntmp-p-1399 (quote each-any)) (let ((syntmp-l-1402 (syntmp-match-each-any-1388 syntmp-e-1398 syntmp-w-1400))) (and syntmp-l-1402 (cons syntmp-l-1402 syntmp-r-1401)))) (else (let ((syntmp-t-1403 (vector-ref syntmp-p-1399 0))) (if (memv syntmp-t-1403 (quote (each))) (if (null? syntmp-e-1398) (syntmp-match-empty-1389 (vector-ref syntmp-p-1399 1) syntmp-r-1401) (let ((syntmp-l-1404 (syntmp-match-each-1387 syntmp-e-1398 (vector-ref syntmp-p-1399 1) syntmp-w-1400))) (and syntmp-l-1404 (let syntmp-collect-1405 ((syntmp-l-1406 syntmp-l-1404)) (if (null? (car syntmp-l-1406)) syntmp-r-1401 (cons (map car syntmp-l-1406) (syntmp-collect-1405 (map cdr syntmp-l-1406)))))))) (if (memv syntmp-t-1403 (quote (free-id))) (and (syntmp-id?-102 syntmp-e-1398) (syntmp-free-id=?-125 (syntmp-wrap-130 syntmp-e-1398 syntmp-w-1400) (vector-ref syntmp-p-1399 1)) syntmp-r-1401) (if (memv syntmp-t-1403 (quote (atom))) (and (equal? (vector-ref syntmp-p-1399 1) (syntmp-strip-149 syntmp-e-1398 syntmp-w-1400)) syntmp-r-1401) (if (memv syntmp-t-1403 (quote (vector))) (and (vector? syntmp-e-1398) (syntmp-match-1391 (vector->list syntmp-e-1398) (vector-ref syntmp-p-1399 1) syntmp-w-1400 syntmp-r-1401))))))))))) (syntmp-match-empty-1389 (lambda (syntmp-p-1407 syntmp-r-1408) (cond ((null? syntmp-p-1407) syntmp-r-1408) ((eq? syntmp-p-1407 (quote any)) (cons (quote ()) syntmp-r-1408)) ((pair? syntmp-p-1407) (syntmp-match-empty-1389 (car syntmp-p-1407) (syntmp-match-empty-1389 (cdr syntmp-p-1407) syntmp-r-1408))) ((eq? syntmp-p-1407 (quote each-any)) (cons (quote ()) syntmp-r-1408)) (else (let ((syntmp-t-1409 (vector-ref syntmp-p-1407 0))) (if (memv syntmp-t-1409 (quote (each))) (syntmp-match-empty-1389 (vector-ref syntmp-p-1407 1) syntmp-r-1408) (if (memv syntmp-t-1409 (quote (free-id atom))) syntmp-r-1408 (if (memv syntmp-t-1409 (quote (vector))) (syntmp-match-empty-1389 (vector-ref syntmp-p-1407 1) syntmp-r-1408))))))))) (syntmp-match-each-any-1388 (lambda (syntmp-e-1410 syntmp-w-1411) (cond ((annotation? syntmp-e-1410) (syntmp-match-each-any-1388 (annotation-expression syntmp-e-1410) syntmp-w-1411)) ((pair? syntmp-e-1410) (let ((syntmp-l-1412 (syntmp-match-each-any-1388 (cdr syntmp-e-1410) syntmp-w-1411))) (and syntmp-l-1412 (cons (syntmp-wrap-130 (car syntmp-e-1410) syntmp-w-1411) syntmp-l-1412)))) ((null? syntmp-e-1410) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1410) (syntmp-match-each-any-1388 (syntmp-syntax-object-expression-89 syntmp-e-1410) (syntmp-join-wraps-121 syntmp-w-1411 (syntmp-syntax-object-wrap-90 syntmp-e-1410)))) (else #f)))) (syntmp-match-each-1387 (lambda (syntmp-e-1413 syntmp-p-1414 syntmp-w-1415) (cond ((annotation? syntmp-e-1413) (syntmp-match-each-1387 (annotation-expression syntmp-e-1413) syntmp-p-1414 syntmp-w-1415)) ((pair? syntmp-e-1413) (let ((syntmp-first-1416 (syntmp-match-1391 (car syntmp-e-1413) syntmp-p-1414 syntmp-w-1415 (quote ())))) (and syntmp-first-1416 (let ((syntmp-rest-1417 (syntmp-match-each-1387 (cdr syntmp-e-1413) syntmp-p-1414 syntmp-w-1415))) (and syntmp-rest-1417 (cons syntmp-first-1416 syntmp-rest-1417)))))) ((null? syntmp-e-1413) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1413) (syntmp-match-each-1387 (syntmp-syntax-object-expression-89 syntmp-e-1413) syntmp-p-1414 (syntmp-join-wraps-121 syntmp-w-1415 (syntmp-syntax-object-wrap-90 syntmp-e-1413)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1418 syntmp-p-1419) (cond ((eq? syntmp-p-1419 (quote any)) (list syntmp-e-1418)) ((syntmp-syntax-object?-88 syntmp-e-1418) (syntmp-match*-1390 (let ((syntmp-e-1420 (syntmp-syntax-object-expression-89 syntmp-e-1418))) (if (annotation? syntmp-e-1420) (annotation-expression syntmp-e-1420) syntmp-e-1420)) syntmp-p-1419 (syntmp-syntax-object-wrap-90 syntmp-e-1418) (quote ()))) (else (syntmp-match*-1390 (let ((syntmp-e-1421 syntmp-e-1418)) (if (annotation? syntmp-e-1421) (annotation-expression syntmp-e-1421) syntmp-e-1421)) syntmp-p-1419 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-138))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1422) ((lambda (syntmp-tmp-1423) ((lambda (syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda (syntmp-_-1425 syntmp-e1-1426 syntmp-e2-1427) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1426 syntmp-e2-1427))) syntmp-tmp-1424) ((lambda (syntmp-tmp-1429) (if syntmp-tmp-1429 (apply (lambda (syntmp-_-1430 syntmp-out-1431 syntmp-in-1432 syntmp-e1-1433 syntmp-e2-1434) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1432 (quote ()) (list syntmp-out-1431 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1433 syntmp-e2-1434))))) syntmp-tmp-1429) ((lambda (syntmp-tmp-1436) (if syntmp-tmp-1436 (apply (lambda (syntmp-_-1437 syntmp-out-1438 syntmp-in-1439 syntmp-e1-1440 syntmp-e2-1441) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1439) (quote ()) (list syntmp-out-1438 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1440 syntmp-e2-1441))))) syntmp-tmp-1436) (syntax-error syntmp-tmp-1423))) (syntax-dispatch syntmp-tmp-1423 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1423 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1423 (quote (any () any . each-any))))) syntmp-x-1422))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1463) ((lambda (syntmp-tmp-1464) ((lambda (syntmp-tmp-1465) (if syntmp-tmp-1465 (apply (lambda (syntmp-_-1466 syntmp-k-1467 syntmp-keyword-1468 syntmp-pattern-1469 syntmp-template-1470) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1467 (map (lambda (syntmp-tmp-1473 syntmp-tmp-1472) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1472) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1473))) syntmp-template-1470 syntmp-pattern-1469)))))) syntmp-tmp-1465) (syntax-error syntmp-tmp-1464))) (syntax-dispatch syntmp-tmp-1464 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1463))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1484) ((lambda (syntmp-tmp-1485) ((lambda (syntmp-tmp-1486) (if (if syntmp-tmp-1486 (apply (lambda (syntmp-let*-1487 syntmp-x-1488 syntmp-v-1489 syntmp-e1-1490 syntmp-e2-1491) (andmap identifier? syntmp-x-1488)) syntmp-tmp-1486) #f) (apply (lambda (syntmp-let*-1493 syntmp-x-1494 syntmp-v-1495 syntmp-e1-1496 syntmp-e2-1497) (let syntmp-f-1498 ((syntmp-bindings-1499 (map list syntmp-x-1494 syntmp-v-1495))) (if (null? syntmp-bindings-1499) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1496 syntmp-e2-1497))) ((lambda (syntmp-tmp-1503) ((lambda (syntmp-tmp-1504) (if syntmp-tmp-1504 (apply (lambda (syntmp-body-1505 syntmp-binding-1506) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1506) syntmp-body-1505)) syntmp-tmp-1504) (syntax-error syntmp-tmp-1503))) (syntax-dispatch syntmp-tmp-1503 (quote (any any))))) (list (syntmp-f-1498 (cdr syntmp-bindings-1499)) (car syntmp-bindings-1499)))))) syntmp-tmp-1486) (syntax-error syntmp-tmp-1485))) (syntax-dispatch syntmp-tmp-1485 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1484))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1526) ((lambda (syntmp-tmp-1527) ((lambda (syntmp-tmp-1528) (if syntmp-tmp-1528 (apply (lambda (syntmp-_-1529 syntmp-var-1530 syntmp-init-1531 syntmp-step-1532 syntmp-e0-1533 syntmp-e1-1534 syntmp-c-1535) ((lambda (syntmp-tmp-1536) ((lambda (syntmp-tmp-1537) (if syntmp-tmp-1537 (apply (lambda (syntmp-step-1538) ((lambda (syntmp-tmp-1539) ((lambda (syntmp-tmp-1540) (if syntmp-tmp-1540 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1530 syntmp-init-1531) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1533) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1535 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1538))))))) syntmp-tmp-1540) ((lambda (syntmp-tmp-1545) (if syntmp-tmp-1545 (apply (lambda (syntmp-e1-1546 syntmp-e2-1547) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1530 syntmp-init-1531) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1533 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons syntmp-e1-1546 syntmp-e2-1547)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1535 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1538))))))) syntmp-tmp-1545) (syntax-error syntmp-tmp-1539))) (syntax-dispatch syntmp-tmp-1539 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1539 (quote ())))) syntmp-e1-1534)) syntmp-tmp-1537) (syntax-error syntmp-tmp-1536))) (syntax-dispatch syntmp-tmp-1536 (quote each-any)))) (map (lambda (syntmp-v-1554 syntmp-s-1555) ((lambda (syntmp-tmp-1556) ((lambda (syntmp-tmp-1557) (if syntmp-tmp-1557 (apply (lambda () syntmp-v-1554) syntmp-tmp-1557) ((lambda (syntmp-tmp-1558) (if syntmp-tmp-1558 (apply (lambda (syntmp-e-1559) syntmp-e-1559) syntmp-tmp-1558) ((lambda (syntmp-_-1560) (syntax-error syntmp-orig-x-1526)) syntmp-tmp-1556))) (syntax-dispatch syntmp-tmp-1556 (quote (any)))))) (syntax-dispatch syntmp-tmp-1556 (quote ())))) syntmp-s-1555)) syntmp-var-1530 syntmp-step-1532))) syntmp-tmp-1528) (syntax-error syntmp-tmp-1527))) (syntax-dispatch syntmp-tmp-1527 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1526))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1588 (lambda (syntmp-x-1592 syntmp-y-1593) ((lambda (syntmp-tmp-1594) ((lambda (syntmp-tmp-1595) (if syntmp-tmp-1595 (apply (lambda (syntmp-x-1596 syntmp-y-1597) ((lambda (syntmp-tmp-1598) ((lambda (syntmp-tmp-1599) (if syntmp-tmp-1599 (apply (lambda (syntmp-dy-1600) ((lambda (syntmp-tmp-1601) ((lambda (syntmp-tmp-1602) (if syntmp-tmp-1602 (apply (lambda (syntmp-dx-1603) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1603 syntmp-dy-1600))) syntmp-tmp-1602) ((lambda (syntmp-_-1604) (if (null? syntmp-dy-1600) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596 syntmp-y-1597))) syntmp-tmp-1601))) (syntax-dispatch syntmp-tmp-1601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1596)) syntmp-tmp-1599) ((lambda (syntmp-tmp-1605) (if syntmp-tmp-1605 (apply (lambda (syntmp-stuff-1606) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1596 syntmp-stuff-1606))) syntmp-tmp-1605) ((lambda (syntmp-else-1607) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596 syntmp-y-1597)) syntmp-tmp-1598))) (syntax-dispatch syntmp-tmp-1598 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1598 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1597)) syntmp-tmp-1595) (syntax-error syntmp-tmp-1594))) (syntax-dispatch syntmp-tmp-1594 (quote (any any))))) (list syntmp-x-1592 syntmp-y-1593)))) (syntmp-quasiappend-1589 (lambda (syntmp-x-1608 syntmp-y-1609) ((lambda (syntmp-tmp-1610) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-x-1612 syntmp-y-1613) ((lambda (syntmp-tmp-1614) ((lambda (syntmp-tmp-1615) (if syntmp-tmp-1615 (apply (lambda () syntmp-x-1612) syntmp-tmp-1615) ((lambda (syntmp-_-1616) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1612 syntmp-y-1613)) syntmp-tmp-1614))) (syntax-dispatch syntmp-tmp-1614 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1613)) syntmp-tmp-1611) (syntax-error syntmp-tmp-1610))) (syntax-dispatch syntmp-tmp-1610 (quote (any any))))) (list syntmp-x-1608 syntmp-y-1609)))) (syntmp-quasivector-1590 (lambda (syntmp-x-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-x-1619) ((lambda (syntmp-tmp-1620) ((lambda (syntmp-tmp-1621) (if syntmp-tmp-1621 (apply (lambda (syntmp-x-1622) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1622))) syntmp-tmp-1621) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-x-1625) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1625)) syntmp-tmp-1624) ((lambda (syntmp-_-1627) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1619)) syntmp-tmp-1620))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1619)) syntmp-tmp-1618)) syntmp-x-1617))) (syntmp-quasi-1591 (lambda (syntmp-p-1628 syntmp-lev-1629) ((lambda (syntmp-tmp-1630) ((lambda (syntmp-tmp-1631) (if syntmp-tmp-1631 (apply (lambda (syntmp-p-1632) (if (= syntmp-lev-1629 0) syntmp-p-1632 (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1632) (- syntmp-lev-1629 1))))) syntmp-tmp-1631) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-p-1634 syntmp-q-1635) (if (= syntmp-lev-1629 0) (syntmp-quasiappend-1589 syntmp-p-1634 (syntmp-quasi-1591 syntmp-q-1635 syntmp-lev-1629)) (syntmp-quasicons-1588 (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1634) (- syntmp-lev-1629 1))) (syntmp-quasi-1591 syntmp-q-1635 syntmp-lev-1629)))) syntmp-tmp-1633) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda (syntmp-p-1637) (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1637) (+ syntmp-lev-1629 1)))) syntmp-tmp-1636) ((lambda (syntmp-tmp-1638) (if syntmp-tmp-1638 (apply (lambda (syntmp-p-1639 syntmp-q-1640) (syntmp-quasicons-1588 (syntmp-quasi-1591 syntmp-p-1639 syntmp-lev-1629) (syntmp-quasi-1591 syntmp-q-1640 syntmp-lev-1629))) syntmp-tmp-1638) ((lambda (syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-x-1642) (syntmp-quasivector-1590 (syntmp-quasi-1591 syntmp-x-1642 syntmp-lev-1629))) syntmp-tmp-1641) ((lambda (syntmp-p-1644) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1644)) syntmp-tmp-1630))) (syntax-dispatch syntmp-tmp-1630 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1630 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1628)))) (lambda (syntmp-x-1645) ((lambda (syntmp-tmp-1646) ((lambda (syntmp-tmp-1647) (if syntmp-tmp-1647 (apply (lambda (syntmp-_-1648 syntmp-e-1649) (syntmp-quasi-1591 syntmp-e-1649 0)) syntmp-tmp-1647) (syntax-error syntmp-tmp-1646))) (syntax-dispatch syntmp-tmp-1646 (quote (any any))))) syntmp-x-1645)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1709) (letrec ((syntmp-read-file-1710 (lambda (syntmp-fn-1711 syntmp-k-1712) (let ((syntmp-p-1713 (open-input-file syntmp-fn-1711))) (let syntmp-f-1714 ((syntmp-x-1715 (read syntmp-p-1713))) (if (eof-object? syntmp-x-1715) (begin (close-input-port syntmp-p-1713) (quote ())) (cons (datum->syntax-object syntmp-k-1712 syntmp-x-1715) (syntmp-f-1714 (read syntmp-p-1713))))))))) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-k-1718 syntmp-filename-1719) (let ((syntmp-fn-1720 (syntax-object->datum syntmp-filename-1719))) ((lambda (syntmp-tmp-1721) ((lambda (syntmp-tmp-1722) (if syntmp-tmp-1722 (apply (lambda (syntmp-exp-1723) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) syntmp-exp-1723)) syntmp-tmp-1722) (syntax-error syntmp-tmp-1721))) (syntax-dispatch syntmp-tmp-1721 (quote each-any)))) (syntmp-read-file-1710 syntmp-fn-1720 syntmp-k-1718)))) syntmp-tmp-1717) (syntax-error syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (any any))))) syntmp-x-1709)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1740) ((lambda (syntmp-tmp-1741) ((lambda (syntmp-tmp-1742) (if syntmp-tmp-1742 (apply (lambda (syntmp-_-1743 syntmp-e-1744) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1744))) syntmp-tmp-1742) (syntax-error syntmp-tmp-1741))) (syntax-dispatch syntmp-tmp-1741 (quote (any any))))) syntmp-x-1740))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1750) ((lambda (syntmp-tmp-1751) ((lambda (syntmp-tmp-1752) (if syntmp-tmp-1752 (apply (lambda (syntmp-_-1753 syntmp-e-1754) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1754))) syntmp-tmp-1752) (syntax-error syntmp-tmp-1751))) (syntax-dispatch syntmp-tmp-1751 (quote (any any))))) syntmp-x-1750))) -(install-global-transformer (quote case) (lambda (syntmp-x-1760) ((lambda (syntmp-tmp-1761) ((lambda (syntmp-tmp-1762) (if syntmp-tmp-1762 (apply (lambda (syntmp-_-1763 syntmp-e-1764 syntmp-m1-1765 syntmp-m2-1766) ((lambda (syntmp-tmp-1767) ((lambda (syntmp-body-1768) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1764)) syntmp-body-1768)) syntmp-tmp-1767)) (let syntmp-f-1769 ((syntmp-clause-1770 syntmp-m1-1765) (syntmp-clauses-1771 syntmp-m2-1766)) (if (null? syntmp-clauses-1771) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-tmp-1774) (if syntmp-tmp-1774 (apply (lambda (syntmp-e1-1775 syntmp-e2-1776) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1775 syntmp-e2-1776))) syntmp-tmp-1774) ((lambda (syntmp-tmp-1778) (if syntmp-tmp-1778 (apply (lambda (syntmp-k-1779 syntmp-e1-1780 syntmp-e2-1781) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1779)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1780 syntmp-e2-1781)))) syntmp-tmp-1778) ((lambda (syntmp-_-1784) (syntax-error syntmp-x-1760)) syntmp-tmp-1773))) (syntax-dispatch syntmp-tmp-1773 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1773 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1770) ((lambda (syntmp-tmp-1785) ((lambda (syntmp-rest-1786) ((lambda (syntmp-tmp-1787) ((lambda (syntmp-tmp-1788) (if syntmp-tmp-1788 (apply (lambda (syntmp-k-1789 syntmp-e1-1790 syntmp-e2-1791) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1789)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1790 syntmp-e2-1791)) syntmp-rest-1786)) syntmp-tmp-1788) ((lambda (syntmp-_-1794) (syntax-error syntmp-x-1760)) syntmp-tmp-1787))) (syntax-dispatch syntmp-tmp-1787 (quote (each-any any . each-any))))) syntmp-clause-1770)) syntmp-tmp-1785)) (syntmp-f-1769 (car syntmp-clauses-1771) (cdr syntmp-clauses-1771))))))) syntmp-tmp-1762) (syntax-error syntmp-tmp-1761))) (syntax-dispatch syntmp-tmp-1761 (quote (any any any . each-any))))) syntmp-x-1760))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1824) ((lambda (syntmp-tmp-1825) ((lambda (syntmp-tmp-1826) (if syntmp-tmp-1826 (apply (lambda (syntmp-_-1827 syntmp-e-1828) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1828)) (list (cons syntmp-_-1827 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1828 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1826) (syntax-error syntmp-tmp-1825))) (syntax-dispatch syntmp-tmp-1825 (quote (any any))))) syntmp-x-1824))) +(letrec ((syntmp-lambda-var-list-166 (lambda (syntmp-vars-557) (let syntmp-lvl-558 ((syntmp-vars-559 syntmp-vars-557) (syntmp-ls-560 (quote ())) (syntmp-w-561 (quote (())))) (cond ((pair? syntmp-vars-559) (syntmp-lvl-558 (cdr syntmp-vars-559) (cons (syntmp-wrap-145 (car syntmp-vars-559) syntmp-w-561 #f) syntmp-ls-560) syntmp-w-561)) ((syntmp-id?-117 syntmp-vars-559) (cons (syntmp-wrap-145 syntmp-vars-559 syntmp-w-561 #f) syntmp-ls-560)) ((null? syntmp-vars-559) syntmp-ls-560) ((syntmp-syntax-object?-101 syntmp-vars-559) (syntmp-lvl-558 (syntmp-syntax-object-expression-102 syntmp-vars-559) syntmp-ls-560 (syntmp-join-wraps-136 syntmp-w-561 (syntmp-syntax-object-wrap-103 syntmp-vars-559)))) ((annotation? syntmp-vars-559) (syntmp-lvl-558 (annotation-expression syntmp-vars-559) syntmp-ls-560 syntmp-w-561)) (else (cons syntmp-vars-559 syntmp-ls-560)))))) (syntmp-gen-var-165 (lambda (syntmp-id-562) (let ((syntmp-id-563 (if (syntmp-syntax-object?-101 syntmp-id-562) (syntmp-syntax-object-expression-102 syntmp-id-562) syntmp-id-562))) (if (annotation? syntmp-id-563) (syntmp-build-annotated-94 (annotation-source syntmp-id-563) (gensym (symbol->string (annotation-expression syntmp-id-563)))) (syntmp-build-annotated-94 #f (gensym (symbol->string syntmp-id-563))))))) (syntmp-strip-164 (lambda (syntmp-x-564 syntmp-w-565) (if (memq (quote top) (syntmp-wrap-marks-120 syntmp-w-565)) (if (or (annotation? syntmp-x-564) (and (pair? syntmp-x-564) (annotation? (car syntmp-x-564)))) (syntmp-strip-annotation-163 syntmp-x-564 #f) syntmp-x-564) (let syntmp-f-566 ((syntmp-x-567 syntmp-x-564)) (cond ((syntmp-syntax-object?-101 syntmp-x-567) (syntmp-strip-164 (syntmp-syntax-object-expression-102 syntmp-x-567) (syntmp-syntax-object-wrap-103 syntmp-x-567))) ((pair? syntmp-x-567) (let ((syntmp-a-568 (syntmp-f-566 (car syntmp-x-567))) (syntmp-d-569 (syntmp-f-566 (cdr syntmp-x-567)))) (if (and (eq? syntmp-a-568 (car syntmp-x-567)) (eq? syntmp-d-569 (cdr syntmp-x-567))) syntmp-x-567 (cons syntmp-a-568 syntmp-d-569)))) ((vector? syntmp-x-567) (let ((syntmp-old-570 (vector->list syntmp-x-567))) (let ((syntmp-new-571 (map syntmp-f-566 syntmp-old-570))) (if (andmap eq? syntmp-old-570 syntmp-new-571) syntmp-x-567 (list->vector syntmp-new-571))))) (else syntmp-x-567)))))) (syntmp-strip-annotation-163 (lambda (syntmp-x-572 syntmp-parent-573) (cond ((pair? syntmp-x-572) (let ((syntmp-new-574 (cons #f #f))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-574)) (set-car! syntmp-new-574 (syntmp-strip-annotation-163 (car syntmp-x-572) #f)) (set-cdr! syntmp-new-574 (syntmp-strip-annotation-163 (cdr syntmp-x-572) #f)) syntmp-new-574))) ((annotation? syntmp-x-572) (or (annotation-stripped syntmp-x-572) (syntmp-strip-annotation-163 (annotation-expression syntmp-x-572) syntmp-x-572))) ((vector? syntmp-x-572) (let ((syntmp-new-575 (make-vector (vector-length syntmp-x-572)))) (begin (if syntmp-parent-573 (set-annotation-stripped! syntmp-parent-573 syntmp-new-575)) (let syntmp-loop-576 ((syntmp-i-577 (- (vector-length syntmp-x-572) 1))) (unless (syntmp-fx<-88 syntmp-i-577 0) (vector-set! syntmp-new-575 syntmp-i-577 (syntmp-strip-annotation-163 (vector-ref syntmp-x-572 syntmp-i-577) #f)) (syntmp-loop-576 (syntmp-fx--86 syntmp-i-577 1)))) syntmp-new-575))) (else syntmp-x-572)))) (syntmp-ellipsis?-162 (lambda (syntmp-x-578) (and (syntmp-nonsymbol-id?-116 syntmp-x-578) (syntmp-free-id=?-140 syntmp-x-578 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-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-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-161 (lambda () (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote void)))))) (syntmp-eval-local-transformer-160 (lambda (syntmp-expanded-579 syntmp-mod-580) (let ((syntmp-p-581 (syntmp-local-eval-hook-90 syntmp-expanded-579 syntmp-mod-580))) (if (procedure? syntmp-p-581) syntmp-p-581 (syntax-error syntmp-p-581 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-159 (lambda (syntmp-rec?-582 syntmp-e-583 syntmp-r-584 syntmp-w-585 syntmp-s-586 syntmp-mod-587 syntmp-k-588) ((lambda (syntmp-tmp-589) ((lambda (syntmp-tmp-590) (if syntmp-tmp-590 (apply (lambda (syntmp-_-591 syntmp-id-592 syntmp-val-593 syntmp-e1-594 syntmp-e2-595) (let ((syntmp-ids-596 syntmp-id-592)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-596)) (syntax-error syntmp-e-583 "duplicate bound keyword in") (let ((syntmp-labels-598 (syntmp-gen-labels-123 syntmp-ids-596))) (let ((syntmp-new-w-599 (syntmp-make-binding-wrap-134 syntmp-ids-596 syntmp-labels-598 syntmp-w-585))) (syntmp-k-588 (cons syntmp-e1-594 syntmp-e2-595) (syntmp-extend-env-111 syntmp-labels-598 (let ((syntmp-w-601 (if syntmp-rec?-582 syntmp-new-w-599 syntmp-w-585)) (syntmp-trans-r-602 (syntmp-macros-only-env-113 syntmp-r-584))) (map (lambda (syntmp-x-603) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-603 syntmp-trans-r-602 syntmp-w-601 syntmp-mod-587) syntmp-mod-587))) syntmp-val-593)) syntmp-r-584) syntmp-new-w-599 syntmp-s-586 syntmp-mod-587)))))) syntmp-tmp-590) ((lambda (syntmp-_-605) (syntax-error (syntmp-source-wrap-146 syntmp-e-583 syntmp-w-585 syntmp-s-586 syntmp-mod-587))) syntmp-tmp-589))) (syntax-dispatch syntmp-tmp-589 (quote (any #(each (any any)) any . each-any))))) syntmp-e-583))) (syntmp-chi-lambda-clause-158 (lambda (syntmp-e-606 syntmp-c-607 syntmp-r-608 syntmp-w-609 syntmp-mod-610 syntmp-k-611) ((lambda (syntmp-tmp-612) ((lambda (syntmp-tmp-613) (if syntmp-tmp-613 (apply (lambda (syntmp-id-614 syntmp-e1-615 syntmp-e2-616) (let ((syntmp-ids-617 syntmp-id-614)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-617)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-619 (syntmp-gen-labels-123 syntmp-ids-617)) (syntmp-new-vars-620 (map syntmp-gen-var-165 syntmp-ids-617))) (syntmp-k-611 syntmp-new-vars-620 (syntmp-chi-body-157 (cons syntmp-e1-615 syntmp-e2-616) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-619 syntmp-new-vars-620 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-ids-617 syntmp-labels-619 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-613) ((lambda (syntmp-tmp-622) (if syntmp-tmp-622 (apply (lambda (syntmp-ids-623 syntmp-e1-624 syntmp-e2-625) (let ((syntmp-old-ids-626 (syntmp-lambda-var-list-166 syntmp-ids-623))) (if (not (syntmp-valid-bound-ids?-142 syntmp-old-ids-626)) (syntax-error syntmp-e-606 "invalid parameter list in") (let ((syntmp-labels-627 (syntmp-gen-labels-123 syntmp-old-ids-626)) (syntmp-new-vars-628 (map syntmp-gen-var-165 syntmp-old-ids-626))) (syntmp-k-611 (let syntmp-f-629 ((syntmp-ls1-630 (cdr syntmp-new-vars-628)) (syntmp-ls2-631 (car syntmp-new-vars-628))) (if (null? syntmp-ls1-630) syntmp-ls2-631 (syntmp-f-629 (cdr syntmp-ls1-630) (cons (car syntmp-ls1-630) syntmp-ls2-631)))) (syntmp-chi-body-157 (cons syntmp-e1-624 syntmp-e2-625) syntmp-e-606 (syntmp-extend-var-env-112 syntmp-labels-627 syntmp-new-vars-628 syntmp-r-608) (syntmp-make-binding-wrap-134 syntmp-old-ids-626 syntmp-labels-627 syntmp-w-609) syntmp-mod-610)))))) syntmp-tmp-622) ((lambda (syntmp-_-633) (syntax-error syntmp-e-606)) syntmp-tmp-612))) (syntax-dispatch syntmp-tmp-612 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-612 (quote (each-any any . each-any))))) syntmp-c-607))) (syntmp-chi-body-157 (lambda (syntmp-body-634 syntmp-outer-form-635 syntmp-r-636 syntmp-w-637 syntmp-mod-638) (let ((syntmp-r-639 (cons (quote ("placeholder" placeholder)) syntmp-r-636))) (let ((syntmp-ribcage-640 (syntmp-make-ribcage-124 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-641 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-637) (cons syntmp-ribcage-640 (syntmp-wrap-subst-121 syntmp-w-637))))) (let syntmp-parse-642 ((syntmp-body-643 (map (lambda (syntmp-x-649) (cons syntmp-r-639 (syntmp-wrap-145 syntmp-x-649 syntmp-w-641 syntmp-mod-638))) syntmp-body-634)) (syntmp-ids-644 (quote ())) (syntmp-labels-645 (quote ())) (syntmp-vars-646 (quote ())) (syntmp-vals-647 (quote ())) (syntmp-bindings-648 (quote ()))) (if (null? syntmp-body-643) (syntax-error syntmp-outer-form-635 "no expressions in body") (let ((syntmp-e-650 (cdar syntmp-body-643)) (syntmp-er-651 (caar syntmp-body-643))) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-650 syntmp-er-651 (quote (())) #f syntmp-ribcage-640 syntmp-mod-638)) (lambda (syntmp-type-652 syntmp-value-653 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657) (let ((syntmp-t-658 syntmp-type-652)) (if (memv syntmp-t-658 (quote (define-form))) (let ((syntmp-id-659 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-660 (syntmp-gen-label-122))) (let ((syntmp-var-661 (syntmp-gen-var-165 syntmp-id-659))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-659 syntmp-label-660) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-659 syntmp-ids-644) (cons syntmp-label-660 syntmp-labels-645) (cons syntmp-var-661 syntmp-vars-646) (cons (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657)) syntmp-vals-647) (cons (cons (quote lexical) syntmp-var-661) syntmp-bindings-648))))) (if (memv syntmp-t-658 (quote (define-syntax-form))) (let ((syntmp-id-662 (syntmp-wrap-145 syntmp-value-653 syntmp-w-655 syntmp-mod-657)) (syntmp-label-663 (syntmp-gen-label-122))) (begin (syntmp-extend-ribcage!-133 syntmp-ribcage-640 syntmp-id-662 syntmp-label-663) (syntmp-parse-642 (cdr syntmp-body-643) (cons syntmp-id-662 syntmp-ids-644) (cons syntmp-label-663 syntmp-labels-645) syntmp-vars-646 syntmp-vals-647 (cons (cons (quote macro) (cons syntmp-er-651 (syntmp-wrap-145 syntmp-e-654 syntmp-w-655 syntmp-mod-657))) syntmp-bindings-648)))) (if (memv syntmp-t-658 (quote (begin-form))) ((lambda (syntmp-tmp-664) ((lambda (syntmp-tmp-665) (if syntmp-tmp-665 (apply (lambda (syntmp-_-666 syntmp-e1-667) (syntmp-parse-642 (let syntmp-f-668 ((syntmp-forms-669 syntmp-e1-667)) (if (null? syntmp-forms-669) (cdr syntmp-body-643) (cons (cons syntmp-er-651 (syntmp-wrap-145 (car syntmp-forms-669) syntmp-w-655 syntmp-mod-657)) (syntmp-f-668 (cdr syntmp-forms-669))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648)) syntmp-tmp-665) (syntax-error syntmp-tmp-664))) (syntax-dispatch syntmp-tmp-664 (quote (any . each-any))))) syntmp-e-654) (if (memv syntmp-t-658 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-653 syntmp-e-654 syntmp-er-651 syntmp-w-655 syntmp-s-656 syntmp-mod-657 (lambda (syntmp-forms-671 syntmp-er-672 syntmp-w-673 syntmp-s-674 syntmp-mod-675) (syntmp-parse-642 (let syntmp-f-676 ((syntmp-forms-677 syntmp-forms-671)) (if (null? syntmp-forms-677) (cdr syntmp-body-643) (cons (cons syntmp-er-672 (syntmp-wrap-145 (car syntmp-forms-677) syntmp-w-673 syntmp-mod-675)) (syntmp-f-676 (cdr syntmp-forms-677))))) syntmp-ids-644 syntmp-labels-645 syntmp-vars-646 syntmp-vals-647 syntmp-bindings-648))) (if (null? syntmp-ids-644) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-678) (syntmp-chi-153 (cdr syntmp-x-678) (car syntmp-x-678) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))) (begin (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-644)) (syntax-error syntmp-outer-form-635 "invalid or duplicate identifier in definition")) (let syntmp-loop-679 ((syntmp-bs-680 syntmp-bindings-648) (syntmp-er-cache-681 #f) (syntmp-r-cache-682 #f)) (if (not (null? syntmp-bs-680)) (let ((syntmp-b-683 (car syntmp-bs-680))) (if (eq? (car syntmp-b-683) (quote macro)) (let ((syntmp-er-684 (cadr syntmp-b-683))) (let ((syntmp-r-cache-685 (if (eq? syntmp-er-684 syntmp-er-cache-681) syntmp-r-cache-682 (syntmp-macros-only-env-113 syntmp-er-684)))) (begin (set-cdr! syntmp-b-683 (syntmp-eval-local-transformer-160 (syntmp-chi-153 (cddr syntmp-b-683) syntmp-r-cache-685 (quote (())) syntmp-mod-657) syntmp-mod-657)) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-684 syntmp-r-cache-685)))) (syntmp-loop-679 (cdr syntmp-bs-680) syntmp-er-cache-681 syntmp-r-cache-682))))) (set-cdr! syntmp-r-639 (syntmp-extend-env-111 syntmp-labels-645 syntmp-bindings-648 (cdr syntmp-r-639))) (syntmp-build-letrec-99 #f syntmp-vars-646 (map (lambda (syntmp-x-686) (syntmp-chi-153 (cdr syntmp-x-686) (car syntmp-x-686) (quote (())) syntmp-mod-657)) syntmp-vals-647) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-687) (syntmp-chi-153 (cdr syntmp-x-687) (car syntmp-x-687) (quote (())) syntmp-mod-657)) (cons (cons syntmp-er-651 (syntmp-source-wrap-146 syntmp-e-654 syntmp-w-655 syntmp-s-656 syntmp-mod-657)) (cdr syntmp-body-643)))))))))))))))))))))) (syntmp-chi-macro-156 (lambda (syntmp-p-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-rib-692 syntmp-mod-693) (letrec ((syntmp-rebuild-macro-output-694 (lambda (syntmp-x-695 syntmp-m-696) (cond ((pair? syntmp-x-695) (cons (syntmp-rebuild-macro-output-694 (car syntmp-x-695) syntmp-m-696) (syntmp-rebuild-macro-output-694 (cdr syntmp-x-695) syntmp-m-696))) ((syntmp-syntax-object?-101 syntmp-x-695) (let ((syntmp-w-697 (syntmp-syntax-object-wrap-103 syntmp-x-695))) (let ((syntmp-ms-698 (syntmp-wrap-marks-120 syntmp-w-697)) (syntmp-s-699 (syntmp-wrap-subst-121 syntmp-w-697))) (if (and (pair? syntmp-ms-698) (eq? (car syntmp-ms-698) #f)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cdr syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cdr syntmp-s-699)) (cdr syntmp-s-699))) (syntmp-syntax-object-module-104 syntmp-x-695)) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-695) (syntmp-make-wrap-119 (cons syntmp-m-696 syntmp-ms-698) (if syntmp-rib-692 (cons syntmp-rib-692 (cons (quote shift) syntmp-s-699)) (cons (quote shift) syntmp-s-699))) (module-name (procedure-module syntmp-p-688))))))) ((vector? syntmp-x-695) (let ((syntmp-n-700 (vector-length syntmp-x-695))) (let ((syntmp-v-701 (make-vector syntmp-n-700))) (let syntmp-doloop-702 ((syntmp-i-703 0)) (if (syntmp-fx=-87 syntmp-i-703 syntmp-n-700) syntmp-v-701 (begin (vector-set! syntmp-v-701 syntmp-i-703 (syntmp-rebuild-macro-output-694 (vector-ref syntmp-x-695 syntmp-i-703) syntmp-m-696)) (syntmp-doloop-702 (syntmp-fx+-85 syntmp-i-703 1)))))))) ((symbol? syntmp-x-695) (syntax-error syntmp-x-695 "encountered raw symbol in macro output")) (else syntmp-x-695))))) (syntmp-rebuild-macro-output-694 (syntmp-p-688 (syntmp-wrap-145 syntmp-e-689 (syntmp-anti-mark-132 syntmp-w-691) syntmp-mod-693)) (string #\m))))) (syntmp-chi-application-155 (lambda (syntmp-x-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) ((lambda (syntmp-tmp-710) ((lambda (syntmp-tmp-711) (if syntmp-tmp-711 (apply (lambda (syntmp-e0-712 syntmp-e1-713) (syntmp-build-annotated-94 syntmp-s-708 (cons syntmp-x-704 (map (lambda (syntmp-e-714) (syntmp-chi-153 syntmp-e-714 syntmp-r-706 syntmp-w-707 syntmp-mod-709)) syntmp-e1-713)))) syntmp-tmp-711) (syntax-error syntmp-tmp-710))) (syntax-dispatch syntmp-tmp-710 (quote (any . each-any))))) syntmp-e-705))) (syntmp-chi-expr-154 (lambda (syntmp-type-716 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (let ((syntmp-t-723 syntmp-type-716)) (if (memv syntmp-t-723 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-721 syntmp-value-717) (if (memv syntmp-t-723 (quote (core external-macro))) (syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (lexical-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) syntmp-value-717) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (global-call))) (syntmp-chi-application-155 (syntmp-build-annotated-94 (syntmp-source-annotation-108 (car syntmp-e-718)) (make-module-ref (if (syntmp-syntax-object?-101 (car syntmp-e-718)) (syntmp-syntax-object-module-104 (car syntmp-e-718)) syntmp-mod-722) syntmp-value-717 #f)) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (constant))) (syntmp-build-data-95 syntmp-s-721 (syntmp-strip-164 (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (quote (())))) (if (memv syntmp-t-723 (quote (global))) (syntmp-build-annotated-94 syntmp-s-721 (make-module-ref syntmp-mod-722 syntmp-value-717 #f)) (if (memv syntmp-t-723 (quote (call))) (syntmp-chi-application-155 (syntmp-chi-153 (car syntmp-e-718) syntmp-r-719 syntmp-w-720 syntmp-mod-722) syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (if (memv syntmp-t-723 (quote (begin-form))) ((lambda (syntmp-tmp-724) ((lambda (syntmp-tmp-725) (if syntmp-tmp-725 (apply (lambda (syntmp-_-726 syntmp-e1-727 syntmp-e2-728) (syntmp-chi-sequence-147 (cons syntmp-e1-727 syntmp-e2-728) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722)) syntmp-tmp-725) (syntax-error syntmp-tmp-724))) (syntax-dispatch syntmp-tmp-724 (quote (any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-717 syntmp-e-718 syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722 syntmp-chi-sequence-147) (if (memv syntmp-t-723 (quote (eval-when-form))) ((lambda (syntmp-tmp-730) ((lambda (syntmp-tmp-731) (if syntmp-tmp-731 (apply (lambda (syntmp-_-732 syntmp-x-733 syntmp-e1-734 syntmp-e2-735) (let ((syntmp-when-list-736 (syntmp-chi-when-list-150 syntmp-e-718 syntmp-x-733 syntmp-w-720))) (if (memq (quote eval) syntmp-when-list-736) (syntmp-chi-sequence-147 (cons syntmp-e1-734 syntmp-e2-735) syntmp-r-719 syntmp-w-720 syntmp-s-721 syntmp-mod-722) (syntmp-chi-void-161)))) syntmp-tmp-731) (syntax-error syntmp-tmp-730))) (syntax-dispatch syntmp-tmp-730 (quote (any each-any any . each-any))))) syntmp-e-718) (if (memv syntmp-t-723 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-145 syntmp-value-717 syntmp-w-720 syntmp-mod-722) "invalid context for definition of") (if (memv syntmp-t-723 (quote (syntax))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to pattern variable outside syntax form") (if (memv syntmp-t-723 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-146 syntmp-e-718 syntmp-w-720 syntmp-s-721 syntmp-mod-722)))))))))))))))))) (syntmp-chi-153 (lambda (syntmp-e-739 syntmp-r-740 syntmp-w-741 syntmp-mod-742) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-739 syntmp-r-740 syntmp-w-741 #f #f syntmp-mod-742)) (lambda (syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-w-746 syntmp-s-747 syntmp-mod-748) (syntmp-chi-expr-154 syntmp-type-743 syntmp-value-744 syntmp-e-745 syntmp-r-740 syntmp-w-746 syntmp-s-747 syntmp-mod-748))))) (syntmp-chi-top-152 (lambda (syntmp-e-749 syntmp-r-750 syntmp-w-751 syntmp-m-752 syntmp-esew-753 syntmp-mod-754) (call-with-values (lambda () (syntmp-syntax-type-151 syntmp-e-749 syntmp-r-750 syntmp-w-751 #f #f syntmp-mod-754)) (lambda (syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-w-772 syntmp-s-773 syntmp-mod-774) (let ((syntmp-t-775 syntmp-type-769)) (if (memv syntmp-t-775 (quote (begin-form))) ((lambda (syntmp-tmp-776) ((lambda (syntmp-tmp-777) (if syntmp-tmp-777 (apply (lambda (syntmp-_-778) (syntmp-chi-void-161)) syntmp-tmp-777) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-e1-781 syntmp-e2-782) (syntmp-chi-top-sequence-148 (cons syntmp-e1-781 syntmp-e2-782) syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-m-752 syntmp-esew-753 syntmp-mod-774)) syntmp-tmp-779) (syntax-error syntmp-tmp-776))) (syntax-dispatch syntmp-tmp-776 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-776 (quote (any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (local-syntax-form))) (syntmp-chi-local-syntax-159 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774 (lambda (syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-mod-788) (syntmp-chi-top-sequence-148 syntmp-body-784 syntmp-r-785 syntmp-w-786 syntmp-s-787 syntmp-m-752 syntmp-esew-753 syntmp-mod-788))) (if (memv syntmp-t-775 (quote (eval-when-form))) ((lambda (syntmp-tmp-789) ((lambda (syntmp-tmp-790) (if syntmp-tmp-790 (apply (lambda (syntmp-_-791 syntmp-x-792 syntmp-e1-793 syntmp-e2-794) (let ((syntmp-when-list-795 (syntmp-chi-when-list-150 syntmp-e-771 syntmp-x-792 syntmp-w-772)) (syntmp-body-796 (cons syntmp-e1-793 syntmp-e2-794))) (cond ((eq? syntmp-m-752 (quote e)) (if (memq (quote eval) syntmp-when-list-795) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) (syntmp-chi-void-161))) ((memq (quote load) syntmp-when-list-795) (if (or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c&e) (quote (compile load)) syntmp-mod-774) (if (memq syntmp-m-752 (quote (c c&e))) (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote c) (quote (load)) syntmp-mod-774) (syntmp-chi-void-161)))) ((or (memq (quote compile) syntmp-when-list-795) (and (eq? syntmp-m-752 (quote c&e)) (memq (quote eval) syntmp-when-list-795))) (syntmp-top-level-eval-hook-89 (syntmp-chi-top-sequence-148 syntmp-body-796 syntmp-r-750 syntmp-w-772 syntmp-s-773 (quote e) (quote (eval)) syntmp-mod-774) syntmp-mod-774) (syntmp-chi-void-161)) (else (syntmp-chi-void-161))))) syntmp-tmp-790) (syntax-error syntmp-tmp-789))) (syntax-dispatch syntmp-tmp-789 (quote (any each-any any . each-any))))) syntmp-e-771) (if (memv syntmp-t-775 (quote (define-syntax-form))) (let ((syntmp-n-799 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772)) (syntmp-r-800 (syntmp-macros-only-env-113 syntmp-r-750))) (let ((syntmp-t-801 syntmp-m-752)) (if (memv syntmp-t-801 (quote (c))) (if (memq (quote compile) syntmp-esew-753) (let ((syntmp-e-802 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-802 syntmp-mod-774) (if (memq (quote load) syntmp-esew-753) syntmp-e-802 (syntmp-chi-void-161)))) (if (memq (quote load) syntmp-esew-753) (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) (syntmp-chi-void-161))) (if (memv syntmp-t-801 (quote (c&e))) (let ((syntmp-e-803 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)))) (begin (syntmp-top-level-eval-hook-89 syntmp-e-803 syntmp-mod-774) syntmp-e-803)) (begin (if (memq (quote eval) syntmp-esew-753) (syntmp-top-level-eval-hook-89 (syntmp-chi-install-global-149 syntmp-n-799 (syntmp-chi-153 syntmp-e-771 syntmp-r-800 syntmp-w-772 syntmp-mod-774)) syntmp-mod-774)) (syntmp-chi-void-161)))))) (if (memv syntmp-t-775 (quote (define-form))) (let ((syntmp-n-804 (syntmp-id-var-name-139 syntmp-value-770 syntmp-w-772))) (let ((syntmp-type-805 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-804 syntmp-r-750 syntmp-mod-774)))) (let ((syntmp-t-806 syntmp-type-805)) (if (memv syntmp-t-806 (quote (global))) (let ((syntmp-x-807 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-807 syntmp-mod-774)) syntmp-x-807)) (if (memv syntmp-t-806 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "identifier out of context") (if (eq? syntmp-type-805 (quote external-macro)) (let ((syntmp-x-808 (syntmp-build-annotated-94 syntmp-s-773 (list (quote define) syntmp-n-804 (syntmp-chi-153 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-mod-774))))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-808 syntmp-mod-774)) syntmp-x-808)) (syntax-error (syntmp-wrap-145 syntmp-value-770 syntmp-w-772 syntmp-mod-774) "cannot define keyword at top level"))))))) (let ((syntmp-x-809 (syntmp-chi-expr-154 syntmp-type-769 syntmp-value-770 syntmp-e-771 syntmp-r-750 syntmp-w-772 syntmp-s-773 syntmp-mod-774))) (begin (if (eq? syntmp-m-752 (quote c&e)) (syntmp-top-level-eval-hook-89 syntmp-x-809 syntmp-mod-774)) syntmp-x-809)))))))))))) (syntmp-syntax-type-151 (lambda (syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (cond ((symbol? syntmp-e-810) (let ((syntmp-n-816 (syntmp-id-var-name-139 syntmp-e-810 syntmp-w-812))) (let ((syntmp-b-817 (syntmp-lookup-114 syntmp-n-816 syntmp-r-811 syntmp-mod-815))) (let ((syntmp-type-818 (syntmp-binding-type-109 syntmp-b-817))) (let ((syntmp-t-819 syntmp-type-818)) (if (memv syntmp-t-819 (quote (lexical))) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (global))) (values syntmp-type-818 syntmp-n-816 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-819 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (values syntmp-type-818 (syntmp-binding-value-110 syntmp-b-817) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))))))) ((pair? syntmp-e-810) (let ((syntmp-first-820 (car syntmp-e-810))) (if (syntmp-id?-117 syntmp-first-820) (let ((syntmp-n-821 (syntmp-id-var-name-139 syntmp-first-820 syntmp-w-812))) (let ((syntmp-b-822 (syntmp-lookup-114 syntmp-n-821 syntmp-r-811 (or (and (syntmp-syntax-object?-101 syntmp-first-820) (syntmp-syntax-object-module-104 syntmp-first-820)) syntmp-mod-815)))) (let ((syntmp-type-823 (syntmp-binding-type-109 syntmp-b-822))) (let ((syntmp-t-824 syntmp-type-823)) (if (memv syntmp-t-824 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (global))) (values (quote global-call) syntmp-n-821 syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (macro))) (syntmp-syntax-type-151 (syntmp-chi-macro-156 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-r-811 syntmp-w-812 syntmp-rib-814 syntmp-mod-815) syntmp-r-811 (quote (())) syntmp-s-813 syntmp-rib-814 syntmp-mod-815) (if (memv syntmp-t-824 (quote (core external-macro))) (values syntmp-type-823 (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-110 syntmp-b-822) syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (begin))) (values (quote begin-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815) (if (memv syntmp-t-824 (quote (define))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-117 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-form) syntmp-name-831 syntmp-val-832 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-826) ((lambda (syntmp-tmp-833) (if (if syntmp-tmp-833 (apply (lambda (syntmp-_-834 syntmp-name-835 syntmp-args-836 syntmp-e1-837 syntmp-e2-838) (and (syntmp-id?-117 syntmp-name-835) (syntmp-valid-bound-ids?-142 (syntmp-lambda-var-list-166 syntmp-args-836)))) syntmp-tmp-833) #f) (apply (lambda (syntmp-_-839 syntmp-name-840 syntmp-args-841 syntmp-e1-842 syntmp-e2-843) (values (quote define-form) (syntmp-wrap-145 syntmp-name-840 syntmp-w-812 syntmp-mod-815) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-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-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-145 (cons syntmp-args-841 (cons syntmp-e1-842 syntmp-e2-843)) syntmp-w-812 syntmp-mod-815)) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-833) ((lambda (syntmp-tmp-845) (if (if syntmp-tmp-845 (apply (lambda (syntmp-_-846 syntmp-name-847) (syntmp-id?-117 syntmp-name-847)) syntmp-tmp-845) #f) (apply (lambda (syntmp-_-848 syntmp-name-849) (values (quote define-form) (syntmp-wrap-145 syntmp-name-849 syntmp-w-812 syntmp-mod-815) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-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-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-813 syntmp-mod-815)) syntmp-tmp-845) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-810) (if (memv syntmp-t-824 (quote (define-syntax))) ((lambda (syntmp-tmp-850) ((lambda (syntmp-tmp-851) (if (if syntmp-tmp-851 (apply (lambda (syntmp-_-852 syntmp-name-853 syntmp-val-854) (syntmp-id?-117 syntmp-name-853)) syntmp-tmp-851) #f) (apply (lambda (syntmp-_-855 syntmp-name-856 syntmp-val-857) (values (quote define-syntax-form) syntmp-name-856 syntmp-val-857 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) syntmp-tmp-851) (syntax-error syntmp-tmp-850))) (syntax-dispatch syntmp-tmp-850 (quote (any any any))))) syntmp-e-810) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))))))))))))) (values (quote call) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)))) ((syntmp-syntax-object?-101 syntmp-e-810) (syntmp-syntax-type-151 (syntmp-syntax-object-expression-102 syntmp-e-810) syntmp-r-811 (syntmp-join-wraps-136 syntmp-w-812 (syntmp-syntax-object-wrap-103 syntmp-e-810)) #f syntmp-rib-814 (or (syntmp-syntax-object-module-104 syntmp-e-810) syntmp-mod-815))) ((annotation? syntmp-e-810) (syntmp-syntax-type-151 (annotation-expression syntmp-e-810) syntmp-r-811 syntmp-w-812 (annotation-source syntmp-e-810) syntmp-rib-814 syntmp-mod-815)) ((self-evaluating? syntmp-e-810) (values (quote constant) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815)) (else (values (quote other) #f syntmp-e-810 syntmp-w-812 syntmp-s-813 syntmp-mod-815))))) (syntmp-chi-when-list-150 (lambda (syntmp-e-858 syntmp-when-list-859 syntmp-w-860) (let syntmp-f-861 ((syntmp-when-list-862 syntmp-when-list-859) (syntmp-situations-863 (quote ()))) (if (null? syntmp-when-list-862) syntmp-situations-863 (syntmp-f-861 (cdr syntmp-when-list-862) (cons (let ((syntmp-x-864 (car syntmp-when-list-862))) (cond ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-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-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-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-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-140 syntmp-x-864 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-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-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-145 syntmp-x-864 syntmp-w-860 #f) "invalid eval-when situation")))) syntmp-situations-863)))))) (syntmp-chi-install-global-149 (lambda (syntmp-name-869 syntmp-e-870) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote install-global-transformer)) (syntmp-build-data-95 #f syntmp-name-869) syntmp-e-870)))) (syntmp-chi-top-sequence-148 (lambda (syntmp-body-871 syntmp-r-872 syntmp-w-873 syntmp-s-874 syntmp-m-875 syntmp-esew-876 syntmp-mod-877) (syntmp-build-sequence-96 syntmp-s-874 (let syntmp-dobody-878 ((syntmp-body-879 syntmp-body-871) (syntmp-r-880 syntmp-r-872) (syntmp-w-881 syntmp-w-873) (syntmp-m-882 syntmp-m-875) (syntmp-esew-883 syntmp-esew-876) (syntmp-mod-884 syntmp-mod-877)) (if (null? syntmp-body-879) (quote ()) (let ((syntmp-first-885 (syntmp-chi-top-152 (car syntmp-body-879) syntmp-r-880 syntmp-w-881 syntmp-m-882 syntmp-esew-883 syntmp-mod-884))) (cons syntmp-first-885 (syntmp-dobody-878 (cdr syntmp-body-879) syntmp-r-880 syntmp-w-881 syntmp-m-882 syntmp-esew-883 syntmp-mod-884)))))))) (syntmp-chi-sequence-147 (lambda (syntmp-body-886 syntmp-r-887 syntmp-w-888 syntmp-s-889 syntmp-mod-890) (syntmp-build-sequence-96 syntmp-s-889 (let syntmp-dobody-891 ((syntmp-body-892 syntmp-body-886) (syntmp-r-893 syntmp-r-887) (syntmp-w-894 syntmp-w-888) (syntmp-mod-895 syntmp-mod-890)) (if (null? syntmp-body-892) (quote ()) (let ((syntmp-first-896 (syntmp-chi-153 (car syntmp-body-892) syntmp-r-893 syntmp-w-894 syntmp-mod-895))) (cons syntmp-first-896 (syntmp-dobody-891 (cdr syntmp-body-892) syntmp-r-893 syntmp-w-894 syntmp-mod-895)))))))) (syntmp-source-wrap-146 (lambda (syntmp-x-897 syntmp-w-898 syntmp-s-899 syntmp-defmod-900) (syntmp-wrap-145 (if syntmp-s-899 (make-annotation syntmp-x-897 syntmp-s-899 #f) syntmp-x-897) syntmp-w-898 syntmp-defmod-900))) (syntmp-wrap-145 (lambda (syntmp-x-901 syntmp-w-902 syntmp-defmod-903) (cond ((and (null? (syntmp-wrap-marks-120 syntmp-w-902)) (null? (syntmp-wrap-subst-121 syntmp-w-902))) syntmp-x-901) ((syntmp-syntax-object?-101 syntmp-x-901) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-901) (syntmp-join-wraps-136 syntmp-w-902 (syntmp-syntax-object-wrap-103 syntmp-x-901)) (syntmp-syntax-object-module-104 syntmp-x-901))) ((null? syntmp-x-901) syntmp-x-901) (else (syntmp-make-syntax-object-100 syntmp-x-901 syntmp-w-902 syntmp-defmod-903))))) (syntmp-bound-id-member?-144 (lambda (syntmp-x-904 syntmp-list-905) (and (not (null? syntmp-list-905)) (or (syntmp-bound-id=?-141 syntmp-x-904 (car syntmp-list-905)) (syntmp-bound-id-member?-144 syntmp-x-904 (cdr syntmp-list-905)))))) (syntmp-distinct-bound-ids?-143 (lambda (syntmp-ids-906) (let syntmp-distinct?-907 ((syntmp-ids-908 syntmp-ids-906)) (or (null? syntmp-ids-908) (and (not (syntmp-bound-id-member?-144 (car syntmp-ids-908) (cdr syntmp-ids-908))) (syntmp-distinct?-907 (cdr syntmp-ids-908))))))) (syntmp-valid-bound-ids?-142 (lambda (syntmp-ids-909) (and (let syntmp-all-ids?-910 ((syntmp-ids-911 syntmp-ids-909)) (or (null? syntmp-ids-911) (and (syntmp-id?-117 (car syntmp-ids-911)) (syntmp-all-ids?-910 (cdr syntmp-ids-911))))) (syntmp-distinct-bound-ids?-143 syntmp-ids-909)))) (syntmp-bound-id=?-141 (lambda (syntmp-i-912 syntmp-j-913) (if (and (syntmp-syntax-object?-101 syntmp-i-912) (syntmp-syntax-object?-101 syntmp-j-913)) (and (eq? (let ((syntmp-e-914 (syntmp-syntax-object-expression-102 syntmp-i-912))) (if (annotation? syntmp-e-914) (annotation-expression syntmp-e-914) syntmp-e-914)) (let ((syntmp-e-915 (syntmp-syntax-object-expression-102 syntmp-j-913))) (if (annotation? syntmp-e-915) (annotation-expression syntmp-e-915) syntmp-e-915))) (syntmp-same-marks?-138 (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-i-912)) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-j-913)))) (eq? (let ((syntmp-e-916 syntmp-i-912)) (if (annotation? syntmp-e-916) (annotation-expression syntmp-e-916) syntmp-e-916)) (let ((syntmp-e-917 syntmp-j-913)) (if (annotation? syntmp-e-917) (annotation-expression syntmp-e-917) syntmp-e-917)))))) (syntmp-free-id=?-140 (lambda (syntmp-i-918 syntmp-j-919) (and (eq? (let ((syntmp-x-920 syntmp-i-918)) (let ((syntmp-e-921 (if (syntmp-syntax-object?-101 syntmp-x-920) (syntmp-syntax-object-expression-102 syntmp-x-920) syntmp-x-920))) (if (annotation? syntmp-e-921) (annotation-expression syntmp-e-921) syntmp-e-921))) (let ((syntmp-x-922 syntmp-j-919)) (let ((syntmp-e-923 (if (syntmp-syntax-object?-101 syntmp-x-922) (syntmp-syntax-object-expression-102 syntmp-x-922) syntmp-x-922))) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)))) (eq? (syntmp-id-var-name-139 syntmp-i-918 (quote (()))) (syntmp-id-var-name-139 syntmp-j-919 (quote (()))))))) (syntmp-id-var-name-139 (lambda (syntmp-id-924 syntmp-w-925) (letrec ((syntmp-search-vector-rib-928 (lambda (syntmp-sym-939 syntmp-subst-940 syntmp-marks-941 syntmp-symnames-942 syntmp-ribcage-943) (let ((syntmp-n-944 (vector-length syntmp-symnames-942))) (let syntmp-f-945 ((syntmp-i-946 0)) (cond ((syntmp-fx=-87 syntmp-i-946 syntmp-n-944) (syntmp-search-926 syntmp-sym-939 (cdr syntmp-subst-940) syntmp-marks-941)) ((and (eq? (vector-ref syntmp-symnames-942 syntmp-i-946) syntmp-sym-939) (syntmp-same-marks?-138 syntmp-marks-941 (vector-ref (syntmp-ribcage-marks-127 syntmp-ribcage-943) syntmp-i-946))) (values (vector-ref (syntmp-ribcage-labels-128 syntmp-ribcage-943) syntmp-i-946) syntmp-marks-941)) (else (syntmp-f-945 (syntmp-fx+-85 syntmp-i-946 1)))))))) (syntmp-search-list-rib-927 (lambda (syntmp-sym-947 syntmp-subst-948 syntmp-marks-949 syntmp-symnames-950 syntmp-ribcage-951) (let syntmp-f-952 ((syntmp-symnames-953 syntmp-symnames-950) (syntmp-i-954 0)) (cond ((null? syntmp-symnames-953) (syntmp-search-926 syntmp-sym-947 (cdr syntmp-subst-948) syntmp-marks-949)) ((and (eq? (car syntmp-symnames-953) syntmp-sym-947) (syntmp-same-marks?-138 syntmp-marks-949 (list-ref (syntmp-ribcage-marks-127 syntmp-ribcage-951) syntmp-i-954))) (values (list-ref (syntmp-ribcage-labels-128 syntmp-ribcage-951) syntmp-i-954) syntmp-marks-949)) (else (syntmp-f-952 (cdr syntmp-symnames-953) (syntmp-fx+-85 syntmp-i-954 1))))))) (syntmp-search-926 (lambda (syntmp-sym-955 syntmp-subst-956 syntmp-marks-957) (if (null? syntmp-subst-956) (values #f syntmp-marks-957) (let ((syntmp-fst-958 (car syntmp-subst-956))) (if (eq? syntmp-fst-958 (quote shift)) (syntmp-search-926 syntmp-sym-955 (cdr syntmp-subst-956) (cdr syntmp-marks-957)) (let ((syntmp-symnames-959 (syntmp-ribcage-symnames-126 syntmp-fst-958))) (if (vector? syntmp-symnames-959) (syntmp-search-vector-rib-928 syntmp-sym-955 syntmp-subst-956 syntmp-marks-957 syntmp-symnames-959 syntmp-fst-958) (syntmp-search-list-rib-927 syntmp-sym-955 syntmp-subst-956 syntmp-marks-957 syntmp-symnames-959 syntmp-fst-958))))))))) (cond ((symbol? syntmp-id-924) (or (call-with-values (lambda () (syntmp-search-926 syntmp-id-924 (syntmp-wrap-subst-121 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w-925))) (lambda (syntmp-x-961 . syntmp-ignore-960) syntmp-x-961)) syntmp-id-924)) ((syntmp-syntax-object?-101 syntmp-id-924) (let ((syntmp-id-962 (let ((syntmp-e-964 (syntmp-syntax-object-expression-102 syntmp-id-924))) (if (annotation? syntmp-e-964) (annotation-expression syntmp-e-964) syntmp-e-964))) (syntmp-w1-963 (syntmp-syntax-object-wrap-103 syntmp-id-924))) (let ((syntmp-marks-965 (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w1-963)))) (call-with-values (lambda () (syntmp-search-926 syntmp-id-962 (syntmp-wrap-subst-121 syntmp-w-925) syntmp-marks-965)) (lambda (syntmp-new-id-966 syntmp-marks-967) (or syntmp-new-id-966 (call-with-values (lambda () (syntmp-search-926 syntmp-id-962 (syntmp-wrap-subst-121 syntmp-w1-963) syntmp-marks-967)) (lambda (syntmp-x-969 . syntmp-ignore-968) syntmp-x-969)) syntmp-id-962)))))) ((annotation? syntmp-id-924) (let ((syntmp-id-970 (let ((syntmp-e-971 syntmp-id-924)) (if (annotation? syntmp-e-971) (annotation-expression syntmp-e-971) syntmp-e-971)))) (or (call-with-values (lambda () (syntmp-search-926 syntmp-id-970 (syntmp-wrap-subst-121 syntmp-w-925) (syntmp-wrap-marks-120 syntmp-w-925))) (lambda (syntmp-x-973 . syntmp-ignore-972) syntmp-x-973)) syntmp-id-970))) (else (syntmp-error-hook-91 (quote id-var-name) "invalid id" syntmp-id-924)))))) (syntmp-same-marks?-138 (lambda (syntmp-x-974 syntmp-y-975) (or (eq? syntmp-x-974 syntmp-y-975) (and (not (null? syntmp-x-974)) (not (null? syntmp-y-975)) (eq? (car syntmp-x-974) (car syntmp-y-975)) (syntmp-same-marks?-138 (cdr syntmp-x-974) (cdr syntmp-y-975)))))) (syntmp-join-marks-137 (lambda (syntmp-m1-976 syntmp-m2-977) (syntmp-smart-append-135 syntmp-m1-976 syntmp-m2-977))) (syntmp-join-wraps-136 (lambda (syntmp-w1-978 syntmp-w2-979) (let ((syntmp-m1-980 (syntmp-wrap-marks-120 syntmp-w1-978)) (syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w1-978))) (if (null? syntmp-m1-980) (if (null? syntmp-s1-981) syntmp-w2-979 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w2-979) (syntmp-smart-append-135 syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w2-979)))) (syntmp-make-wrap-119 (syntmp-smart-append-135 syntmp-m1-980 (syntmp-wrap-marks-120 syntmp-w2-979)) (syntmp-smart-append-135 syntmp-s1-981 (syntmp-wrap-subst-121 syntmp-w2-979))))))) (syntmp-smart-append-135 (lambda (syntmp-m1-982 syntmp-m2-983) (if (null? syntmp-m2-983) syntmp-m1-982 (append syntmp-m1-982 syntmp-m2-983)))) (syntmp-make-binding-wrap-134 (lambda (syntmp-ids-984 syntmp-labels-985 syntmp-w-986) (if (null? syntmp-ids-984) syntmp-w-986 (syntmp-make-wrap-119 (syntmp-wrap-marks-120 syntmp-w-986) (cons (let ((syntmp-labelvec-987 (list->vector syntmp-labels-985))) (let ((syntmp-n-988 (vector-length syntmp-labelvec-987))) (let ((syntmp-symnamevec-989 (make-vector syntmp-n-988)) (syntmp-marksvec-990 (make-vector syntmp-n-988))) (begin (let syntmp-f-991 ((syntmp-ids-992 syntmp-ids-984) (syntmp-i-993 0)) (if (not (null? syntmp-ids-992)) (call-with-values (lambda () (syntmp-id-sym-name&marks-118 (car syntmp-ids-992) syntmp-w-986)) (lambda (syntmp-symname-994 syntmp-marks-995) (begin (vector-set! syntmp-symnamevec-989 syntmp-i-993 syntmp-symname-994) (vector-set! syntmp-marksvec-990 syntmp-i-993 syntmp-marks-995) (syntmp-f-991 (cdr syntmp-ids-992) (syntmp-fx+-85 syntmp-i-993 1))))))) (syntmp-make-ribcage-124 syntmp-symnamevec-989 syntmp-marksvec-990 syntmp-labelvec-987))))) (syntmp-wrap-subst-121 syntmp-w-986)))))) (syntmp-extend-ribcage!-133 (lambda (syntmp-ribcage-996 syntmp-id-997 syntmp-label-998) (begin (syntmp-set-ribcage-symnames!-129 syntmp-ribcage-996 (cons (let ((syntmp-e-999 (syntmp-syntax-object-expression-102 syntmp-id-997))) (if (annotation? syntmp-e-999) (annotation-expression syntmp-e-999) syntmp-e-999)) (syntmp-ribcage-symnames-126 syntmp-ribcage-996))) (syntmp-set-ribcage-marks!-130 syntmp-ribcage-996 (cons (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-id-997)) (syntmp-ribcage-marks-127 syntmp-ribcage-996))) (syntmp-set-ribcage-labels!-131 syntmp-ribcage-996 (cons syntmp-label-998 (syntmp-ribcage-labels-128 syntmp-ribcage-996)))))) (syntmp-anti-mark-132 (lambda (syntmp-w-1000) (syntmp-make-wrap-119 (cons #f (syntmp-wrap-marks-120 syntmp-w-1000)) (cons (quote shift) (syntmp-wrap-subst-121 syntmp-w-1000))))) (syntmp-set-ribcage-labels!-131 (lambda (syntmp-x-1001 syntmp-update-1002) (vector-set! syntmp-x-1001 3 syntmp-update-1002))) (syntmp-set-ribcage-marks!-130 (lambda (syntmp-x-1003 syntmp-update-1004) (vector-set! syntmp-x-1003 2 syntmp-update-1004))) (syntmp-set-ribcage-symnames!-129 (lambda (syntmp-x-1005 syntmp-update-1006) (vector-set! syntmp-x-1005 1 syntmp-update-1006))) (syntmp-ribcage-labels-128 (lambda (syntmp-x-1007) (vector-ref syntmp-x-1007 3))) (syntmp-ribcage-marks-127 (lambda (syntmp-x-1008) (vector-ref syntmp-x-1008 2))) (syntmp-ribcage-symnames-126 (lambda (syntmp-x-1009) (vector-ref syntmp-x-1009 1))) (syntmp-ribcage?-125 (lambda (syntmp-x-1010) (and (vector? syntmp-x-1010) (= (vector-length syntmp-x-1010) 4) (eq? (vector-ref syntmp-x-1010 0) (quote ribcage))))) (syntmp-make-ribcage-124 (lambda (syntmp-symnames-1011 syntmp-marks-1012 syntmp-labels-1013) (vector (quote ribcage) syntmp-symnames-1011 syntmp-marks-1012 syntmp-labels-1013))) (syntmp-gen-labels-123 (lambda (syntmp-ls-1014) (if (null? syntmp-ls-1014) (quote ()) (cons (syntmp-gen-label-122) (syntmp-gen-labels-123 (cdr syntmp-ls-1014)))))) (syntmp-gen-label-122 (lambda () (string #\i))) (syntmp-wrap-subst-121 cdr) (syntmp-wrap-marks-120 car) (syntmp-make-wrap-119 cons) (syntmp-id-sym-name&marks-118 (lambda (syntmp-x-1015 syntmp-w-1016) (if (syntmp-syntax-object?-101 syntmp-x-1015) (values (let ((syntmp-e-1017 (syntmp-syntax-object-expression-102 syntmp-x-1015))) (if (annotation? syntmp-e-1017) (annotation-expression syntmp-e-1017) syntmp-e-1017)) (syntmp-join-marks-137 (syntmp-wrap-marks-120 syntmp-w-1016) (syntmp-wrap-marks-120 (syntmp-syntax-object-wrap-103 syntmp-x-1015)))) (values (let ((syntmp-e-1018 syntmp-x-1015)) (if (annotation? syntmp-e-1018) (annotation-expression syntmp-e-1018) syntmp-e-1018)) (syntmp-wrap-marks-120 syntmp-w-1016))))) (syntmp-id?-117 (lambda (syntmp-x-1019) (cond ((symbol? syntmp-x-1019) #t) ((syntmp-syntax-object?-101 syntmp-x-1019) (symbol? (let ((syntmp-e-1020 (syntmp-syntax-object-expression-102 syntmp-x-1019))) (if (annotation? syntmp-e-1020) (annotation-expression syntmp-e-1020) syntmp-e-1020)))) ((annotation? syntmp-x-1019) (symbol? (annotation-expression syntmp-x-1019))) (else #f)))) (syntmp-nonsymbol-id?-116 (lambda (syntmp-x-1021) (and (syntmp-syntax-object?-101 syntmp-x-1021) (symbol? (let ((syntmp-e-1022 (syntmp-syntax-object-expression-102 syntmp-x-1021))) (if (annotation? syntmp-e-1022) (annotation-expression syntmp-e-1022) syntmp-e-1022)))))) (syntmp-global-extend-115 (lambda (syntmp-type-1023 syntmp-sym-1024 syntmp-val-1025) (syntmp-put-global-definition-hook-92 syntmp-sym-1024 (cons syntmp-type-1023 syntmp-val-1025) (module-name (current-module))))) (syntmp-lookup-114 (lambda (syntmp-x-1026 syntmp-r-1027 syntmp-mod-1028) (cond ((assq syntmp-x-1026 syntmp-r-1027) => cdr) ((symbol? syntmp-x-1026) (or (syntmp-get-global-definition-hook-93 syntmp-x-1026 syntmp-mod-1028) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-113 (lambda (syntmp-r-1029) (if (null? syntmp-r-1029) (quote ()) (let ((syntmp-a-1030 (car syntmp-r-1029))) (if (eq? (cadr syntmp-a-1030) (quote macro)) (cons syntmp-a-1030 (syntmp-macros-only-env-113 (cdr syntmp-r-1029))) (syntmp-macros-only-env-113 (cdr syntmp-r-1029))))))) (syntmp-extend-var-env-112 (lambda (syntmp-labels-1031 syntmp-vars-1032 syntmp-r-1033) (if (null? syntmp-labels-1031) syntmp-r-1033 (syntmp-extend-var-env-112 (cdr syntmp-labels-1031) (cdr syntmp-vars-1032) (cons (cons (car syntmp-labels-1031) (cons (quote lexical) (car syntmp-vars-1032))) syntmp-r-1033))))) (syntmp-extend-env-111 (lambda (syntmp-labels-1034 syntmp-bindings-1035 syntmp-r-1036) (if (null? syntmp-labels-1034) syntmp-r-1036 (syntmp-extend-env-111 (cdr syntmp-labels-1034) (cdr syntmp-bindings-1035) (cons (cons (car syntmp-labels-1034) (car syntmp-bindings-1035)) syntmp-r-1036))))) (syntmp-binding-value-110 cdr) (syntmp-binding-type-109 car) (syntmp-source-annotation-108 (lambda (syntmp-x-1037) (cond ((annotation? syntmp-x-1037) (annotation-source syntmp-x-1037)) ((syntmp-syntax-object?-101 syntmp-x-1037) (syntmp-source-annotation-108 (syntmp-syntax-object-expression-102 syntmp-x-1037))) (else #f)))) (syntmp-set-syntax-object-module!-107 (lambda (syntmp-x-1038 syntmp-update-1039) (vector-set! syntmp-x-1038 3 syntmp-update-1039))) (syntmp-set-syntax-object-wrap!-106 (lambda (syntmp-x-1040 syntmp-update-1041) (vector-set! syntmp-x-1040 2 syntmp-update-1041))) (syntmp-set-syntax-object-expression!-105 (lambda (syntmp-x-1042 syntmp-update-1043) (vector-set! syntmp-x-1042 1 syntmp-update-1043))) (syntmp-syntax-object-module-104 (lambda (syntmp-x-1044) (vector-ref syntmp-x-1044 3))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1045) (vector-ref syntmp-x-1045 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1046) (vector-ref syntmp-x-1046 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1047) (and (vector? syntmp-x-1047) (= (vector-length syntmp-x-1047) 4) (eq? (vector-ref syntmp-x-1047 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1048 syntmp-wrap-1049 syntmp-module-1050) (vector (quote syntax-object) syntmp-expression-1048 syntmp-wrap-1049 syntmp-module-1050))) (syntmp-build-letrec-99 (lambda (syntmp-src-1051 syntmp-vars-1052 syntmp-val-exps-1053 syntmp-body-exp-1054) (if (null? syntmp-vars-1052) (syntmp-build-annotated-94 syntmp-src-1051 syntmp-body-exp-1054) (syntmp-build-annotated-94 syntmp-src-1051 (list (quote letrec) (map list syntmp-vars-1052 syntmp-val-exps-1053) syntmp-body-exp-1054))))) (syntmp-build-named-let-98 (lambda (syntmp-src-1055 syntmp-vars-1056 syntmp-val-exps-1057 syntmp-body-exp-1058) (if (null? syntmp-vars-1056) (syntmp-build-annotated-94 syntmp-src-1055 syntmp-body-exp-1058) (syntmp-build-annotated-94 syntmp-src-1055 (list (quote let) (car syntmp-vars-1056) (map list (cdr syntmp-vars-1056) syntmp-val-exps-1057) syntmp-body-exp-1058))))) (syntmp-build-let-97 (lambda (syntmp-src-1059 syntmp-vars-1060 syntmp-val-exps-1061 syntmp-body-exp-1062) (if (null? syntmp-vars-1060) (syntmp-build-annotated-94 syntmp-src-1059 syntmp-body-exp-1062) (syntmp-build-annotated-94 syntmp-src-1059 (list (quote let) (map list syntmp-vars-1060 syntmp-val-exps-1061) syntmp-body-exp-1062))))) (syntmp-build-sequence-96 (lambda (syntmp-src-1063 syntmp-exps-1064) (if (null? (cdr syntmp-exps-1064)) (syntmp-build-annotated-94 syntmp-src-1063 (car syntmp-exps-1064)) (syntmp-build-annotated-94 syntmp-src-1063 (cons (quote begin) syntmp-exps-1064))))) (syntmp-build-data-95 (lambda (syntmp-src-1065 syntmp-exp-1066) (if (and (self-evaluating? syntmp-exp-1066) (not (vector? syntmp-exp-1066))) (syntmp-build-annotated-94 syntmp-src-1065 syntmp-exp-1066) (syntmp-build-annotated-94 syntmp-src-1065 (list (quote quote) syntmp-exp-1066))))) (syntmp-build-annotated-94 (lambda (syntmp-src-1067 syntmp-exp-1068) (if (and syntmp-src-1067 (not (annotation? syntmp-exp-1068))) (make-annotation syntmp-exp-1068 syntmp-src-1067 #t) syntmp-exp-1068))) (syntmp-get-global-definition-hook-93 (lambda (syntmp-symbol-1069 syntmp-module-1070) (let ((syntmp-module-1071 (if syntmp-module-1070 (resolve-module syntmp-module-1070) (warn "wha" syntmp-symbol-1069 (current-module))))) (let ((syntmp-v-1072 (module-variable syntmp-module-1071 syntmp-symbol-1069))) (and syntmp-v-1072 (or (object-property syntmp-v-1072 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1072) (macro? (variable-ref syntmp-v-1072)) (macro-transformer (variable-ref syntmp-v-1072)) guile-macro))))))) (syntmp-put-global-definition-hook-92 (lambda (syntmp-symbol-1073 syntmp-binding-1074 syntmp-module-1075) (let ((syntmp-module-1076 (if syntmp-module-1075 (resolve-module syntmp-module-1075) (warn "wha" syntmp-symbol-1073 (current-module))))) (let ((syntmp-v-1077 (or (module-variable syntmp-module-1076 syntmp-symbol-1073) (let ((syntmp-v-1078 (make-variable sc-macro))) (begin (module-add! syntmp-module-1076 syntmp-symbol-1073 syntmp-v-1078) syntmp-v-1078))))) (begin (if (not (and (symbol-property syntmp-symbol-1073 (quote primitive-syntax)) (eq? syntmp-module-1076 the-syncase-module))) (variable-set! syntmp-v-1077 sc-macro)) (set-object-property! syntmp-v-1077 (quote *sc-expander*) syntmp-binding-1074)))))) (syntmp-error-hook-91 (lambda (syntmp-who-1079 syntmp-why-1080 syntmp-what-1081) (error syntmp-who-1079 "~a ~s" syntmp-why-1080 syntmp-what-1081))) (syntmp-local-eval-hook-90 (lambda (syntmp-x-1082 syntmp-mod-1083) (eval (list syntmp-noexpand-84 syntmp-x-1082) (if syntmp-mod-1083 (resolve-module syntmp-mod-1083) (interaction-environment))))) (syntmp-top-level-eval-hook-89 (lambda (syntmp-x-1084 syntmp-mod-1085) (eval (list syntmp-noexpand-84 syntmp-x-1084) (if syntmp-mod-1085 (resolve-module syntmp-mod-1085) (interaction-environment))))) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-115 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-115 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-115 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1086 syntmp-r-1087 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) ((lambda (syntmp-tmp-1091) ((lambda (syntmp-tmp-1092) (if (if syntmp-tmp-1092 (apply (lambda (syntmp-_-1093 syntmp-var-1094 syntmp-val-1095 syntmp-e1-1096 syntmp-e2-1097) (syntmp-valid-bound-ids?-142 syntmp-var-1094)) syntmp-tmp-1092) #f) (apply (lambda (syntmp-_-1099 syntmp-var-1100 syntmp-val-1101 syntmp-e1-1102 syntmp-e2-1103) (let ((syntmp-names-1104 (map (lambda (syntmp-x-1105) (syntmp-id-var-name-139 syntmp-x-1105 syntmp-w-1088)) syntmp-var-1100))) (begin (for-each (lambda (syntmp-id-1107 syntmp-n-1108) (let ((syntmp-t-1109 (syntmp-binding-type-109 (syntmp-lookup-114 syntmp-n-1108 syntmp-r-1087 syntmp-mod-1090)))) (if (memv syntmp-t-1109 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-146 syntmp-id-1107 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) "identifier out of context")))) syntmp-var-1100 syntmp-names-1104) (syntmp-chi-body-157 (cons syntmp-e1-1102 syntmp-e2-1103) (syntmp-source-wrap-146 syntmp-e-1086 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090) (syntmp-extend-env-111 syntmp-names-1104 (let ((syntmp-trans-r-1112 (syntmp-macros-only-env-113 syntmp-r-1087))) (map (lambda (syntmp-x-1113) (cons (quote macro) (syntmp-eval-local-transformer-160 (syntmp-chi-153 syntmp-x-1113 syntmp-trans-r-1112 syntmp-w-1088 syntmp-mod-1090) syntmp-mod-1090))) syntmp-val-1101)) syntmp-r-1087) syntmp-w-1088 syntmp-mod-1090)))) syntmp-tmp-1092) ((lambda (syntmp-_-1115) (syntax-error (syntmp-source-wrap-146 syntmp-e-1086 syntmp-w-1088 syntmp-s-1089 syntmp-mod-1090))) syntmp-tmp-1091))) (syntax-dispatch syntmp-tmp-1091 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1086))) (syntmp-global-extend-115 (quote core) (quote quote) (lambda (syntmp-e-1116 syntmp-r-1117 syntmp-w-1118 syntmp-s-1119 syntmp-mod-1120) ((lambda (syntmp-tmp-1121) ((lambda (syntmp-tmp-1122) (if syntmp-tmp-1122 (apply (lambda (syntmp-_-1123 syntmp-e-1124) (syntmp-build-data-95 syntmp-s-1119 (syntmp-strip-164 syntmp-e-1124 syntmp-w-1118))) syntmp-tmp-1122) ((lambda (syntmp-_-1125) (syntax-error (syntmp-source-wrap-146 syntmp-e-1116 syntmp-w-1118 syntmp-s-1119 syntmp-mod-1120))) syntmp-tmp-1121))) (syntax-dispatch syntmp-tmp-1121 (quote (any any))))) syntmp-e-1116))) (syntmp-global-extend-115 (quote core) (quote syntax) (letrec ((syntmp-regen-1133 (lambda (syntmp-x-1134) (let ((syntmp-t-1135 (car syntmp-x-1134))) (if (memv syntmp-t-1135 (quote (ref))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (primitive))) (syntmp-build-annotated-94 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1134)) (if (memv syntmp-t-1135 (quote (lambda))) (syntmp-build-annotated-94 #f (list (quote lambda) (cadr syntmp-x-1134) (syntmp-regen-1133 (caddr syntmp-x-1134)))) (if (memv syntmp-t-1135 (quote (map))) (let ((syntmp-ls-1136 (map syntmp-regen-1133 (cdr syntmp-x-1134)))) (syntmp-build-annotated-94 #f (cons (if (syntmp-fx=-87 (length syntmp-ls-1136) 2) (syntmp-build-annotated-94 #f (quote map)) (syntmp-build-annotated-94 #f (quote map))) syntmp-ls-1136))) (syntmp-build-annotated-94 #f (cons (syntmp-build-annotated-94 #f (car syntmp-x-1134)) (map syntmp-regen-1133 (cdr syntmp-x-1134)))))))))))) (syntmp-gen-vector-1132 (lambda (syntmp-x-1137) (cond ((eq? (car syntmp-x-1137) (quote list)) (cons (quote vector) (cdr syntmp-x-1137))) ((eq? (car syntmp-x-1137) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1137)))) (else (list (quote list->vector) syntmp-x-1137))))) (syntmp-gen-append-1131 (lambda (syntmp-x-1138 syntmp-y-1139) (if (equal? syntmp-y-1139 (quote (quote ()))) syntmp-x-1138 (list (quote append) syntmp-x-1138 syntmp-y-1139)))) (syntmp-gen-cons-1130 (lambda (syntmp-x-1140 syntmp-y-1141) (let ((syntmp-t-1142 (car syntmp-y-1141))) (if (memv syntmp-t-1142 (quote (quote))) (if (eq? (car syntmp-x-1140) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1140) (cadr syntmp-y-1141))) (if (eq? (cadr syntmp-y-1141) (quote ())) (list (quote list) syntmp-x-1140) (list (quote cons) syntmp-x-1140 syntmp-y-1141))) (if (memv syntmp-t-1142 (quote (list))) (cons (quote list) (cons syntmp-x-1140 (cdr syntmp-y-1141))) (list (quote cons) syntmp-x-1140 syntmp-y-1141)))))) (syntmp-gen-map-1129 (lambda (syntmp-e-1143 syntmp-map-env-1144) (let ((syntmp-formals-1145 (map cdr syntmp-map-env-1144)) (syntmp-actuals-1146 (map (lambda (syntmp-x-1147) (list (quote ref) (car syntmp-x-1147))) syntmp-map-env-1144))) (cond ((eq? (car syntmp-e-1143) (quote ref)) (car syntmp-actuals-1146)) ((andmap (lambda (syntmp-x-1148) (and (eq? (car syntmp-x-1148) (quote ref)) (memq (cadr syntmp-x-1148) syntmp-formals-1145))) (cdr syntmp-e-1143)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1143)) (map (let ((syntmp-r-1149 (map cons syntmp-formals-1145 syntmp-actuals-1146))) (lambda (syntmp-x-1150) (cdr (assq (cadr syntmp-x-1150) syntmp-r-1149)))) (cdr syntmp-e-1143))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1145 syntmp-e-1143) syntmp-actuals-1146))))))) (syntmp-gen-mappend-1128 (lambda (syntmp-e-1151 syntmp-map-env-1152) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1129 syntmp-e-1151 syntmp-map-env-1152)))) (syntmp-gen-ref-1127 (lambda (syntmp-src-1153 syntmp-var-1154 syntmp-level-1155 syntmp-maps-1156) (if (syntmp-fx=-87 syntmp-level-1155 0) (values syntmp-var-1154 syntmp-maps-1156) (if (null? syntmp-maps-1156) (syntax-error syntmp-src-1153 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1127 syntmp-src-1153 syntmp-var-1154 (syntmp-fx--86 syntmp-level-1155 1) (cdr syntmp-maps-1156))) (lambda (syntmp-outer-var-1157 syntmp-outer-maps-1158) (let ((syntmp-b-1159 (assq syntmp-outer-var-1157 (car syntmp-maps-1156)))) (if syntmp-b-1159 (values (cdr syntmp-b-1159) syntmp-maps-1156) (let ((syntmp-inner-var-1160 (syntmp-gen-var-165 (quote tmp)))) (values syntmp-inner-var-1160 (cons (cons (cons syntmp-outer-var-1157 syntmp-inner-var-1160) (car syntmp-maps-1156)) syntmp-outer-maps-1158))))))))))) (syntmp-gen-syntax-1126 (lambda (syntmp-src-1161 syntmp-e-1162 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166) (if (syntmp-id?-117 syntmp-e-1162) (let ((syntmp-label-1167 (syntmp-id-var-name-139 syntmp-e-1162 (quote (()))))) (let ((syntmp-b-1168 (syntmp-lookup-114 syntmp-label-1167 syntmp-r-1163 syntmp-mod-1166))) (if (eq? (syntmp-binding-type-109 syntmp-b-1168) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1169 (syntmp-binding-value-110 syntmp-b-1168))) (syntmp-gen-ref-1127 syntmp-src-1161 (car syntmp-var.lev-1169) (cdr syntmp-var.lev-1169) syntmp-maps-1164))) (lambda (syntmp-var-1170 syntmp-maps-1171) (values (list (quote ref) syntmp-var-1170) syntmp-maps-1171))) (if (syntmp-ellipsis?-1165 syntmp-e-1162) (syntax-error syntmp-src-1161 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1162) syntmp-maps-1164))))) ((lambda (syntmp-tmp-1172) ((lambda (syntmp-tmp-1173) (if (if syntmp-tmp-1173 (apply (lambda (syntmp-dots-1174 syntmp-e-1175) (syntmp-ellipsis?-1165 syntmp-dots-1174)) syntmp-tmp-1173) #f) (apply (lambda (syntmp-dots-1176 syntmp-e-1177) (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-e-1177 syntmp-r-1163 syntmp-maps-1164 (lambda (syntmp-x-1178) #f) syntmp-mod-1166)) syntmp-tmp-1173) ((lambda (syntmp-tmp-1179) (if (if syntmp-tmp-1179 (apply (lambda (syntmp-x-1180 syntmp-dots-1181 syntmp-y-1182) (syntmp-ellipsis?-1165 syntmp-dots-1181)) syntmp-tmp-1179) #f) (apply (lambda (syntmp-x-1183 syntmp-dots-1184 syntmp-y-1185) (let syntmp-f-1186 ((syntmp-y-1187 syntmp-y-1185) (syntmp-k-1188 (lambda (syntmp-maps-1189) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-x-1183 syntmp-r-1163 (cons (quote ()) syntmp-maps-1189) syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-x-1190 syntmp-maps-1191) (if (null? (car syntmp-maps-1191)) (syntax-error syntmp-src-1161 "extra ellipsis in syntax form") (values (syntmp-gen-map-1129 syntmp-x-1190 (car syntmp-maps-1191)) (cdr syntmp-maps-1191)))))))) ((lambda (syntmp-tmp-1192) ((lambda (syntmp-tmp-1193) (if (if syntmp-tmp-1193 (apply (lambda (syntmp-dots-1194 syntmp-y-1195) (syntmp-ellipsis?-1165 syntmp-dots-1194)) syntmp-tmp-1193) #f) (apply (lambda (syntmp-dots-1196 syntmp-y-1197) (syntmp-f-1186 syntmp-y-1197 (lambda (syntmp-maps-1198) (call-with-values (lambda () (syntmp-k-1188 (cons (quote ()) syntmp-maps-1198))) (lambda (syntmp-x-1199 syntmp-maps-1200) (if (null? (car syntmp-maps-1200)) (syntax-error syntmp-src-1161 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1128 syntmp-x-1199 (car syntmp-maps-1200)) (cdr syntmp-maps-1200)))))))) syntmp-tmp-1193) ((lambda (syntmp-_-1201) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-y-1187 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-y-1202 syntmp-maps-1203) (call-with-values (lambda () (syntmp-k-1188 syntmp-maps-1203)) (lambda (syntmp-x-1204 syntmp-maps-1205) (values (syntmp-gen-append-1131 syntmp-x-1204 syntmp-y-1202) syntmp-maps-1205)))))) syntmp-tmp-1192))) (syntax-dispatch syntmp-tmp-1192 (quote (any . any))))) syntmp-y-1187))) syntmp-tmp-1179) ((lambda (syntmp-tmp-1206) (if syntmp-tmp-1206 (apply (lambda (syntmp-x-1207 syntmp-y-1208) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-x-1207 syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-x-1209 syntmp-maps-1210) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 syntmp-y-1208 syntmp-r-1163 syntmp-maps-1210 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-y-1211 syntmp-maps-1212) (values (syntmp-gen-cons-1130 syntmp-x-1209 syntmp-y-1211) syntmp-maps-1212)))))) syntmp-tmp-1206) ((lambda (syntmp-tmp-1213) (if syntmp-tmp-1213 (apply (lambda (syntmp-e1-1214 syntmp-e2-1215) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-src-1161 (cons syntmp-e1-1214 syntmp-e2-1215) syntmp-r-1163 syntmp-maps-1164 syntmp-ellipsis?-1165 syntmp-mod-1166)) (lambda (syntmp-e-1217 syntmp-maps-1218) (values (syntmp-gen-vector-1132 syntmp-e-1217) syntmp-maps-1218)))) syntmp-tmp-1213) ((lambda (syntmp-_-1219) (values (list (quote quote) syntmp-e-1162) syntmp-maps-1164)) syntmp-tmp-1172))) (syntax-dispatch syntmp-tmp-1172 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1172 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1172 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1172 (quote (any any))))) syntmp-e-1162))))) (lambda (syntmp-e-1220 syntmp-r-1221 syntmp-w-1222 syntmp-s-1223 syntmp-mod-1224) (let ((syntmp-e-1225 (syntmp-source-wrap-146 syntmp-e-1220 syntmp-w-1222 syntmp-s-1223 syntmp-mod-1224))) ((lambda (syntmp-tmp-1226) ((lambda (syntmp-tmp-1227) (if syntmp-tmp-1227 (apply (lambda (syntmp-_-1228 syntmp-x-1229) (call-with-values (lambda () (syntmp-gen-syntax-1126 syntmp-e-1225 syntmp-x-1229 syntmp-r-1221 (quote ()) syntmp-ellipsis?-162 syntmp-mod-1224)) (lambda (syntmp-e-1230 syntmp-maps-1231) (syntmp-regen-1133 syntmp-e-1230)))) syntmp-tmp-1227) ((lambda (syntmp-_-1232) (syntax-error syntmp-e-1225)) syntmp-tmp-1226))) (syntax-dispatch syntmp-tmp-1226 (quote (any any))))) syntmp-e-1225))))) (syntmp-global-extend-115 (quote core) (quote lambda) (lambda (syntmp-e-1233 syntmp-r-1234 syntmp-w-1235 syntmp-s-1236 syntmp-mod-1237) ((lambda (syntmp-tmp-1238) ((lambda (syntmp-tmp-1239) (if syntmp-tmp-1239 (apply (lambda (syntmp-_-1240 syntmp-c-1241) (syntmp-chi-lambda-clause-158 (syntmp-source-wrap-146 syntmp-e-1233 syntmp-w-1235 syntmp-s-1236 syntmp-mod-1237) syntmp-c-1241 syntmp-r-1234 syntmp-w-1235 syntmp-mod-1237 (lambda (syntmp-vars-1242 syntmp-body-1243) (syntmp-build-annotated-94 syntmp-s-1236 (list (quote lambda) syntmp-vars-1242 syntmp-body-1243))))) syntmp-tmp-1239) (syntax-error syntmp-tmp-1238))) (syntax-dispatch syntmp-tmp-1238 (quote (any . any))))) syntmp-e-1233))) (syntmp-global-extend-115 (quote core) (quote let) (letrec ((syntmp-chi-let-1244 (lambda (syntmp-e-1245 syntmp-r-1246 syntmp-w-1247 syntmp-s-1248 syntmp-mod-1249 syntmp-constructor-1250 syntmp-ids-1251 syntmp-vals-1252 syntmp-exps-1253) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1251)) (syntax-error syntmp-e-1245 "duplicate bound variable in") (let ((syntmp-labels-1254 (syntmp-gen-labels-123 syntmp-ids-1251)) (syntmp-new-vars-1255 (map syntmp-gen-var-165 syntmp-ids-1251))) (let ((syntmp-nw-1256 (syntmp-make-binding-wrap-134 syntmp-ids-1251 syntmp-labels-1254 syntmp-w-1247)) (syntmp-nr-1257 (syntmp-extend-var-env-112 syntmp-labels-1254 syntmp-new-vars-1255 syntmp-r-1246))) (syntmp-constructor-1250 syntmp-s-1248 syntmp-new-vars-1255 (map (lambda (syntmp-x-1258) (syntmp-chi-153 syntmp-x-1258 syntmp-r-1246 syntmp-w-1247 syntmp-mod-1249)) syntmp-vals-1252) (syntmp-chi-body-157 syntmp-exps-1253 (syntmp-source-wrap-146 syntmp-e-1245 syntmp-nw-1256 syntmp-s-1248 syntmp-mod-1249) syntmp-nr-1257 syntmp-nw-1256 syntmp-mod-1249)))))))) (lambda (syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263) ((lambda (syntmp-tmp-1264) ((lambda (syntmp-tmp-1265) (if syntmp-tmp-1265 (apply (lambda (syntmp-_-1266 syntmp-id-1267 syntmp-val-1268 syntmp-e1-1269 syntmp-e2-1270) (syntmp-chi-let-1244 syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263 syntmp-build-let-97 syntmp-id-1267 syntmp-val-1268 (cons syntmp-e1-1269 syntmp-e2-1270))) syntmp-tmp-1265) ((lambda (syntmp-tmp-1274) (if (if syntmp-tmp-1274 (apply (lambda (syntmp-_-1275 syntmp-f-1276 syntmp-id-1277 syntmp-val-1278 syntmp-e1-1279 syntmp-e2-1280) (syntmp-id?-117 syntmp-f-1276)) syntmp-tmp-1274) #f) (apply (lambda (syntmp-_-1281 syntmp-f-1282 syntmp-id-1283 syntmp-val-1284 syntmp-e1-1285 syntmp-e2-1286) (syntmp-chi-let-1244 syntmp-e-1259 syntmp-r-1260 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263 syntmp-build-named-let-98 (cons syntmp-f-1282 syntmp-id-1283) syntmp-val-1284 (cons syntmp-e1-1285 syntmp-e2-1286))) syntmp-tmp-1274) ((lambda (syntmp-_-1290) (syntax-error (syntmp-source-wrap-146 syntmp-e-1259 syntmp-w-1261 syntmp-s-1262 syntmp-mod-1263))) syntmp-tmp-1264))) (syntax-dispatch syntmp-tmp-1264 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1264 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1259)))) (syntmp-global-extend-115 (quote core) (quote letrec) (lambda (syntmp-e-1291 syntmp-r-1292 syntmp-w-1293 syntmp-s-1294 syntmp-mod-1295) ((lambda (syntmp-tmp-1296) ((lambda (syntmp-tmp-1297) (if syntmp-tmp-1297 (apply (lambda (syntmp-_-1298 syntmp-id-1299 syntmp-val-1300 syntmp-e1-1301 syntmp-e2-1302) (let ((syntmp-ids-1303 syntmp-id-1299)) (if (not (syntmp-valid-bound-ids?-142 syntmp-ids-1303)) (syntax-error syntmp-e-1291 "duplicate bound variable in") (let ((syntmp-labels-1305 (syntmp-gen-labels-123 syntmp-ids-1303)) (syntmp-new-vars-1306 (map syntmp-gen-var-165 syntmp-ids-1303))) (let ((syntmp-w-1307 (syntmp-make-binding-wrap-134 syntmp-ids-1303 syntmp-labels-1305 syntmp-w-1293)) (syntmp-r-1308 (syntmp-extend-var-env-112 syntmp-labels-1305 syntmp-new-vars-1306 syntmp-r-1292))) (syntmp-build-letrec-99 syntmp-s-1294 syntmp-new-vars-1306 (map (lambda (syntmp-x-1309) (syntmp-chi-153 syntmp-x-1309 syntmp-r-1308 syntmp-w-1307 syntmp-mod-1295)) syntmp-val-1300) (syntmp-chi-body-157 (cons syntmp-e1-1301 syntmp-e2-1302) (syntmp-source-wrap-146 syntmp-e-1291 syntmp-w-1307 syntmp-s-1294 syntmp-mod-1295) syntmp-r-1308 syntmp-w-1307 syntmp-mod-1295))))))) syntmp-tmp-1297) ((lambda (syntmp-_-1312) (syntax-error (syntmp-source-wrap-146 syntmp-e-1291 syntmp-w-1293 syntmp-s-1294 syntmp-mod-1295))) syntmp-tmp-1296))) (syntax-dispatch syntmp-tmp-1296 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1291))) (syntmp-global-extend-115 (quote core) (quote set!) (lambda (syntmp-e-1313 syntmp-r-1314 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317) ((lambda (syntmp-tmp-1318) ((lambda (syntmp-tmp-1319) (if (if syntmp-tmp-1319 (apply (lambda (syntmp-_-1320 syntmp-id-1321 syntmp-val-1322) (syntmp-id?-117 syntmp-id-1321)) syntmp-tmp-1319) #f) (apply (lambda (syntmp-_-1323 syntmp-id-1324 syntmp-val-1325) (let ((syntmp-val-1326 (syntmp-chi-153 syntmp-val-1325 syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317)) (syntmp-n-1327 (syntmp-id-var-name-139 syntmp-id-1324 syntmp-w-1315))) (let ((syntmp-b-1328 (syntmp-lookup-114 syntmp-n-1327 syntmp-r-1314 syntmp-mod-1317))) (let ((syntmp-t-1329 (syntmp-binding-type-109 syntmp-b-1328))) (if (memv syntmp-t-1329 (quote (lexical))) (syntmp-build-annotated-94 syntmp-s-1316 (list (quote set!) (syntmp-binding-value-110 syntmp-b-1328) syntmp-val-1326)) (if (memv syntmp-t-1329 (quote (global))) (syntmp-build-annotated-94 syntmp-s-1316 (list (quote set!) (make-module-ref syntmp-mod-1317 syntmp-n-1327 #f) syntmp-val-1326)) (if (memv syntmp-t-1329 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-145 syntmp-id-1324 syntmp-w-1315 syntmp-mod-1317) "identifier out of context") (syntax-error (syntmp-source-wrap-146 syntmp-e-1313 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317))))))))) syntmp-tmp-1319) ((lambda (syntmp-tmp-1330) (if syntmp-tmp-1330 (apply (lambda (syntmp-_-1331 syntmp-getter-1332 syntmp-arg-1333 syntmp-val-1334) (syntmp-build-annotated-94 syntmp-s-1316 (cons (syntmp-chi-153 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-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-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-getter-1332) syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317) (map (lambda (syntmp-e-1335) (syntmp-chi-153 syntmp-e-1335 syntmp-r-1314 syntmp-w-1315 syntmp-mod-1317)) (append syntmp-arg-1333 (list syntmp-val-1334)))))) syntmp-tmp-1330) ((lambda (syntmp-_-1337) (syntax-error (syntmp-source-wrap-146 syntmp-e-1313 syntmp-w-1315 syntmp-s-1316 syntmp-mod-1317))) syntmp-tmp-1318))) (syntax-dispatch syntmp-tmp-1318 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1318 (quote (any any any))))) syntmp-e-1313))) (syntmp-global-extend-115 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-115 (quote define) (quote define) (quote ())) (syntmp-global-extend-115 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-115 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-115 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1341 (lambda (syntmp-x-1342 syntmp-keys-1343 syntmp-clauses-1344 syntmp-r-1345 syntmp-mod-1346) (if (null? syntmp-clauses-1344) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-error)) syntmp-x-1342)) ((lambda (syntmp-tmp-1347) ((lambda (syntmp-tmp-1348) (if syntmp-tmp-1348 (apply (lambda (syntmp-pat-1349 syntmp-exp-1350) (if (and (syntmp-id?-117 syntmp-pat-1349) (andmap (lambda (syntmp-x-1351) (not (syntmp-free-id=?-140 syntmp-pat-1349 syntmp-x-1351))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-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-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1343))) (let ((syntmp-labels-1352 (list (syntmp-gen-label-122))) (syntmp-var-1353 (syntmp-gen-var-165 syntmp-pat-1349))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-var-1353) (syntmp-chi-153 syntmp-exp-1350 (syntmp-extend-env-111 syntmp-labels-1352 (list (cons (quote syntax) (cons syntmp-var-1353 0))) syntmp-r-1345) (syntmp-make-binding-wrap-134 (list syntmp-pat-1349) syntmp-labels-1352 (quote (()))) syntmp-mod-1346))) syntmp-x-1342))) (syntmp-gen-clause-1340 syntmp-x-1342 syntmp-keys-1343 (cdr syntmp-clauses-1344) syntmp-r-1345 syntmp-pat-1349 #t syntmp-exp-1350 syntmp-mod-1346))) syntmp-tmp-1348) ((lambda (syntmp-tmp-1354) (if syntmp-tmp-1354 (apply (lambda (syntmp-pat-1355 syntmp-fender-1356 syntmp-exp-1357) (syntmp-gen-clause-1340 syntmp-x-1342 syntmp-keys-1343 (cdr syntmp-clauses-1344) syntmp-r-1345 syntmp-pat-1355 syntmp-fender-1356 syntmp-exp-1357 syntmp-mod-1346)) syntmp-tmp-1354) ((lambda (syntmp-_-1358) (syntax-error (car syntmp-clauses-1344) "invalid syntax-case clause")) syntmp-tmp-1347))) (syntax-dispatch syntmp-tmp-1347 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1347 (quote (any any))))) (car syntmp-clauses-1344))))) (syntmp-gen-clause-1340 (lambda (syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-pat-1363 syntmp-fender-1364 syntmp-exp-1365 syntmp-mod-1366) (call-with-values (lambda () (syntmp-convert-pattern-1338 syntmp-pat-1363 syntmp-keys-1360)) (lambda (syntmp-p-1367 syntmp-pvars-1368) (cond ((not (syntmp-distinct-bound-ids?-143 (map car syntmp-pvars-1368))) (syntax-error syntmp-pat-1363 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1369) (not (syntmp-ellipsis?-162 (car syntmp-x-1369)))) syntmp-pvars-1368)) (syntax-error syntmp-pat-1363 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1370 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-y-1370) (let ((syntmp-y-1371 (syntmp-build-annotated-94 #f syntmp-y-1370))) (syntmp-build-annotated-94 #f (list (quote if) ((lambda (syntmp-tmp-1372) ((lambda (syntmp-tmp-1373) (if syntmp-tmp-1373 (apply (lambda () syntmp-y-1371) syntmp-tmp-1373) ((lambda (syntmp-_-1374) (syntmp-build-annotated-94 #f (list (quote if) syntmp-y-1371 (syntmp-build-dispatch-call-1339 syntmp-pvars-1368 syntmp-fender-1364 syntmp-y-1371 syntmp-r-1362 syntmp-mod-1366) (syntmp-build-data-95 #f #f)))) syntmp-tmp-1372))) (syntax-dispatch syntmp-tmp-1372 (quote #(atom #t))))) syntmp-fender-1364) (syntmp-build-dispatch-call-1339 syntmp-pvars-1368 syntmp-exp-1365 syntmp-y-1371 syntmp-r-1362 syntmp-mod-1366) (syntmp-gen-syntax-case-1341 syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-mod-1366)))))) (if (eq? syntmp-p-1367 (quote any)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote list)) syntmp-x-1359)) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote syntax-dispatch)) syntmp-x-1359 (syntmp-build-data-95 #f syntmp-p-1367))))))))))))) (syntmp-build-dispatch-call-1339 (lambda (syntmp-pvars-1375 syntmp-exp-1376 syntmp-y-1377 syntmp-r-1378 syntmp-mod-1379) (let ((syntmp-ids-1380 (map car syntmp-pvars-1375)) (syntmp-levels-1381 (map cdr syntmp-pvars-1375))) (let ((syntmp-labels-1382 (syntmp-gen-labels-123 syntmp-ids-1380)) (syntmp-new-vars-1383 (map syntmp-gen-var-165 syntmp-ids-1380))) (syntmp-build-annotated-94 #f (list (syntmp-build-annotated-94 #f (quote apply)) (syntmp-build-annotated-94 #f (list (quote lambda) syntmp-new-vars-1383 (syntmp-chi-153 syntmp-exp-1376 (syntmp-extend-env-111 syntmp-labels-1382 (map (lambda (syntmp-var-1384 syntmp-level-1385) (cons (quote syntax) (cons syntmp-var-1384 syntmp-level-1385))) syntmp-new-vars-1383 (map cdr syntmp-pvars-1375)) syntmp-r-1378) (syntmp-make-binding-wrap-134 syntmp-ids-1380 syntmp-labels-1382 (quote (()))) syntmp-mod-1379))) syntmp-y-1377)))))) (syntmp-convert-pattern-1338 (lambda (syntmp-pattern-1386 syntmp-keys-1387) (let syntmp-cvt-1388 ((syntmp-p-1389 syntmp-pattern-1386) (syntmp-n-1390 0) (syntmp-ids-1391 (quote ()))) (if (syntmp-id?-117 syntmp-p-1389) (if (syntmp-bound-id-member?-144 syntmp-p-1389 syntmp-keys-1387) (values (vector (quote free-id) syntmp-p-1389) syntmp-ids-1391) (values (quote any) (cons (cons syntmp-p-1389 syntmp-n-1390) syntmp-ids-1391))) ((lambda (syntmp-tmp-1392) ((lambda (syntmp-tmp-1393) (if (if syntmp-tmp-1393 (apply (lambda (syntmp-x-1394 syntmp-dots-1395) (syntmp-ellipsis?-162 syntmp-dots-1395)) syntmp-tmp-1393) #f) (apply (lambda (syntmp-x-1396 syntmp-dots-1397) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1396 (syntmp-fx+-85 syntmp-n-1390 1) syntmp-ids-1391)) (lambda (syntmp-p-1398 syntmp-ids-1399) (values (if (eq? syntmp-p-1398 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1398)) syntmp-ids-1399)))) syntmp-tmp-1393) ((lambda (syntmp-tmp-1400) (if syntmp-tmp-1400 (apply (lambda (syntmp-x-1401 syntmp-y-1402) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-y-1402 syntmp-n-1390 syntmp-ids-1391)) (lambda (syntmp-y-1403 syntmp-ids-1404) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1401 syntmp-n-1390 syntmp-ids-1404)) (lambda (syntmp-x-1405 syntmp-ids-1406) (values (cons syntmp-x-1405 syntmp-y-1403) syntmp-ids-1406)))))) syntmp-tmp-1400) ((lambda (syntmp-tmp-1407) (if syntmp-tmp-1407 (apply (lambda () (values (quote ()) syntmp-ids-1391)) syntmp-tmp-1407) ((lambda (syntmp-tmp-1408) (if syntmp-tmp-1408 (apply (lambda (syntmp-x-1409) (call-with-values (lambda () (syntmp-cvt-1388 syntmp-x-1409 syntmp-n-1390 syntmp-ids-1391)) (lambda (syntmp-p-1411 syntmp-ids-1412) (values (vector (quote vector) syntmp-p-1411) syntmp-ids-1412)))) syntmp-tmp-1408) ((lambda (syntmp-x-1413) (values (vector (quote atom) (syntmp-strip-164 syntmp-p-1389 (quote (())))) syntmp-ids-1391)) syntmp-tmp-1392))) (syntax-dispatch syntmp-tmp-1392 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1392 (quote ()))))) (syntax-dispatch syntmp-tmp-1392 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1392 (quote (any any))))) syntmp-p-1389)))))) (lambda (syntmp-e-1414 syntmp-r-1415 syntmp-w-1416 syntmp-s-1417 syntmp-mod-1418) (let ((syntmp-e-1419 (syntmp-source-wrap-146 syntmp-e-1414 syntmp-w-1416 syntmp-s-1417 syntmp-mod-1418))) ((lambda (syntmp-tmp-1420) ((lambda (syntmp-tmp-1421) (if syntmp-tmp-1421 (apply (lambda (syntmp-_-1422 syntmp-val-1423 syntmp-key-1424 syntmp-m-1425) (if (andmap (lambda (syntmp-x-1426) (and (syntmp-id?-117 syntmp-x-1426) (not (syntmp-ellipsis?-162 syntmp-x-1426)))) syntmp-key-1424) (let ((syntmp-x-1428 (syntmp-gen-var-165 (quote tmp)))) (syntmp-build-annotated-94 syntmp-s-1417 (list (syntmp-build-annotated-94 #f (list (quote lambda) (list syntmp-x-1428) (syntmp-gen-syntax-case-1341 (syntmp-build-annotated-94 #f syntmp-x-1428) syntmp-key-1424 syntmp-m-1425 syntmp-r-1415 syntmp-mod-1418))) (syntmp-chi-153 syntmp-val-1423 syntmp-r-1415 (quote (())) syntmp-mod-1418)))) (syntax-error syntmp-e-1419 "invalid literals list in"))) syntmp-tmp-1421) (syntax-error syntmp-tmp-1420))) (syntax-dispatch syntmp-tmp-1420 (quote (any any each-any . each-any))))) syntmp-e-1419))))) (set! sc-expand (let ((syntmp-m-1431 (quote e)) (syntmp-esew-1432 (quote (eval)))) (lambda (syntmp-x-1433) (if (and (pair? syntmp-x-1433) (equal? (car syntmp-x-1433) syntmp-noexpand-84)) (cadr syntmp-x-1433) (syntmp-chi-top-152 syntmp-x-1433 (quote ()) (quote ((top))) syntmp-m-1431 syntmp-esew-1432 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1434 (quote e)) (syntmp-esew-1435 (quote (eval)))) (lambda (syntmp-x-1437 . syntmp-rest-1436) (if (and (pair? syntmp-x-1437) (equal? (car syntmp-x-1437) syntmp-noexpand-84)) (cadr syntmp-x-1437) (syntmp-chi-top-152 syntmp-x-1437 (quote ()) (quote ((top))) (if (null? syntmp-rest-1436) syntmp-m-1434 (car syntmp-rest-1436)) (if (or (null? syntmp-rest-1436) (null? (cdr syntmp-rest-1436))) syntmp-esew-1435 (cadr syntmp-rest-1436)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1438) (syntmp-nonsymbol-id?-116 syntmp-x-1438))) (set! datum->syntax-object (lambda (syntmp-id-1439 syntmp-datum-1440) (syntmp-make-syntax-object-100 syntmp-datum-1440 (syntmp-syntax-object-wrap-103 syntmp-id-1439) #f))) (set! syntax-object->datum (lambda (syntmp-x-1441) (syntmp-strip-164 syntmp-x-1441 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1442) (begin (let ((syntmp-x-1443 syntmp-ls-1442)) (if (not (list? syntmp-x-1443)) (syntmp-error-hook-91 (quote generate-temporaries) "invalid argument" syntmp-x-1443))) (map (lambda (syntmp-x-1444) (syntmp-wrap-145 (gensym) (quote ((top))) #f)) syntmp-ls-1442)))) (set! free-identifier=? (lambda (syntmp-x-1445 syntmp-y-1446) (begin (let ((syntmp-x-1447 syntmp-x-1445)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1447)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1447))) (let ((syntmp-x-1448 syntmp-y-1446)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1448)) (syntmp-error-hook-91 (quote free-identifier=?) "invalid argument" syntmp-x-1448))) (syntmp-free-id=?-140 syntmp-x-1445 syntmp-y-1446)))) (set! bound-identifier=? (lambda (syntmp-x-1449 syntmp-y-1450) (begin (let ((syntmp-x-1451 syntmp-x-1449)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1451)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1451))) (let ((syntmp-x-1452 syntmp-y-1450)) (if (not (syntmp-nonsymbol-id?-116 syntmp-x-1452)) (syntmp-error-hook-91 (quote bound-identifier=?) "invalid argument" syntmp-x-1452))) (syntmp-bound-id=?-141 syntmp-x-1449 syntmp-y-1450)))) (set! syntax-error (lambda (syntmp-object-1454 . syntmp-messages-1453) (begin (for-each (lambda (syntmp-x-1455) (let ((syntmp-x-1456 syntmp-x-1455)) (if (not (string? syntmp-x-1456)) (syntmp-error-hook-91 (quote syntax-error) "invalid argument" syntmp-x-1456)))) syntmp-messages-1453) (let ((syntmp-message-1457 (if (null? syntmp-messages-1453) "invalid syntax" (apply string-append syntmp-messages-1453)))) (syntmp-error-hook-91 #f syntmp-message-1457 (syntmp-strip-164 syntmp-object-1454 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1458 syntmp-v-1459) (begin (let ((syntmp-x-1460 syntmp-sym-1458)) (if (not (symbol? syntmp-x-1460)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1460))) (let ((syntmp-x-1461 syntmp-v-1459)) (if (not (procedure? syntmp-x-1461)) (syntmp-error-hook-91 (quote define-syntax) "invalid argument" syntmp-x-1461))) (syntmp-global-extend-115 (quote macro) syntmp-sym-1458 syntmp-v-1459)))) (letrec ((syntmp-match-1466 (lambda (syntmp-e-1467 syntmp-p-1468 syntmp-w-1469 syntmp-r-1470 syntmp-mod-1471) (cond ((not syntmp-r-1470) #f) ((eq? syntmp-p-1468 (quote any)) (cons (syntmp-wrap-145 syntmp-e-1467 syntmp-w-1469 syntmp-mod-1471) syntmp-r-1470)) ((syntmp-syntax-object?-101 syntmp-e-1467) (syntmp-match*-1465 (let ((syntmp-e-1472 (syntmp-syntax-object-expression-102 syntmp-e-1467))) (if (annotation? syntmp-e-1472) (annotation-expression syntmp-e-1472) syntmp-e-1472)) syntmp-p-1468 (syntmp-join-wraps-136 syntmp-w-1469 (syntmp-syntax-object-wrap-103 syntmp-e-1467)) syntmp-r-1470 (syntmp-syntax-object-module-104 syntmp-e-1467))) (else (syntmp-match*-1465 (let ((syntmp-e-1473 syntmp-e-1467)) (if (annotation? syntmp-e-1473) (annotation-expression syntmp-e-1473) syntmp-e-1473)) syntmp-p-1468 syntmp-w-1469 syntmp-r-1470 syntmp-mod-1471))))) (syntmp-match*-1465 (lambda (syntmp-e-1474 syntmp-p-1475 syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478) (cond ((null? syntmp-p-1475) (and (null? syntmp-e-1474) syntmp-r-1477)) ((pair? syntmp-p-1475) (and (pair? syntmp-e-1474) (syntmp-match-1466 (car syntmp-e-1474) (car syntmp-p-1475) syntmp-w-1476 (syntmp-match-1466 (cdr syntmp-e-1474) (cdr syntmp-p-1475) syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478) syntmp-mod-1478))) ((eq? syntmp-p-1475 (quote each-any)) (let ((syntmp-l-1479 (syntmp-match-each-any-1463 syntmp-e-1474 syntmp-w-1476 syntmp-mod-1478))) (and syntmp-l-1479 (cons syntmp-l-1479 syntmp-r-1477)))) (else (let ((syntmp-t-1480 (vector-ref syntmp-p-1475 0))) (if (memv syntmp-t-1480 (quote (each))) (if (null? syntmp-e-1474) (syntmp-match-empty-1464 (vector-ref syntmp-p-1475 1) syntmp-r-1477) (let ((syntmp-l-1481 (syntmp-match-each-1462 syntmp-e-1474 (vector-ref syntmp-p-1475 1) syntmp-w-1476 syntmp-mod-1478))) (and syntmp-l-1481 (let syntmp-collect-1482 ((syntmp-l-1483 syntmp-l-1481)) (if (null? (car syntmp-l-1483)) syntmp-r-1477 (cons (map car syntmp-l-1483) (syntmp-collect-1482 (map cdr syntmp-l-1483)))))))) (if (memv syntmp-t-1480 (quote (free-id))) (and (syntmp-id?-117 syntmp-e-1474) (syntmp-free-id=?-140 (syntmp-wrap-145 syntmp-e-1474 syntmp-w-1476 syntmp-mod-1478) (vector-ref syntmp-p-1475 1)) syntmp-r-1477) (if (memv syntmp-t-1480 (quote (atom))) (and (equal? (vector-ref syntmp-p-1475 1) (syntmp-strip-164 syntmp-e-1474 syntmp-w-1476)) syntmp-r-1477) (if (memv syntmp-t-1480 (quote (vector))) (and (vector? syntmp-e-1474) (syntmp-match-1466 (vector->list syntmp-e-1474) (vector-ref syntmp-p-1475 1) syntmp-w-1476 syntmp-r-1477 syntmp-mod-1478))))))))))) (syntmp-match-empty-1464 (lambda (syntmp-p-1484 syntmp-r-1485) (cond ((null? syntmp-p-1484) syntmp-r-1485) ((eq? syntmp-p-1484 (quote any)) (cons (quote ()) syntmp-r-1485)) ((pair? syntmp-p-1484) (syntmp-match-empty-1464 (car syntmp-p-1484) (syntmp-match-empty-1464 (cdr syntmp-p-1484) syntmp-r-1485))) ((eq? syntmp-p-1484 (quote each-any)) (cons (quote ()) syntmp-r-1485)) (else (let ((syntmp-t-1486 (vector-ref syntmp-p-1484 0))) (if (memv syntmp-t-1486 (quote (each))) (syntmp-match-empty-1464 (vector-ref syntmp-p-1484 1) syntmp-r-1485) (if (memv syntmp-t-1486 (quote (free-id atom))) syntmp-r-1485 (if (memv syntmp-t-1486 (quote (vector))) (syntmp-match-empty-1464 (vector-ref syntmp-p-1484 1) syntmp-r-1485))))))))) (syntmp-match-each-any-1463 (lambda (syntmp-e-1487 syntmp-w-1488 syntmp-mod-1489) (cond ((annotation? syntmp-e-1487) (syntmp-match-each-any-1463 (annotation-expression syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489)) ((pair? syntmp-e-1487) (let ((syntmp-l-1490 (syntmp-match-each-any-1463 (cdr syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489))) (and syntmp-l-1490 (cons (syntmp-wrap-145 (car syntmp-e-1487) syntmp-w-1488 syntmp-mod-1489) syntmp-l-1490)))) ((null? syntmp-e-1487) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1487) (syntmp-match-each-any-1463 (syntmp-syntax-object-expression-102 syntmp-e-1487) (syntmp-join-wraps-136 syntmp-w-1488 (syntmp-syntax-object-wrap-103 syntmp-e-1487)) syntmp-mod-1489)) (else #f)))) (syntmp-match-each-1462 (lambda (syntmp-e-1491 syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494) (cond ((annotation? syntmp-e-1491) (syntmp-match-each-1462 (annotation-expression syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494)) ((pair? syntmp-e-1491) (let ((syntmp-first-1495 (syntmp-match-1466 (car syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 (quote ()) syntmp-mod-1494))) (and syntmp-first-1495 (let ((syntmp-rest-1496 (syntmp-match-each-1462 (cdr syntmp-e-1491) syntmp-p-1492 syntmp-w-1493 syntmp-mod-1494))) (and syntmp-rest-1496 (cons syntmp-first-1495 syntmp-rest-1496)))))) ((null? syntmp-e-1491) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1491) (syntmp-match-each-1462 (syntmp-syntax-object-expression-102 syntmp-e-1491) syntmp-p-1492 (syntmp-join-wraps-136 syntmp-w-1493 (syntmp-syntax-object-wrap-103 syntmp-e-1491)) (syntmp-syntax-object-module-104 syntmp-e-1491))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1497 syntmp-p-1498) (cond ((eq? syntmp-p-1498 (quote any)) (list syntmp-e-1497)) ((syntmp-syntax-object?-101 syntmp-e-1497) (syntmp-match*-1465 (let ((syntmp-e-1499 (syntmp-syntax-object-expression-102 syntmp-e-1497))) (if (annotation? syntmp-e-1499) (annotation-expression syntmp-e-1499) syntmp-e-1499)) syntmp-p-1498 (syntmp-syntax-object-wrap-103 syntmp-e-1497) (quote ()) (syntmp-syntax-object-module-104 syntmp-e-1497))) (else (syntmp-match*-1465 (let ((syntmp-e-1500 syntmp-e-1497)) (if (annotation? syntmp-e-1500) (annotation-expression syntmp-e-1500) syntmp-e-1500)) syntmp-p-1498 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-153))))) +(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1501) ((lambda (syntmp-tmp-1502) ((lambda (syntmp-tmp-1503) (if syntmp-tmp-1503 (apply (lambda (syntmp-_-1504 syntmp-e1-1505 syntmp-e2-1506) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1505 syntmp-e2-1506))) syntmp-tmp-1503) ((lambda (syntmp-tmp-1508) (if syntmp-tmp-1508 (apply (lambda (syntmp-_-1509 syntmp-out-1510 syntmp-in-1511 syntmp-e1-1512 syntmp-e2-1513) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1511 (quote ()) (list syntmp-out-1510 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1512 syntmp-e2-1513))))) syntmp-tmp-1508) ((lambda (syntmp-tmp-1515) (if syntmp-tmp-1515 (apply (lambda (syntmp-_-1516 syntmp-out-1517 syntmp-in-1518 syntmp-e1-1519 syntmp-e2-1520) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1518) (quote ()) (list syntmp-out-1517 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1519 syntmp-e2-1520))))) syntmp-tmp-1515) (syntax-error syntmp-tmp-1502))) (syntax-dispatch syntmp-tmp-1502 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1502 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1502 (quote (any () any . each-any))))) syntmp-x-1501))) +(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1542) ((lambda (syntmp-tmp-1543) ((lambda (syntmp-tmp-1544) (if syntmp-tmp-1544 (apply (lambda (syntmp-_-1545 syntmp-k-1546 syntmp-keyword-1547 syntmp-pattern-1548 syntmp-template-1549) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1546 (map (lambda (syntmp-tmp-1552 syntmp-tmp-1551) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1551) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1552))) syntmp-template-1549 syntmp-pattern-1548)))))) syntmp-tmp-1544) (syntax-error syntmp-tmp-1543))) (syntax-dispatch syntmp-tmp-1543 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1542))) +(install-global-transformer (quote let*) (lambda (syntmp-x-1563) ((lambda (syntmp-tmp-1564) ((lambda (syntmp-tmp-1565) (if (if syntmp-tmp-1565 (apply (lambda (syntmp-let*-1566 syntmp-x-1567 syntmp-v-1568 syntmp-e1-1569 syntmp-e2-1570) (andmap identifier? syntmp-x-1567)) syntmp-tmp-1565) #f) (apply (lambda (syntmp-let*-1572 syntmp-x-1573 syntmp-v-1574 syntmp-e1-1575 syntmp-e2-1576) (let syntmp-f-1577 ((syntmp-bindings-1578 (map list syntmp-x-1573 syntmp-v-1574))) (if (null? syntmp-bindings-1578) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1575 syntmp-e2-1576))) ((lambda (syntmp-tmp-1582) ((lambda (syntmp-tmp-1583) (if syntmp-tmp-1583 (apply (lambda (syntmp-body-1584 syntmp-binding-1585) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1585) syntmp-body-1584)) syntmp-tmp-1583) (syntax-error syntmp-tmp-1582))) (syntax-dispatch syntmp-tmp-1582 (quote (any any))))) (list (syntmp-f-1577 (cdr syntmp-bindings-1578)) (car syntmp-bindings-1578)))))) syntmp-tmp-1565) (syntax-error syntmp-tmp-1564))) (syntax-dispatch syntmp-tmp-1564 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1563))) +(install-global-transformer (quote do) (lambda (syntmp-orig-x-1605) ((lambda (syntmp-tmp-1606) ((lambda (syntmp-tmp-1607) (if syntmp-tmp-1607 (apply (lambda (syntmp-_-1608 syntmp-var-1609 syntmp-init-1610 syntmp-step-1611 syntmp-e0-1612 syntmp-e1-1613 syntmp-c-1614) ((lambda (syntmp-tmp-1615) ((lambda (syntmp-tmp-1616) (if syntmp-tmp-1616 (apply (lambda (syntmp-step-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-tmp-1619) (if syntmp-tmp-1619 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1609 syntmp-init-1610) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1612) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1614 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1617))))))) syntmp-tmp-1619) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-e1-1625 syntmp-e2-1626) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1609 syntmp-init-1610) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1612 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1625 syntmp-e2-1626)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1614 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1617))))))) syntmp-tmp-1624) (syntax-error syntmp-tmp-1618))) (syntax-dispatch syntmp-tmp-1618 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1618 (quote ())))) syntmp-e1-1613)) syntmp-tmp-1616) (syntax-error syntmp-tmp-1615))) (syntax-dispatch syntmp-tmp-1615 (quote each-any)))) (map (lambda (syntmp-v-1633 syntmp-s-1634) ((lambda (syntmp-tmp-1635) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda () syntmp-v-1633) syntmp-tmp-1636) ((lambda (syntmp-tmp-1637) (if syntmp-tmp-1637 (apply (lambda (syntmp-e-1638) syntmp-e-1638) syntmp-tmp-1637) ((lambda (syntmp-_-1639) (syntax-error syntmp-orig-x-1605)) syntmp-tmp-1635))) (syntax-dispatch syntmp-tmp-1635 (quote (any)))))) (syntax-dispatch syntmp-tmp-1635 (quote ())))) syntmp-s-1634)) syntmp-var-1609 syntmp-step-1611))) syntmp-tmp-1607) (syntax-error syntmp-tmp-1606))) (syntax-dispatch syntmp-tmp-1606 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1605))) +(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1667 (lambda (syntmp-x-1671 syntmp-y-1672) ((lambda (syntmp-tmp-1673) ((lambda (syntmp-tmp-1674) (if syntmp-tmp-1674 (apply (lambda (syntmp-x-1675 syntmp-y-1676) ((lambda (syntmp-tmp-1677) ((lambda (syntmp-tmp-1678) (if syntmp-tmp-1678 (apply (lambda (syntmp-dy-1679) ((lambda (syntmp-tmp-1680) ((lambda (syntmp-tmp-1681) (if syntmp-tmp-1681 (apply (lambda (syntmp-dx-1682) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1682 syntmp-dy-1679))) syntmp-tmp-1681) ((lambda (syntmp-_-1683) (if (null? syntmp-dy-1679) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675 syntmp-y-1676))) syntmp-tmp-1680))) (syntax-dispatch syntmp-tmp-1680 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1675)) syntmp-tmp-1678) ((lambda (syntmp-tmp-1684) (if syntmp-tmp-1684 (apply (lambda (syntmp-stuff-1685) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1675 syntmp-stuff-1685))) syntmp-tmp-1684) ((lambda (syntmp-else-1686) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1675 syntmp-y-1676)) syntmp-tmp-1677))) (syntax-dispatch syntmp-tmp-1677 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1677 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1676)) syntmp-tmp-1674) (syntax-error syntmp-tmp-1673))) (syntax-dispatch syntmp-tmp-1673 (quote (any any))))) (list syntmp-x-1671 syntmp-y-1672)))) (syntmp-quasiappend-1668 (lambda (syntmp-x-1687 syntmp-y-1688) ((lambda (syntmp-tmp-1689) ((lambda (syntmp-tmp-1690) (if syntmp-tmp-1690 (apply (lambda (syntmp-x-1691 syntmp-y-1692) ((lambda (syntmp-tmp-1693) ((lambda (syntmp-tmp-1694) (if syntmp-tmp-1694 (apply (lambda () syntmp-x-1691) syntmp-tmp-1694) ((lambda (syntmp-_-1695) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1691 syntmp-y-1692)) syntmp-tmp-1693))) (syntax-dispatch syntmp-tmp-1693 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1692)) syntmp-tmp-1690) (syntax-error syntmp-tmp-1689))) (syntax-dispatch syntmp-tmp-1689 (quote (any any))))) (list syntmp-x-1687 syntmp-y-1688)))) (syntmp-quasivector-1669 (lambda (syntmp-x-1696) ((lambda (syntmp-tmp-1697) ((lambda (syntmp-x-1698) ((lambda (syntmp-tmp-1699) ((lambda (syntmp-tmp-1700) (if syntmp-tmp-1700 (apply (lambda (syntmp-x-1701) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1701))) syntmp-tmp-1700) ((lambda (syntmp-tmp-1703) (if syntmp-tmp-1703 (apply (lambda (syntmp-x-1704) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1704)) syntmp-tmp-1703) ((lambda (syntmp-_-1706) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1698)) syntmp-tmp-1699))) (syntax-dispatch syntmp-tmp-1699 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1699 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1698)) syntmp-tmp-1697)) syntmp-x-1696))) (syntmp-quasi-1670 (lambda (syntmp-p-1707 syntmp-lev-1708) ((lambda (syntmp-tmp-1709) ((lambda (syntmp-tmp-1710) (if syntmp-tmp-1710 (apply (lambda (syntmp-p-1711) (if (= syntmp-lev-1708 0) syntmp-p-1711 (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1711) (- syntmp-lev-1708 1))))) syntmp-tmp-1710) ((lambda (syntmp-tmp-1712) (if syntmp-tmp-1712 (apply (lambda (syntmp-p-1713 syntmp-q-1714) (if (= syntmp-lev-1708 0) (syntmp-quasiappend-1668 syntmp-p-1713 (syntmp-quasi-1670 syntmp-q-1714 syntmp-lev-1708)) (syntmp-quasicons-1667 (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1713) (- syntmp-lev-1708 1))) (syntmp-quasi-1670 syntmp-q-1714 syntmp-lev-1708)))) syntmp-tmp-1712) ((lambda (syntmp-tmp-1715) (if syntmp-tmp-1715 (apply (lambda (syntmp-p-1716) (syntmp-quasicons-1667 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1670 (list syntmp-p-1716) (+ syntmp-lev-1708 1)))) syntmp-tmp-1715) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-p-1718 syntmp-q-1719) (syntmp-quasicons-1667 (syntmp-quasi-1670 syntmp-p-1718 syntmp-lev-1708) (syntmp-quasi-1670 syntmp-q-1719 syntmp-lev-1708))) syntmp-tmp-1717) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-x-1721) (syntmp-quasivector-1669 (syntmp-quasi-1670 syntmp-x-1721 syntmp-lev-1708))) syntmp-tmp-1720) ((lambda (syntmp-p-1723) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1723)) syntmp-tmp-1709))) (syntax-dispatch syntmp-tmp-1709 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1709 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1709 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1707)))) (lambda (syntmp-x-1724) ((lambda (syntmp-tmp-1725) ((lambda (syntmp-tmp-1726) (if syntmp-tmp-1726 (apply (lambda (syntmp-_-1727 syntmp-e-1728) (syntmp-quasi-1670 syntmp-e-1728 0)) syntmp-tmp-1726) (syntax-error syntmp-tmp-1725))) (syntax-dispatch syntmp-tmp-1725 (quote (any any))))) syntmp-x-1724)))) +(install-global-transformer (quote include) (lambda (syntmp-x-1788) (letrec ((syntmp-read-file-1789 (lambda (syntmp-fn-1790 syntmp-k-1791) (let ((syntmp-p-1792 (open-input-file syntmp-fn-1790))) (let syntmp-f-1793 ((syntmp-x-1794 (read syntmp-p-1792))) (if (eof-object? syntmp-x-1794) (begin (close-input-port syntmp-p-1792) (quote ())) (cons (datum->syntax-object syntmp-k-1791 syntmp-x-1794) (syntmp-f-1793 (read syntmp-p-1792))))))))) ((lambda (syntmp-tmp-1795) ((lambda (syntmp-tmp-1796) (if syntmp-tmp-1796 (apply (lambda (syntmp-k-1797 syntmp-filename-1798) (let ((syntmp-fn-1799 (syntax-object->datum syntmp-filename-1798))) ((lambda (syntmp-tmp-1800) ((lambda (syntmp-tmp-1801) (if syntmp-tmp-1801 (apply (lambda (syntmp-exp-1802) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1802)) syntmp-tmp-1801) (syntax-error syntmp-tmp-1800))) (syntax-dispatch syntmp-tmp-1800 (quote each-any)))) (syntmp-read-file-1789 syntmp-fn-1799 syntmp-k-1797)))) syntmp-tmp-1796) (syntax-error syntmp-tmp-1795))) (syntax-dispatch syntmp-tmp-1795 (quote (any any))))) syntmp-x-1788)))) +(install-global-transformer (quote unquote) (lambda (syntmp-x-1819) ((lambda (syntmp-tmp-1820) ((lambda (syntmp-tmp-1821) (if syntmp-tmp-1821 (apply (lambda (syntmp-_-1822 syntmp-e-1823) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1823))) syntmp-tmp-1821) (syntax-error syntmp-tmp-1820))) (syntax-dispatch syntmp-tmp-1820 (quote (any any))))) syntmp-x-1819))) +(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1829) ((lambda (syntmp-tmp-1830) ((lambda (syntmp-tmp-1831) (if syntmp-tmp-1831 (apply (lambda (syntmp-_-1832 syntmp-e-1833) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1833))) syntmp-tmp-1831) (syntax-error syntmp-tmp-1830))) (syntax-dispatch syntmp-tmp-1830 (quote (any any))))) syntmp-x-1829))) +(install-global-transformer (quote case) (lambda (syntmp-x-1839) ((lambda (syntmp-tmp-1840) ((lambda (syntmp-tmp-1841) (if syntmp-tmp-1841 (apply (lambda (syntmp-_-1842 syntmp-e-1843 syntmp-m1-1844 syntmp-m2-1845) ((lambda (syntmp-tmp-1846) ((lambda (syntmp-body-1847) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1843)) syntmp-body-1847)) syntmp-tmp-1846)) (let syntmp-f-1848 ((syntmp-clause-1849 syntmp-m1-1844) (syntmp-clauses-1850 syntmp-m2-1845)) (if (null? syntmp-clauses-1850) ((lambda (syntmp-tmp-1852) ((lambda (syntmp-tmp-1853) (if syntmp-tmp-1853 (apply (lambda (syntmp-e1-1854 syntmp-e2-1855) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1854 syntmp-e2-1855))) syntmp-tmp-1853) ((lambda (syntmp-tmp-1857) (if syntmp-tmp-1857 (apply (lambda (syntmp-k-1858 syntmp-e1-1859 syntmp-e2-1860) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1858)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1859 syntmp-e2-1860)))) syntmp-tmp-1857) ((lambda (syntmp-_-1863) (syntax-error syntmp-x-1839)) syntmp-tmp-1852))) (syntax-dispatch syntmp-tmp-1852 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1852 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1849) ((lambda (syntmp-tmp-1864) ((lambda (syntmp-rest-1865) ((lambda (syntmp-tmp-1866) ((lambda (syntmp-tmp-1867) (if syntmp-tmp-1867 (apply (lambda (syntmp-k-1868 syntmp-e1-1869 syntmp-e2-1870) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1868)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1869 syntmp-e2-1870)) syntmp-rest-1865)) syntmp-tmp-1867) ((lambda (syntmp-_-1873) (syntax-error syntmp-x-1839)) syntmp-tmp-1866))) (syntax-dispatch syntmp-tmp-1866 (quote (each-any any . each-any))))) syntmp-clause-1849)) syntmp-tmp-1864)) (syntmp-f-1848 (car syntmp-clauses-1850) (cdr syntmp-clauses-1850))))))) syntmp-tmp-1841) (syntax-error syntmp-tmp-1840))) (syntax-dispatch syntmp-tmp-1840 (quote (any any any . each-any))))) syntmp-x-1839))) +(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1903) ((lambda (syntmp-tmp-1904) ((lambda (syntmp-tmp-1905) (if syntmp-tmp-1905 (apply (lambda (syntmp-_-1906 syntmp-e-1907) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1907)) (list (cons syntmp-_-1906 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1907 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1905) (syntax-error syntmp-tmp-1904))) (syntax-dispatch syntmp-tmp-1904 (quote (any any))))) syntmp-x-1903))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 687e0e5bf..2518fc982 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -319,12 +319,14 @@ (define fx< <) (define top-level-eval-hook - (lambda (x) - (eval `(,noexpand ,x) (interaction-environment)))) + (lambda (x mod) + (eval `(,noexpand ,x) (if mod (resolve-module mod) + (interaction-environment))))) (define local-eval-hook - (lambda (x) - (eval `(,noexpand ,x) (interaction-environment)))) + (lambda (x mod) + (eval `(,noexpand ,x) (if mod (resolve-module mod) + (interaction-environment))))) (define error-hook (lambda (who why what) @@ -335,12 +337,34 @@ ((_) (gensym)))) (define put-global-definition-hook - (lambda (symbol binding) - (putprop symbol '*sc-expander* binding))) + (lambda (symbol binding module) + (let* ((module (if module + (resolve-module module) + (warn "wha" symbol (current-module)))) + (v (or (module-variable module symbol) + (let ((v (make-variable sc-macro))) + (module-add! module symbol v) + v)))) + ;; Don't destroy Guile macros corresponding to primitive syntax + ;; when syncase boots. + (if (not (and (symbol-property symbol 'primitive-syntax) + (eq? module the-syncase-module))) + (variable-set! v sc-macro)) + ;; Properties are tied to variable objects + (set-object-property! v '*sc-expander* binding)))) (define get-global-definition-hook - (lambda (symbol) - (getprop symbol '*sc-expander*))) + (lambda (symbol module) + (let* ((module (if module + (resolve-module module) + (warn "wha" symbol (current-module)))) + (v (module-variable module symbol))) + (and v + (or (object-property v '*sc-expander*) + (and (variable-bound? v) + (macro? (variable-ref v)) + (macro-transformer (variable-ref v)) ;non-primitive + guile-macro)))))) ) @@ -372,17 +396,19 @@ (define-syntax build-global-reference (syntax-rules () - ((_ source var) - (build-annotated source var)))) + ((_ source var mod) + (build-annotated source + (make-module-ref mod var #f))))) (define-syntax build-global-assignment (syntax-rules () - ((_ source var exp) - (build-annotated source `(set! ,var ,exp))))) + ((_ source var exp mod) + (build-annotated source + `(set! ,(make-module-ref mod var #f) ,exp))))) (define-syntax build-global-definition (syntax-rules () - ((_ source var exp) + ((_ source var exp mod) (build-annotated source `(define ,var ,exp))))) (define-syntax build-lambda @@ -390,6 +416,7 @@ ((_ src vars exp) (build-annotated src `(lambda ,vars ,exp))))) +;; FIXME: wingo: add modules here somehow? (define-syntax build-primref (syntax-rules () ((_ src name) (build-annotated src name)) @@ -428,11 +455,12 @@ (build-annotated src `(letrec ,(map list vars val-exps) ,body-exp))))) +;; FIXME: wingo: use make-lexical (define-syntax build-lexical-var (syntax-rules () ((_ src id) (build-annotated src (gensym (symbol->string id)))))) -(define-structure (syntax-object expression wrap)) +(define-structure (syntax-object expression wrap module)) (define-syntax unannotate (syntax-rules () @@ -555,16 +583,17 @@ ; although symbols are usually global, we check the environment first ; anyway because a temporary binding may have been established by ; fluid-let-syntax - (lambda (x r) + (lambda (x r mod) (cond ((assq x r) => cdr) ((symbol? x) - (or (get-global-definition-hook x) (make-binding 'global))) + (or (get-global-definition-hook x mod) (make-binding 'global))) (else (make-binding 'displaced-lexical))))) (define global-extend (lambda (type sym val) - (put-global-definition-hook sym (make-binding type val)))) + (put-global-definition-hook sym (make-binding type val) + (module-name (current-module))))) ;;; Conceptually, identifiers are always syntax objects. Internally, @@ -832,40 +861,42 @@ ;;; wrapping expressions and identifiers (define wrap - (lambda (x w) + (lambda (x w defmod) (cond ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x) ((syntax-object? x) (make-syntax-object (syntax-object-expression x) - (join-wraps w (syntax-object-wrap x)))) + (join-wraps w (syntax-object-wrap x)) + (syntax-object-module x))) ((null? x) x) - (else (make-syntax-object x w))))) + (else (make-syntax-object x w defmod))))) (define source-wrap - (lambda (x w s) - (wrap (if s (make-annotation x s #f) x) w))) + (lambda (x w s defmod) + (wrap (if s (make-annotation x s #f) x) w defmod))) ;;; expanding (define chi-sequence - (lambda (body r w s) + (lambda (body r w s mod) (build-sequence s - (let dobody ((body body) (r r) (w w)) + (let dobody ((body body) (r r) (w w) (mod mod)) (if (null? body) '() - (let ((first (chi (car body) r w))) - (cons first (dobody (cdr body) r w)))))))) + (let ((first (chi (car body) r w mod))) + (cons first (dobody (cdr body) r w mod)))))))) (define chi-top-sequence - (lambda (body r w s m esew) + (lambda (body r w s m esew mod) (build-sequence s - (let dobody ((body body) (r r) (w w) (m m) (esew esew)) + (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod)) (if (null? body) '() - (let ((first (chi-top (car body) r w m esew))) - (cons first (dobody (cdr body) r w m esew)))))))) + (let ((first (chi-top (car body) r w m esew mod))) + (cons first (dobody (cdr body) r w m esew mod)))))))) +;; FIXME: module? (define chi-install-global (lambda (name e) (build-application no-source @@ -884,12 +915,12 @@ ((free-id=? x (syntax compile)) 'compile) ((free-id=? x (syntax load)) 'load) ((free-id=? x (syntax eval)) 'eval) - (else (syntax-error (wrap x w) + (else (syntax-error (wrap x w #f) "invalid eval-when situation")))) situations)))))) -;;; syntax-type returns five values: type, value, e, w, and s. The first -;;; two are described in the table below. +;;; syntax-type returns six values: type, value, e, w, s, and mod. The +;;; first two are described in the table below. ;;; ;;; type value explanation ;;; ------------------------------------------------------------------- @@ -917,99 +948,108 @@ ;;; ;;; For define-form and define-syntax-form, e is the rhs expression. ;;; For all others, e is the entire form. w is the wrap for e. -;;; s is the source for the entire form. +;;; s is the source for the entire form. mod is the module for e. ;;; ;;; syntax-type expands macros and unwraps as necessary to get to ;;; one of the forms above. It also parses define and define-syntax ;;; forms, although perhaps this should be done by the consumer. (define syntax-type - (lambda (e r w s rib) + (lambda (e r w s rib mod) (cond ((symbol? e) (let* ((n (id-var-name e w)) - (b (lookup n r)) + (b (lookup n r mod)) (type (binding-type b))) (case type - ((lexical) (values type (binding-value b) e w s)) - ((global) (values type n e w s)) + ((lexical) (values type (binding-value b) e w s mod)) + ((global) (values type n e w s mod)) ((macro) - (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib)) - (else (values type (binding-value b) e w s))))) + (syntax-type (chi-macro (binding-value b) e r w rib mod) + r empty-wrap s rib mod)) + (else (values type (binding-value b) e w s mod))))) ((pair? e) (let ((first (car e))) (if (id? first) (let* ((n (id-var-name first w)) - (b (lookup n r)) + (b (lookup n r (or (and (syntax-object? first) + (syntax-object-module first)) + mod))) (type (binding-type b))) (case type - ((lexical) (values 'lexical-call (binding-value b) e w s)) - ((global) (values 'global-call n e w s)) + ((lexical) + (values 'lexical-call (binding-value b) e w s mod)) + ((global) + (values 'global-call n e w s mod)) ((macro) - (syntax-type (chi-macro (binding-value b) e r w rib) - r empty-wrap s rib)) - ((core external-macro) (values type (binding-value b) e w s)) + (syntax-type (chi-macro (binding-value b) e r w rib mod) + r empty-wrap s rib mod)) + ((core external-macro) + (values type (binding-value b) e w s mod)) ((local-syntax) - (values 'local-syntax-form (binding-value b) e w s)) - ((begin) (values 'begin-form #f e w s)) - ((eval-when) (values 'eval-when-form #f e w s)) + (values 'local-syntax-form (binding-value b) e w s mod)) + ((begin) + (values 'begin-form #f e w s mod)) + ((eval-when) + (values 'eval-when-form #f e w s mod)) ((define) (syntax-case e () ((_ name val) (id? (syntax name)) - (values 'define-form (syntax name) (syntax val) w s)) + (values 'define-form (syntax name) (syntax val) w s mod)) ((_ (name . args) e1 e2 ...) (and (id? (syntax name)) (valid-bound-ids? (lambda-var-list (syntax args)))) ; need lambda here... - (values 'define-form (wrap (syntax name) w) - (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w)) - empty-wrap s)) + (values 'define-form (wrap (syntax name) w mod) + (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod)) + empty-wrap s mod)) ((_ name) (id? (syntax name)) - (values 'define-form (wrap (syntax name) w) + (values 'define-form (wrap (syntax name) w mod) (syntax (void)) - empty-wrap s)))) + empty-wrap s mod)))) ((define-syntax) (syntax-case e () ((_ name val) (id? (syntax name)) (values 'define-syntax-form (syntax name) - (syntax val) w s)))) - (else (values 'call #f e w s)))) - (values 'call #f e w s)))) + (syntax val) w s mod)))) + (else + (values 'call #f e w s mod)))) + (values 'call #f e w s mod)))) ((syntax-object? e) ;; s can't be valid source if we've unwrapped (syntax-type (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e)) - no-source rib)) + no-source rib (or (syntax-object-module e) mod))) ((annotation? e) - (syntax-type (annotation-expression e) r w (annotation-source e) rib)) - ((self-evaluating? e) (values 'constant #f e w s)) - (else (values 'other #f e w s))))) + (syntax-type (annotation-expression e) r w (annotation-source e) rib mod)) + ((self-evaluating? e) (values 'constant #f e w s mod)) + (else (values 'other #f e w s mod))))) (define chi-top - (lambda (e r w m esew) + (lambda (e r w m esew mod) (define-syntax eval-if-c&e (syntax-rules () - ((_ m e) + ((_ m e mod) (let ((x e)) - (if (eq? m 'c&e) (top-level-eval-hook x)) + (if (eq? m 'c&e) (top-level-eval-hook x mod)) x)))) (call-with-values - (lambda () (syntax-type e r w no-source #f)) - (lambda (type value e w s) + (lambda () (syntax-type e r w no-source #f mod)) + (lambda (type value e w s mod) (case type ((begin-form) (syntax-case e () ((_) (chi-void)) ((_ e1 e2 ...) - (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew)))) + (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod)))) ((local-syntax-form) - (chi-local-syntax value e r w s - (lambda (body r w s) - (chi-top-sequence body r w s m esew)))) + (chi-local-syntax value e r w s mod + (lambda (body r w s mod) + (chi-top-sequence body r w s m esew mod)))) ((eval-when-form) (syntax-case e () ((_ (x ...) e1 e2 ...) @@ -1018,19 +1058,20 @@ (cond ((eq? m 'e) (if (memq 'eval when-list) - (chi-top-sequence body r w s 'e '(eval)) + (chi-top-sequence body r w s 'e '(eval) mod) (chi-void))) ((memq 'load when-list) (if (or (memq 'compile when-list) (and (eq? m 'c&e) (memq 'eval when-list))) - (chi-top-sequence body r w s 'c&e '(compile load)) + (chi-top-sequence body r w s 'c&e '(compile load) mod) (if (memq m '(c c&e)) - (chi-top-sequence body r w s 'c '(load)) + (chi-top-sequence body r w s 'c '(load) mod) (chi-void)))) ((or (memq 'compile when-list) (and (eq? m 'c&e) (memq 'eval when-list))) (top-level-eval-hook - (chi-top-sequence body r w s 'e '(eval))) + (chi-top-sequence body r w s 'e '(eval) mod) + mod) (chi-void)) (else (chi-void))))))) ((define-syntax-form) @@ -1038,93 +1079,101 @@ (case m ((c) (if (memq 'compile esew) - (let ((e (chi-install-global n (chi e r w)))) - (top-level-eval-hook e) + (let ((e (chi-install-global n (chi e r w mod)))) + (top-level-eval-hook e mod) (if (memq 'load esew) e (chi-void))) (if (memq 'load esew) - (chi-install-global n (chi e r w)) + (chi-install-global n (chi e r w mod)) (chi-void)))) ((c&e) - (let ((e (chi-install-global n (chi e r w)))) - (top-level-eval-hook e) + (let ((e (chi-install-global n (chi e r w mod)))) + (top-level-eval-hook e mod) e)) (else (if (memq 'eval esew) (top-level-eval-hook - (chi-install-global n (chi e r w)))) + (chi-install-global n (chi e r w mod)) + mod)) (chi-void))))) ((define-form) (let* ((n (id-var-name value w)) - (type (binding-type (lookup n r)))) + (type (binding-type (lookup n r mod)))) (case type ((global) (eval-if-c&e m - (build-global-definition s n (chi e r w)))) + (build-global-definition s n (chi e r w mod) mod) + mod)) ((displaced-lexical) - (syntax-error (wrap value w) "identifier out of context")) + (syntax-error (wrap value w mod) "identifier out of context")) (else (if (eq? type 'external-macro) (eval-if-c&e m - (build-global-definition s n (chi e r w))) - (syntax-error (wrap value w) + (build-global-definition s n (chi e r w mod) mod) + mod) + (syntax-error (wrap value w mod) "cannot define keyword at top level")))))) - (else (eval-if-c&e m (chi-expr type value e r w s)))))))) + (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) (define chi - (lambda (e r w) + (lambda (e r w mod) (call-with-values - (lambda () (syntax-type e r w no-source #f)) - (lambda (type value e w s) - (chi-expr type value e r w s))))) + (lambda () (syntax-type e r w no-source #f mod)) + (lambda (type value e w s mod) + (chi-expr type value e r w s mod))))) (define chi-expr - (lambda (type value e r w s) + (lambda (type value e r w s mod) (case type ((lexical) (build-lexical-reference 'value s value)) - ((core external-macro) (value e r w s)) + ((core external-macro) + ;; apply transformer + (value e r w s mod)) ((lexical-call) (chi-application (build-lexical-reference 'fun (source-annotation (car e)) value) - e r w s)) + e r w s mod)) ((global-call) (chi-application - (build-global-reference (source-annotation (car e)) value) - e r w s)) - ((constant) (build-data s (strip (source-wrap e w s) empty-wrap))) - ((global) (build-global-reference s value)) - ((call) (chi-application (chi (car e) r w) e r w s)) + (build-global-reference (source-annotation (car e)) value + (if (syntax-object? (car e)) + (syntax-object-module (car e)) + mod)) + e r w s mod)) + ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) + ((global) (build-global-reference s value mod)) + ((call) (chi-application (chi (car e) r w mod) e r w s mod)) ((begin-form) (syntax-case e () - ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s)))) + ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod)))) ((local-syntax-form) - (chi-local-syntax value e r w s chi-sequence)) + (chi-local-syntax value e r w s mod chi-sequence)) ((eval-when-form) (syntax-case e () ((_ (x ...) e1 e2 ...) (let ((when-list (chi-when-list e (syntax (x ...)) w))) (if (memq 'eval when-list) - (chi-sequence (syntax (e1 e2 ...)) r w s) + (chi-sequence (syntax (e1 e2 ...)) r w s mod) (chi-void)))))) ((define-form define-syntax-form) - (syntax-error (wrap value w) "invalid context for definition of")) + (syntax-error (wrap value w mod) "invalid context for definition of")) ((syntax) - (syntax-error (source-wrap e w s) + (syntax-error (source-wrap e w s mod) "reference to pattern variable outside syntax form")) ((displaced-lexical) - (syntax-error (source-wrap e w s) + (syntax-error (source-wrap e w s mod) "reference to identifier outside its scope")) - (else (syntax-error (source-wrap e w s)))))) + (else (syntax-error (source-wrap e w s mod)))))) (define chi-application - (lambda (x e r w s) + (lambda (x e r w s mod) (syntax-case e () ((e0 e1 ...) (build-application s x - (map (lambda (e) (chi e r w)) (syntax (e1 ...)))))))) + (map (lambda (e) (chi e r w mod)) (syntax (e1 ...)))))))) (define chi-macro - (lambda (p e r w rib) + (lambda (p e r w rib mod) (define rebuild-macro-output (lambda (x m) (cond ((pair? x) @@ -1133,14 +1182,20 @@ ((syntax-object? x) (let ((w (syntax-object-wrap x))) (let ((ms (wrap-marks w)) (s (wrap-subst w))) - (make-syntax-object (syntax-object-expression x) - (if (and (pair? ms) (eq? (car ms) the-anti-mark)) - (make-wrap (cdr ms) - (if rib (cons rib (cdr s)) (cdr s))) - (make-wrap (cons m ms) - (if rib - (cons rib (cons 'shift s)) - (cons 'shift s)))))))) + (if (and (pair? ms) (eq? (car ms) the-anti-mark)) + ;; output is from original text + (make-syntax-object + (syntax-object-expression x) + (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) + (syntax-object-module x)) + ;; output introduced by macro + (make-syntax-object + (syntax-object-expression x) + (make-wrap (cons m ms) + (if rib + (cons rib (cons 'shift s)) + (cons 'shift s))) + (module-name (procedure-module p))))))) ;; hither the hygiene ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) @@ -1150,7 +1205,7 @@ ((symbol? x) (syntax-error x "encountered raw symbol in macro output")) (else x)))) - (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark)))) + (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark)))) (define chi-body ;; In processing the forms of the body, we create a new, empty wrap. @@ -1191,34 +1246,34 @@ ;; into the body. ;; ;; outer-form is fully wrapped w/source - (lambda (body outer-form r w) + (lambda (body outer-form r w mod) (let* ((r (cons '("placeholder" . (placeholder)) r)) (ribcage (make-empty-ribcage)) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) - (let parse ((body (map (lambda (x) (cons r (wrap x w))) body)) + (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) (ids '()) (labels '()) (vars '()) (vals '()) (bindings '())) (if (null? body) (syntax-error outer-form "no expressions in body") (let ((e (cdar body)) (er (caar body))) (call-with-values - (lambda () (syntax-type e er empty-wrap no-source ribcage)) - (lambda (type value e w s) + (lambda () (syntax-type e er empty-wrap no-source ribcage mod)) + (lambda (type value e w s mod) (case type ((define-form) - (let ((id (wrap value w)) (label (gen-label))) + (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 var vars) (cons (cons er (wrap e w)) vals) + (cons var vars) (cons (cons er (wrap e w mod)) vals) (cons (make-binding 'lexical var) bindings))))) ((define-syntax-form) - (let ((id (wrap value w)) (label (gen-label))) + (let ((id (wrap value w mod)) (label (gen-label))) (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) vars vals - (cons (make-binding 'macro (cons er (wrap e w))) + (cons (make-binding 'macro (cons er (wrap e w mod))) bindings)))) ((begin-form) (syntax-case e () @@ -1226,24 +1281,24 @@ (parse (let f ((forms (syntax (e1 ...)))) (if (null? forms) (cdr body) - (cons (cons er (wrap (car forms) w)) + (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) ids labels vars vals bindings)))) ((local-syntax-form) - (chi-local-syntax value e er w s - (lambda (forms er w s) + (chi-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)) + (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) ids labels vars vals bindings)))) (else ; found a non-definition (if (null? ids) (build-sequence no-source (map (lambda (x) - (chi (cdr x) (car x) empty-wrap)) - (cons (cons er (source-wrap e w s)) + (chi (cdr x) (car x) empty-wrap mod)) + (cons (cons er (source-wrap e w s mod)) (cdr body)))) (begin (if (not (valid-bound-ids? ids)) @@ -1260,23 +1315,24 @@ (macros-only-env er)))) (set-cdr! b (eval-local-transformer - (chi (cddr b) r-cache empty-wrap))) + (chi (cddr b) r-cache empty-wrap mod) + mod)) (loop (cdr bs) er r-cache)) (loop (cdr bs) er-cache r-cache))))) (set-cdr! r (extend-env labels bindings (cdr r))) (build-letrec no-source vars (map (lambda (x) - (chi (cdr x) (car x) empty-wrap)) + (chi (cdr x) (car x) empty-wrap mod)) vals) (build-sequence no-source (map (lambda (x) - (chi (cdr x) (car x) empty-wrap)) - (cons (cons er (source-wrap e w s)) + (chi (cdr x) (car x) empty-wrap mod)) + (cons (cons er (source-wrap e w s mod)) (cdr body))))))))))))))))) (define chi-lambda-clause - (lambda (e c r w k) + (lambda (e c r w mod k) (syntax-case c () (((id ...) e1 e2 ...) (let ((ids (syntax (id ...)))) @@ -1288,7 +1344,8 @@ (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) - (make-binding-wrap ids labels w))))))) + (make-binding-wrap ids labels w) + mod)))))) ((ids e1 e2 ...) (let ((old-ids (lambda-var-list (syntax ids)))) (if (not (valid-bound-ids? old-ids)) @@ -1302,11 +1359,12 @@ (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) - (make-binding-wrap old-ids labels w))))))) + (make-binding-wrap old-ids labels w) + mod)))))) (_ (syntax-error e))))) (define chi-local-syntax - (lambda (rec? e r w s k) + (lambda (rec? e r w s mod k) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) (let ((ids (syntax (id ...)))) @@ -1321,16 +1379,19 @@ (trans-r (macros-only-env r))) (map (lambda (x) (make-binding 'macro - (eval-local-transformer (chi x trans-r w)))) + (eval-local-transformer + (chi x trans-r w mod) + mod))) (syntax (val ...)))) r) new-w - s)))))) - (_ (syntax-error (source-wrap e w s)))))) + s + mod)))))) + (_ (syntax-error (source-wrap e w s mod)))))) (define eval-local-transformer - (lambda (expanded) - (let ((p (local-eval-hook expanded))) + (lambda (expanded mod) + (let ((p (local-eval-hook expanded mod))) (if (procedure? p) p (syntax-error p "nonprocedure transformer"))))) @@ -1410,8 +1471,8 @@ (lambda (vars) (let lvl ((vars vars) (ls '()) (w empty-wrap)) (cond - ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w)) - ((id? vars) (cons (wrap vars w) ls)) + ((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) @@ -1429,46 +1490,48 @@ (global-extend 'local-syntax 'let-syntax #f) (global-extend 'core 'fluid-let-syntax - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ ((var val) ...) e1 e2 ...) (valid-bound-ids? (syntax (var ...))) (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...))))) (for-each (lambda (id n) - (case (binding-type (lookup n r)) + (case (binding-type (lookup n r mod)) ((displaced-lexical) - (syntax-error (source-wrap id w s) + (syntax-error (source-wrap id w s mod) "identifier out of context")))) (syntax (var ...)) names) (chi-body (syntax (e1 e2 ...)) - (source-wrap e w s) + (source-wrap e w s mod) (extend-env names (let ((trans-r (macros-only-env r))) (map (lambda (x) (make-binding 'macro - (eval-local-transformer (chi x trans-r w)))) + (eval-local-transformer (chi x trans-r w mod) + mod))) (syntax (val ...)))) r) - w))) - (_ (syntax-error (source-wrap e w s)))))) + w + mod))) + (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'core 'quote - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ e) (build-data s (strip (syntax e) w))) - (_ (syntax-error (source-wrap e w s)))))) + (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'core 'syntax (let () (define gen-syntax - (lambda (src e r maps ellipsis?) + (lambda (src e r maps ellipsis? mod) (if (id? e) (let ((label (id-var-name e empty-wrap))) - (let ((b (lookup label r))) + (let ((b (lookup label r mod))) (if (eq? (binding-type b) 'syntax) (call-with-values (lambda () @@ -1481,7 +1544,7 @@ (syntax-case e () ((dots e) (ellipsis? (syntax dots)) - (gen-syntax src (syntax e) r maps (lambda (x) #f))) + (gen-syntax src (syntax e) r maps (lambda (x) #f) mod)) ((x dots . y) ; this could be about a dozen lines of code, except that we ; choose to handle (syntax (x ... ...)) forms @@ -1491,7 +1554,7 @@ (call-with-values (lambda () (gen-syntax src (syntax x) r - (cons '() maps) ellipsis?)) + (cons '() maps) ellipsis? mod)) (lambda (x maps) (if (null? (car maps)) (syntax-error src @@ -1512,7 +1575,7 @@ (values (gen-mappend x (car maps)) (cdr maps)))))))) (_ (call-with-values - (lambda () (gen-syntax src y r maps ellipsis?)) + (lambda () (gen-syntax src y r maps ellipsis? mod)) (lambda (y maps) (call-with-values (lambda () (k maps)) @@ -1520,15 +1583,15 @@ (values (gen-append x y) maps))))))))) ((x . y) (call-with-values - (lambda () (gen-syntax src (syntax x) r maps ellipsis?)) + (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod)) (lambda (x maps) (call-with-values - (lambda () (gen-syntax src (syntax y) r maps ellipsis?)) + (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod)) (lambda (y maps) (values (gen-cons x y) maps)))))) (#(e1 e2 ...) (call-with-values (lambda () - (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?)) + (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod)) (lambda (e maps) (values (gen-vector e) maps)))) (_ (values `(quote ,e) maps)))))) @@ -1618,27 +1681,27 @@ (build-primref no-source (car x)) (map regen (cdr x))))))) - (lambda (e r w s) - (let ((e (source-wrap e w s))) + (lambda (e r w s mod) + (let ((e (source-wrap e w s mod))) (syntax-case e () ((_ x) (call-with-values - (lambda () (gen-syntax e (syntax x) r '() ellipsis?)) + (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod)) (lambda (e maps) (regen e)))) (_ (syntax-error e))))))) (global-extend 'core 'lambda - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ . c) - (chi-lambda-clause (source-wrap e w s) (syntax c) r w + (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod (lambda (vars body) (build-lambda s vars body))))))) (global-extend 'core 'let (let () - (define (chi-let e r w s constructor ids vals exps) + (define (chi-let e r w s mod constructor ids vals exps) (if (not (valid-bound-ids? ids)) (syntax-error e "duplicate bound variable in") (let ((labels (gen-labels ids)) @@ -1647,28 +1710,29 @@ (nr (extend-var-env labels new-vars r))) (constructor s new-vars - (map (lambda (x) (chi x r w)) vals) - (chi-body exps (source-wrap e nw s) nr nw)))))) - (lambda (e r w s) + (map (lambda (x) (chi x r w mod)) vals) + (chi-body exps (source-wrap e nw s mod) + nr nw mod)))))) + (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) - (chi-let e r w s + (chi-let e r w s mod build-let (syntax (id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) ((_ f ((id val) ...) e1 e2 ...) (id? (syntax f)) - (chi-let e r w s + (chi-let e r w s mod build-named-let (syntax (f id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) - (_ (syntax-error (source-wrap e w s))))))) + (_ (syntax-error (source-wrap e w s mod))))))) (global-extend 'core 'letrec - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) (let ((ids (syntax (id ...)))) @@ -1680,33 +1744,34 @@ (r (extend-var-env labels new-vars r))) (build-letrec s new-vars - (map (lambda (x) (chi x r w)) (syntax (val ...))) - (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w))))))) - (_ (syntax-error (source-wrap e w s)))))) + (map (lambda (x) (chi x r w mod)) (syntax (val ...))) + (chi-body (syntax (e1 e2 ...)) + (source-wrap e w s mod) r w mod))))))) + (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'core 'set! - (lambda (e r w s) + (lambda (e r w s mod) (syntax-case e () ((_ id val) (id? (syntax id)) - (let ((val (chi (syntax val) r w)) + (let ((val (chi (syntax val) r w mod)) (n (id-var-name (syntax id) w))) - (let ((b (lookup n r))) + (let ((b (lookup n r mod))) (case (binding-type b) ((lexical) (build-lexical-assignment s (binding-value b) val)) - ((global) (build-global-assignment s n val)) + ((global) (build-global-assignment s n val mod)) ((displaced-lexical) - (syntax-error (wrap (syntax id) w) + (syntax-error (wrap (syntax id) w mod) "identifier out of context")) - (else (syntax-error (source-wrap e w s))))))) + (else (syntax-error (source-wrap e w s mod))))))) ((_ (getter arg ...) val) (build-application s - (chi (syntax (setter getter)) r w) - (map (lambda (e) (chi e r w)) + (chi (syntax (setter getter)) r w mod) + (map (lambda (e) (chi e r w mod)) (syntax (arg ... val))))) - (_ (syntax-error (source-wrap e w s)))))) + (_ (syntax-error (source-wrap e w s mod)))))) (global-extend 'begin 'begin '()) @@ -1751,25 +1816,26 @@ (x (values (vector 'atom (strip p empty-wrap)) ids))))))) (define build-dispatch-call - (lambda (pvars exp y r) + (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-application no-source (build-primref no-source 'apply) (list (build-lambda no-source new-vars (chi exp - (extend-env - labels - (map (lambda (var level) - (make-binding 'syntax `(,var . ,level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels empty-wrap))) + (extend-env + labels + (map (lambda (var level) + (make-binding 'syntax `(,var . ,level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap) + mod)) y)))))) (define gen-clause - (lambda (x keys clauses r pat fender exp) + (lambda (x keys clauses r pat fender exp mod) (call-with-values (lambda () (convert-pattern pat keys)) (lambda (p pvars) @@ -1791,10 +1857,10 @@ (#t y) (_ (build-conditional no-source y - (build-dispatch-call pvars fender y r) + (build-dispatch-call pvars fender y r mod) (build-data no-source #f)))) - (build-dispatch-call pvars exp y r) - (gen-syntax-case x keys clauses r)))) + (build-dispatch-call pvars exp y r mod) + (gen-syntax-case x keys clauses r mod)))) (list (if (eq? p 'any) (build-application no-source (build-primref no-source 'list) @@ -1804,7 +1870,7 @@ (list x (build-data no-source p))))))))))))) (define gen-syntax-case - (lambda (x keys clauses r) + (lambda (x keys clauses r mod) (if (null? clauses) (build-application no-source (build-primref no-source 'syntax-error) @@ -1823,17 +1889,18 @@ (list (make-binding 'syntax `(,var . 0))) r) (make-binding-wrap (syntax (pat)) - labels empty-wrap))) + labels empty-wrap) + mod)) (list x))) (gen-clause x keys (cdr clauses) r - (syntax pat) #t (syntax exp)))) + (syntax pat) #t (syntax exp) mod))) ((pat fender exp) (gen-clause x keys (cdr clauses) r - (syntax pat) (syntax fender) (syntax exp))) + (syntax pat) (syntax fender) (syntax exp) mod)) (_ (syntax-error (car clauses) "invalid syntax-case clause")))))) - (lambda (e r w s) - (let ((e (source-wrap e w s))) + (lambda (e r w s mod) + (let ((e (source-wrap e w s mod))) (syntax-case e () ((_ val (key ...) m ...) (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) @@ -1844,8 +1911,9 @@ (build-lambda no-source (list x) (gen-syntax-case (build-lexical-reference 'value no-source x) (syntax (key ...)) (syntax (m ...)) - r)) - (list (chi (syntax val) r empty-wrap)))) + r + mod)) + (list (chi (syntax val) r empty-wrap mod)))) (syntax-error e "invalid literals list in")))))))) ;;; The portable sc-expand seeds chi-top's mode m with 'e (for @@ -1862,7 +1930,8 @@ (lambda (x) (if (and (pair? x) (equal? (car x) noexpand)) (cadr x) - (chi-top x null-env top-wrap m esew))))) + (chi-top x null-env top-wrap m esew + (module-name (current-module))))))) (set! sc-expand3 (let ((m 'e) (esew '(eval))) @@ -1875,7 +1944,8 @@ (if (null? rest) m (car rest)) (if (or (null? rest) (null? (cdr rest))) esew - (cadr rest))))))) + (cadr rest)) + (module-name (current-module))))))) (set! identifier? (lambda (x) @@ -1883,7 +1953,7 @@ (set! datum->syntax-object (lambda (id datum) - (make-syntax-object datum (syntax-object-wrap id)))) + (make-syntax-object datum (syntax-object-wrap id) #f))) (set! syntax-object->datum ; accepts any object, since syntax objects may consist partially @@ -1894,7 +1964,7 @@ (set! generate-temporaries (lambda (ls) (arg-check list? ls 'generate-temporaries) - (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls))) + (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls))) (set! free-identifier=? (lambda (x y) @@ -1947,34 +2017,36 @@ (let () (define match-each - (lambda (e p w) + (lambda (e p w mod) (cond ((annotation? e) - (match-each (annotation-expression e) p w)) + (match-each (annotation-expression e) p w mod)) ((pair? e) - (let ((first (match (car e) p w '()))) + (let ((first (match (car e) p w '() mod))) (and first - (let ((rest (match-each (cdr e) p w))) + (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)))) + (join-wraps w (syntax-object-wrap e)) + (syntax-object-module e))) (else #f)))) (define match-each-any - (lambda (e w) + (lambda (e w mod) (cond ((annotation? e) - (match-each-any (annotation-expression e) w)) + (match-each-any (annotation-expression e) w mod)) ((pair? e) - (let ((l (match-each-any (cdr e) w))) - (and l (cons (wrap (car e) w) l)))) + (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)))) + (join-wraps w (syntax-object-wrap e)) + mod)) (else #f)))) (define match-empty @@ -1991,43 +2063,45 @@ ((vector) (match-empty (vector-ref p 1) r))))))) (define match* - (lambda (e p w r) + (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)))) + (match (cdr e) (cdr p) w r mod) + mod))) ((eq? p 'each-any) - (let ((l (match-each-any e w))) (and l (cons l r)))) + (let ((l (match-each-any e w mod))) (and l (cons l r)))) (else (case (vector-ref p 0) ((each) (if (null? e) (match-empty (vector-ref p 1) r) - (let ((l (match-each e (vector-ref p 1) w))) + (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))))))))) - ((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r)) + ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) ((atom) (and (equal? (vector-ref p 1) (strip e w)) r)) ((vector) (and (vector? e) - (match (vector->list e) (vector-ref p 1) w r)))))))) + (match (vector->list e) (vector-ref p 1) w r mod)))))))) (define match - (lambda (e p w r) + (lambda (e p w r mod) (cond ((not r) #f) - ((eq? p 'any) (cons (wrap e w) r)) + ((eq? p 'any) (cons (wrap e w mod) r)) ((syntax-object? e) (match* (unannotate (syntax-object-expression e)) p (join-wraps w (syntax-object-wrap e)) - r)) - (else (match* (unannotate e) p w r))))) + r + (syntax-object-module e))) + (else (match* (unannotate e) p w r mod))))) (set! syntax-dispatch (lambda (e p) @@ -2035,8 +2109,8 @@ ((eq? p 'any) (list e)) ((syntax-object? e) (match* (unannotate (syntax-object-expression e)) - p (syntax-object-wrap e) '())) - (else (match* (unannotate e) p empty-wrap '()))))) + p (syntax-object-wrap e) '() (syntax-object-module e))) + (else (match* (unannotate e) p empty-wrap '() #f))))) (set! sc-chi chi) )) @@ -2213,4 +2287,3 @@ (syntax e)) ((_ x (... ...)) (syntax (e x (... ...))))))))))) - diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index 5a5e1a6ea..a6bdaa4a9 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -17,10 +17,11 @@ (define-module (ice-9 syncase) + :use-module (ice-9 expand-support) :use-module (ice-9 debug) :use-module (ice-9 threads) :export-syntax (sc-macro define-syntax define-syntax-public - eval-when fluid-let-syntax + fluid-let-syntax identifier-syntax let-syntax letrec-syntax syntax syntax-case syntax-rules with-syntax @@ -30,25 +31,21 @@ datum->syntax-object free-identifier=? generate-temporaries identifier? syntax-object->datum void syncase) - :replace (eval)) + :replace (eval eval-when)) -(define expansion-eval-closure (make-fluid)) -(define (current-eval-closure) - (or (fluid-ref expansion-eval-closure) - (module-eval-closure (current-module)))) - -(define (env->eval-closure env) - (and env (car (last-pair env)))) - (define (annotation? x) #f) (define sc-macro (procedure->memoizing-macro (lambda (exp env) - (with-fluids ((expansion-eval-closure (env->eval-closure env))) - (sc-expand exp))))) + (save-module-excursion + (lambda () + ;; Because memoization happens lazily, env's module isn't + ;; necessarily the current module. + (set-current-module (eval-closure-module (car (last-pair env)))) + (strip-expansion-structures (sc-expand exp))))))) ;;; Exported variables @@ -105,55 +102,28 @@ '()))) (define the-syncase-module (current-module)) -(define the-syncase-eval-closure (module-eval-closure the-syncase-module)) - -(fluid-set! expansion-eval-closure the-syncase-eval-closure) - -(define (putprop symbol key binding) - (let* ((eval-closure (current-eval-closure)) - ;; Why not simply do (eval-closure symbol #t)? - ;; Answer: That would overwrite imported bindings - (v (or (eval-closure symbol #f) ;lookup - (eval-closure symbol #t) ;create it locally - ))) - ;; Don't destroy Guile macros corresponding to - ;; primitive syntax when syncase boots. - (if (not (and (symbol-property symbol 'primitive-syntax) - (eq? eval-closure the-syncase-eval-closure))) - (variable-set! v sc-macro)) - ;; Properties are tied to variable objects - (set-object-property! v key binding))) - -(define (getprop symbol key) - (let* ((v ((current-eval-closure) symbol #f))) - (and v - (or (object-property v key) - (and (variable-bound? v) - (macro? (variable-ref v)) - (macro-transformer (variable-ref v)) ;non-primitive - guile-macro))))) (define guile-macro (cons 'external-macro - (lambda (e r w s) + (lambda (e r w s mod) (let ((e (syntax-object->datum e))) (if (symbol? e) ;; pass the expression through e - (let* ((eval-closure (current-eval-closure)) - (m (variable-ref (eval-closure (car e) #f)))) + (let* ((mod (resolve-module mod)) + (m (module-ref mod (car e)))) (if (eq? (macro-type m) 'syntax) ;; pass the expression through e ;; perform Guile macro transform (let ((e ((macro-transformer m) - e - (append r (list eval-closure))))) + (strip-expansion-structures e) + (append r (list (module-eval-closure mod)))))) (if (variable? e) e (if (null? r) (sc-expand e) - (sc-chi e r w))))))))))) + (sc-chi e r w (module-name mod)))))))))))) (define generated-symbols (make-weak-key-hash-table 1019)) @@ -207,25 +177,20 @@ (set! old-debug (debug-options)) (set! old-read (read-options))) (lambda () - (debug-disable 'debug 'procnames) - (read-disable 'positions) + (debug-disable 'debug 'procnames) + (read-disable 'positions) (load-from-path "ice-9/psyntax-pp")) (lambda () (debug-options old-debug) (read-options old-read)))) - -;;; The following lines are necessary only if we start making changes -;; (use-syntax sc-expand) -;; (load-from-path "ice-9/psyntax") - (define internal-eval (nested-ref the-scm-module '(%app modules guile eval))) (define (eval x environment) (internal-eval (if (and (pair? x) (equal? (car x) "noexpand")) - (cadr x) - (sc-expand x)) + (strip-expansion-structures (cadr x)) + (strip-expansion-structures (sc-expand x))) environment)) ;;; Hack to make syncase macros work in the slib module @@ -236,9 +201,7 @@ '(define)))) (define (syncase exp) - (with-fluids ((expansion-eval-closure - (module-eval-closure (current-module)))) - (sc-expand exp))) + (strip-expansion-structures (sc-expand exp))) (set-module-transformer! the-syncase-module syncase) @@ -248,5 +211,3 @@ (begin ;(eval-case ((load-toplevel) (export-syntax name))) (define-syntax name rules ...))))) - -(fluid-set! expansion-eval-closure #f) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index fcca8a940..86234059e 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -27,6 +27,7 @@ #:use-module (system vm objcode) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) + #:use-module (ice-9 expand-support) #:use-module ((ice-9 syncase) #:select (sc-macro)) #:use-module ((system base compile) #:select (syntax-error)) #:export (compile-ghil translate-1 @@ -93,17 +94,25 @@ ;; ;; FIXME shadowing lexicals? (define (lookup-transformer head retrans) + (define (module-ref/safe mod sym) + (and mod + (and=> (module-variable mod sym) + (lambda (var) + ;; unbound vars can happen if the module + ;; definition forward-declared them + (and (variable-bound? var) (variable-ref var)))))) (let* ((mod (current-module)) (val (cond - ((symbol? head) - (and=> (module-variable mod head) - (lambda (var) - ;; unbound vars can happen if the module - ;; definition forward-declared them - (and (variable-bound? var) (variable-ref var))))) + ((symbol? head) (module-ref/safe mod head)) ;; allow macros to be unquoted into the output of a macro ;; expansion ((macro? head) head) + ((pmatch head + ((@ ,modname ,sym) + (module-ref/safe (resolve-interface modname) sym)) + ((@@ ,modname ,sym) + (module-ref/safe (resolve-module modname) sym)) + (else #f))) (else #f)))) (cond ((hashq-ref *translate-table* val)) @@ -114,12 +123,11 @@ ((eq? val sc-macro) ;; syncase! - (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure)) - (sc-expand3 (@@ (ice-9 syncase) sc-expand3))) + (let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3))) (lambda (env loc exp) (retrans - (with-fluids ((eec (module-eval-closure mod))) - (sc-expand3 exp 'c '(compile load eval))))))) + (strip-expansion-structures + (sc-expand3 exp 'c '(compile load eval))))))) ((primitive-macro? val) (syntax-error #f "unhandled primitive macro" head)) diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm index ee689a092..18dc032c9 100644 --- a/module/language/scheme/expand.scm +++ b/module/language/scheme/expand.scm @@ -21,7 +21,7 @@ (define-module (language scheme expand) #:use-module (language scheme amatch) - #:use-module (ice-9 annotate) + #:use-module (ice-9 expand-support) #:use-module (ice-9 optargs) #:use-module ((ice-9 syncase) #:select (sc-macro)) #:use-module ((system base compile) #:select (syntax-error)) diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm index ed61464f0..902fc49a5 100644 --- a/module/system/base/pmatch.scm +++ b/module/system/base/pmatch.scm @@ -1,6 +1,6 @@ (define-module (system base pmatch) #:use-module (ice-9 syncase) - #:export (pmatch ppat)) + #:export (pmatch)) ;; FIXME: shouldn't have to export ppat... ;; Originally written by Oleg Kiselyov. Taken from: