From 9c35c5796cbffda57d76499048e8b8f82db943eb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 23:10:31 +0200 Subject: make sure we compile boot code in (guile), not (guile-user) * libguile/eval.h: * libguile/eval.c (scm_m_eval_when): Define a cheap eval-when, used before syncase has booted. * module/Makefile.am: Reorder to put (system vm) and (system repl) modules after the compiler, as they are not needed at runtime. * module/ice-9/boot-9.scm: Move the eval-when earlier, to be the first thing -- so when we recompile Guile we do so all in the '(guile) module, not '(guile-user). * module/ice-9/compile-psyntax.scm: Rewrite to assume that psyntax.scm will eval-when to set its module, etc. Have everything in a let -- otherwise the `format' call is in (guile), but `target' was defined in (guile-user). Also, write in an eval-when to the expanded file. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/networking.scm: * module/ice-9/psyntax.scm: * module/ice-9/r4rs.scm: Sprinkles of eval-when, for flavor. --- libguile/eval.c | 19 +++++++++++++++++++ libguile/eval.h | 2 ++ 2 files changed, 21 insertions(+) (limited to 'libguile') diff --git a/libguile/eval.c b/libguile/eval.c index 19ac0b155..5b1473e06 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2140,6 +2140,25 @@ unmemoize_at_call_with_values (const SCM expr, const SCM env) unmemoize_exprs (SCM_CDR (expr), env)); } +SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when); +SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when); +SCM_SYMBOL (sym_eval, "eval"); +SCM_SYMBOL (sym_load, "load"); + + +SCM +scm_m_eval_when (SCM expr, SCM env SCM_UNUSED) +{ + ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + + if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr))) + || scm_is_true (scm_memq (sym_load, scm_cadr (expr)))) + return scm_caddr (expr); + + return scm_list_1 (SCM_IM_BEGIN); +} + #if 0 /* See futures.h for a comment why futures are not enabled. diff --git a/libguile/eval.h b/libguile/eval.h index f3ec2e19c..b017f2e02 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -100,6 +100,7 @@ SCM_API SCM scm_sym_atapply; SCM_API SCM scm_sym_atcall_cc; SCM_API SCM scm_sym_at_call_with_values; SCM_API SCM scm_sym_delay; +SCM_API SCM scm_sym_eval_when; SCM_API SCM scm_sym_arrow; SCM_API SCM scm_sym_else; SCM_API SCM scm_sym_apply; @@ -146,6 +147,7 @@ SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env); SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env); SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env); SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env); +SCM_API SCM scm_m_eval_when (SCM xorig, SCM env); SCM_API int scm_badargsp (SCM formals, SCM args); SCM_API SCM scm_call_0 (SCM proc); SCM_API SCM scm_call_1 (SCM proc, SCM arg1); -- cgit v1.2.3 From b3501b8043d36a3215ec51e321a2aa3733ea54cc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Apr 2009 14:10:08 +0200 Subject: all of guile compiles now, expanded with syncase * libguile/eval.c (scm_m_eval_when): Whoops, eval-when has an implicit begin. Fix. * module/oop/goops.scm: Syncase doesn't like definitions in expression context, and grudgingly I have decided to go along with that. But that doesn't mean we can't keep the old semantics, via accessing the module system directly. So do so. I took the opportunity to rewrite some macros with syntax-rules and syntax-case -- the former is nicer than the latter, of course. * module/oop/goops/save.scm: Don't define within an expression. * module/oop/goops/simple.scm (define-class): Use define-syntax. * module/oop/goops/stklos.scm (define-class): Use define-syntax. --- libguile/eval.c | 4 +- module/oop/goops.scm | 169 ++++++++++++++++++++++++++------------------ module/oop/goops/save.scm | 4 +- module/oop/goops/simple.scm | 5 +- module/oop/goops/stklos.scm | 71 +++++++------------ 5 files changed, 131 insertions(+), 122 deletions(-) (limited to 'libguile') diff --git a/libguile/eval.c b/libguile/eval.c index 5b1473e06..05af5a1c5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2149,12 +2149,12 @@ SCM_SYMBOL (sym_load, "load"); SCM scm_m_eval_when (SCM expr, SCM env SCM_UNUSED) { - ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr))) || scm_is_true (scm_memq (sym_load, scm_cadr (expr)))) - return scm_caddr (expr); + return scm_cons (SCM_IM_BEGIN, scm_cddr (expr)); return scm_list_1 (SCM_IM_BEGIN); } diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 7e9eae9a9..873e4b831 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -154,17 +154,6 @@ ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) ;;; OPTION ::= KEYWORD VALUE ;;; -(define (define-class-pre-definition kw val) - (case kw - ((#:getter #:setter) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-generic ,val))) - ((#:accessor) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-accessor ,val))) - (else #f))) (define (kw-do-map mapper f kwargs) (define (keywords l) @@ -180,33 +169,37 @@ (a (args kwargs))) (mapper f k a))) -;;; This code should be implemented in C. -;;; -(define-macro (define-class name supers . slots) - ;; Some slot options require extra definitions to be made. In - ;; particular, we want to make sure that the generic function objects - ;; which represent accessors exist before `make-class' tries to add - ;; methods to them. - ;; - ;; Postpone some error handling to class macro. - ;; - `(begin - ;; define accessors - ,@(append-map (lambda (slot) - (kw-do-map filter-map - define-class-pre-definition - (if (pair? slot) (cdr slot) '()))) - (take-while (lambda (x) (not (keyword? x))) slots)) - (if (and (defined? ',name) - (is-a? ,name ) - (memq (class-precedence-list ,name))) - (class-redefinition ,name - (class ,supers ,@slots #:name ',name)) - (define ,name (class ,supers ,@slots #:name ',name))))) +(define (make-class supers slots . options) + (let ((env (or (get-keyword #:environment options #f) + (top-level-env)))) + (let* ((name (get-keyword #:name options (make-unbound))) + (supers (if (not (or-map (lambda (class) + (memq + (class-precedence-list class))) + supers)) + (append supers (list )) + supers)) + (metaclass (or (get-keyword #:metaclass options #f) + (ensure-metaclass supers env)))) -(define-syntax standard-define-class - (syntax-rules () - ((_ arg ...) (define-class arg ...)))) + ;; Verify that all direct slots are different and that we don't inherit + ;; several time from the same class + (let ((tmp1 (find-duplicate supers)) + (tmp2 (find-duplicate (map slot-definition-name slots)))) + (if tmp1 + (goops-error "make-class: super class ~S is duplicate in class ~S" + tmp1 name)) + (if tmp2 + (goops-error "make-class: slot ~S is duplicate in class ~S" + tmp2 name))) + + ;; Everything seems correct, build the class + (apply make metaclass + #:dsupers supers + #:slots slots + #:name name + #:environment env + options)))) ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) ;;; @@ -231,7 +224,6 @@ (else `(list ',def)))) slots)) - (if (not (list? supers)) (goops-error "malformed superclass list: ~S" supers)) (let ((slot-defs (cons #f '())) @@ -245,37 +237,71 @@ ;; evaluate class options ,@options))) -(define (make-class supers slots . options) - (let ((env (or (get-keyword #:environment options #f) - (top-level-env)))) - (let* ((name (get-keyword #:name options (make-unbound))) - (supers (if (not (or-map (lambda (class) - (memq - (class-precedence-list class))) - supers)) - (append supers (list )) - supers)) - (metaclass (or (get-keyword #:metaclass options #f) - (ensure-metaclass supers env)))) - - ;; Verify that all direct slots are different and that we don't inherit - ;; several time from the same class - (let ((tmp1 (find-duplicate supers)) - (tmp2 (find-duplicate (map slot-definition-name slots)))) - (if tmp1 - (goops-error "make-class: super class ~S is duplicate in class ~S" - tmp1 name)) - (if tmp2 - (goops-error "make-class: slot ~S is duplicate in class ~S" - tmp2 name))) - - ;; Everything seems correct, build the class - (apply make metaclass - #:dsupers supers - #:slots slots - #:name name - #:environment env - options)))) +(define-syntax define-class-pre-definition + (lambda (x) + (syntax-case x () + ((_ (k arg rest ...) out ...) + (keyword? (syntax-object->datum (syntax k))) + (case (syntax-object->datum (syntax k)) + ((#:getter #:setter) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))) + ((#:accessor) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))) + (else + (syntax + (define-class-pre-definition (rest ...) out ...))))) + ((_ () out ...) + (syntax (begin out ...)))))) + +;; Some slot options require extra definitions to be made. In +;; particular, we want to make sure that the generic function objects +;; which represent accessors exist before `make-class' tries to add +;; methods to them. +(define-syntax define-class-pre-definitions + (lambda (x) + (syntax-case x () + ((_ () out ...) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (keyword? (syntax-object->datum (syntax slot))) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (identifier? (syntax slot)) + (syntax (define-class-pre-definitions (rest ...) + out ...))) + ((_ ((slotname slotopt ...) rest ...) out ...) + (syntax (define-class-pre-definitions (rest ...) + out ... (define-class-pre-definition (slotopt ...)))))))) + +(define-syntax define-class + (syntax-rules () + ((_ name supers slot ...) + (begin + (define-class-pre-definitions (slot ...)) + (if (and (defined? 'name) + (is-a? name ) + (memq (class-precedence-list name))) + (class-redefinition name + (class supers slot ... #:name 'name)) + (toplevel-define! 'name (class supers slot ... #:name 'name))))))) + +(define-syntax standard-define-class + (syntax-rules () + ((_ arg ...) (define-class arg ...)))) ;;; ;;; {Generic functions and accessors} @@ -1035,11 +1061,14 @@ ;; the idea is to compile the index into the procedure, for fastest ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. +;; separate expression so that we affect the expansion of the subsequent +;; expression (eval-when (compile) (use-modules ((language scheme compile-ghil) :select (define-scheme-translator)) ((language ghil) :select (make-ghil-inline make-ghil-call)) - (system base pmatch)) + (system base pmatch))) +(eval-when (compile) ;; unfortunately, can't use define-inline because these are primitive ;; syntaxen. (define-scheme-translator @slot-ref diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm index 4d64da8bb..2aedd7698 100644 --- a/module/oop/goops/save.scm +++ b/module/oop/goops/save.scm @@ -110,9 +110,7 @@ ;;; Readables ;;; -(if (or (not (defined? 'readables)) - (not readables)) - (define readables (make-weak-key-hash-table 61))) +(define readables (make-weak-key-hash-table 61)) (define-macro (readable exp) `(make-readable ,exp ',(copy-tree exp))) diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm index 48e76f312..c0cb76fbb 100644 --- a/module/oop/goops/simple.scm +++ b/module/oop/goops/simple.scm @@ -23,6 +23,9 @@ :export (define-class) :no-backtrace) -(define define-class define-class-with-accessors-keywords) +(define-syntax define-class + (syntax-rules () + ((_ arg ...) + (define-class-with-accessors-keywords arg ...)))) (module-use! %module-public-interface (resolve-interface '(oop goops))) diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm index 60ab293c3..ef943cf96 100644 --- a/module/oop/goops/stklos.scm +++ b/module/oop/goops/stklos.scm @@ -47,51 +47,30 @@ ;;; Enable keyword support (*fixme*---currently this has global effect) (read-set! keywords 'prefix) -(define standard-define-class-transformer - (macro-transformer standard-define-class)) +(define-syntax define-class + (syntax-rules () + ((_ name supers (slot ...) rest ...) + (standard-define-class name supers slot ... rest ...)))) -(define define-class - ;; Syntax - (let ((name cadr) - (supers caddr) - (slots cadddr) - (rest cddddr)) - (procedure->memoizing-macro - (lambda (exp env) - (standard-define-class-transformer - `(define-class ,(name exp) ,(supers exp) ,@(slots exp) - ,@(rest exp)) - env))))) +(define (toplevel-define! name val) + (module-define! (current-module) name val)) -(define define-method - (procedure->memoizing-macro - (lambda (exp env) - (let ((name (cadr exp))) - (if (and (pair? name) - (eq? (car name) 'setter) - (pair? (cdr name)) - (null? (cddr name))) - (let ((name (cadr name))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - (if (not (is-a? ,name )) - (define-accessor ,name)) - (add-method! (setter ,name) (method ,@(cddr exp))))) - (else - `(begin - (define-accessor ,name) - (add-method! (setter ,name) (method ,@(cddr exp))))))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - (if (not (or (is-a? ,name ) - (is-a? ,name ))) - (define-generic ,name)) - (add-method! ,name (method ,@(cddr exp))))) - (else - `(begin - (define-generic ,name) - (add-method! ,name (method ,@(cddr exp))))))))))) +(define-syntax define-method + (syntax-rules (setter) + ((_ (setter name) rest ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name ))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method rest ...)))) + ((_ name rest ...) + (begin + (if (or (not (defined? 'name)) + (not (or (is-a? name ) + (is-a? name )))) + (toplevel-define! 'name + (ensure-generic + (if (defined? 'name) name #f) 'name))) + (add-method! name (method rest ...)))))) -- cgit v1.2.3 From 165a7596ee62a2871de8569e3d41ef7f7c925594 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 26 Apr 2009 13:10:30 +0200 Subject: add module-{define-keyword!,undefine-keyword!,lookup-keyword} * libguile/modules.c (scm_module_local_variable): Allow this to be called before modules are booted with #f as the module. * module/ice-9/boot-9.scm (module-define-keyword!) (module-lookup-keyword, module-undefine-keyword!): Well, if syncase forces us to allow the keyword bindings to be partitioned from value bindings, let's go ahead and do that in boot-9 instead of in psyntax. A step on the way to removing `install-global-transformer'. (sc-chi): Remove. * module/ice-9/psyntax.scm (put-global-definition-hook): (remove-global-definition-hook, get-global-definition-hook): Use our new module-* functions. (sc-chi): Remove, no longer needed. * module/ice-9/psyntax-pp.scm: Regenerated. --- libguile/modules.c | 4 ++-- module/ice-9/boot-9.scm | 25 ++++++++++++++++++++++++- module/ice-9/psyntax-pp.scm | 22 +++++++++++----------- module/ice-9/psyntax.scm | 30 +++++++----------------------- 4 files changed, 44 insertions(+), 37 deletions(-) (limited to 'libguile') diff --git a/libguile/modules.c b/libguile/modules.c index 2cb8a7620..689510ce6 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -412,13 +412,13 @@ SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0, register SCM b; - /* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being - evaluated. */ if (scm_module_system_booted_p) SCM_VALIDATE_MODULE (1, module); SCM_VALIDATE_SYMBOL (2, sym); + if (scm_is_false (module)) + return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED); /* 1. Check module obarray */ b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5becaa8a3..356a2416d 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -156,9 +156,32 @@ (define (resolve-module . args) #f) +;;; Here we use "keyword" in the sense that R6RS uses it, as in "a +;;; definition may be a keyword definition or a variable definition". +;;; Keywords are syntactic bindings; variables are value bindings. +(define (module-define-keyword! mod sym type val) + (let ((v (or (module-local-variable mod sym) + (let ((v (make-variable val))) + (module-add! mod sym v) + v)))) + (if (or (not (variable-bound? v)) + (not (macro? (variable-ref v)))) + (variable-set! v val)) + (set-object-property! v '*sc-expander* (cons type val)))) + +(define (module-lookup-keyword mod sym) + (let ((v (module-variable mod sym))) + (and v (object-property v '*sc-expander*)))) + +(define (module-undefine-keyword! mod sym) + (let ((v (module-local-variable mod sym))) + (if v + (let ((p (assq '*sc-expander* (object-properties v)))) + ;; probably should unbind the variable too + (set-object-properties! v (delq p (object-properties v))))))) + (define sc-expand #f) (define sc-expand3 #f) -(define sc-chi #f) (define install-global-transformer #f) (define syntax-dispatch #f) (define syntax-error #f) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 37b02c455..09e35e360 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1165 (lambda (vars1370) (let lvl1371 ((vars1372 vars1370) (ls1373 (quote ())) (w1374 (quote (())))) (cond ((pair? vars1372) (lvl1371 (cdr vars1372) (cons (wrap1144 (car vars1372) w1374 #f) ls1373) w1374)) ((id?1116 vars1372) (cons (wrap1144 vars1372 w1374 #f) ls1373)) ((null? vars1372) ls1373) ((syntax-object?1100 vars1372) (lvl1371 (syntax-object-expression1101 vars1372) ls1373 (join-wraps1135 w1374 (syntax-object-wrap1102 vars1372)))) ((annotation? vars1372) (lvl1371 (annotation-expression vars1372) ls1373 w1374)) (else (cons vars1372 ls1373)))))) (gen-var1164 (lambda (id1375) (let ((id1376 (if (syntax-object?1100 id1375) (syntax-object-expression1101 id1375) id1375))) (if (annotation? id1376) (build-annotated1093 (annotation-source id1376) (gensym (symbol->string (annotation-expression id1376)))) (build-annotated1093 #f (gensym (symbol->string id1376))))))) (strip1163 (lambda (x1377 w1378) (if (memq (quote top) (wrap-marks1119 w1378)) (if (or (annotation? x1377) (and (pair? x1377) (annotation? (car x1377)))) (strip-annotation1162 x1377 #f) x1377) (let f1379 ((x1380 x1377)) (cond ((syntax-object?1100 x1380) (strip1163 (syntax-object-expression1101 x1380) (syntax-object-wrap1102 x1380))) ((pair? x1380) (let ((a1381 (f1379 (car x1380))) (d1382 (f1379 (cdr x1380)))) (if (and (eq? a1381 (car x1380)) (eq? d1382 (cdr x1380))) x1380 (cons a1381 d1382)))) ((vector? x1380) (let ((old1383 (vector->list x1380))) (let ((new1384 (map f1379 old1383))) (if (andmap eq? old1383 new1384) x1380 (list->vector new1384))))) (else x1380)))))) (strip-annotation1162 (lambda (x1385 parent1386) (cond ((pair? x1385) (let ((new1387 (cons #f #f))) (begin (if parent1386 (set-annotation-stripped! parent1386 new1387)) (set-car! new1387 (strip-annotation1162 (car x1385) #f)) (set-cdr! new1387 (strip-annotation1162 (cdr x1385) #f)) new1387))) ((annotation? x1385) (or (annotation-stripped x1385) (strip-annotation1162 (annotation-expression x1385) x1385))) ((vector? x1385) (let ((new1388 (make-vector (vector-length x1385)))) (begin (if parent1386 (set-annotation-stripped! parent1386 new1388)) (let loop1389 ((i1390 (- (vector-length x1385) 1))) (unless (fx<1086 i1390 0) (vector-set! new1388 i1390 (strip-annotation1162 (vector-ref x1385 i1390) #f)) (loop1389 (fx-1084 i1390 1)))) new1388))) (else x1385)))) (ellipsis?1161 (lambda (x1391) (and (nonsymbol-id?1115 x1391) (free-id=?1139 x1391 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1160 (lambda () (build-annotated1093 #f (list (build-annotated1093 #f (quote void)))))) (eval-local-transformer1159 (lambda (expanded1392 mod1393) (let ((p1394 (local-eval-hook1088 expanded1392 mod1393))) (if (procedure? p1394) p1394 (syntax-error p1394 "nonprocedure transformer"))))) (chi-local-syntax1158 (lambda (rec?1395 e1396 r1397 w1398 s1399 mod1400 k1401) ((lambda (tmp1402) ((lambda (tmp1403) (if tmp1403 (apply (lambda (_1404 id1405 val1406 e11407 e21408) (let ((ids1409 id1405)) (if (not (valid-bound-ids?1141 ids1409)) (syntax-error e1396 "duplicate bound keyword in") (let ((labels1411 (gen-labels1122 ids1409))) (let ((new-w1412 (make-binding-wrap1133 ids1409 labels1411 w1398))) (k1401 (cons e11407 e21408) (extend-env1110 labels1411 (let ((w1414 (if rec?1395 new-w1412 w1398)) (trans-r1415 (macros-only-env1112 r1397))) (map (lambda (x1416) (cons (quote macro) (eval-local-transformer1159 (chi1152 x1416 trans-r1415 w1414 mod1400) mod1400))) val1406)) r1397) new-w1412 s1399 mod1400)))))) tmp1403) ((lambda (_1418) (syntax-error (source-wrap1145 e1396 w1398 s1399 mod1400))) tmp1402))) (syntax-dispatch tmp1402 (quote (any #(each (any any)) any . each-any))))) e1396))) (chi-lambda-clause1157 (lambda (e1419 docstring1420 c1421 r1422 w1423 mod1424 k1425) ((lambda (tmp1426) ((lambda (tmp1427) (if (if tmp1427 (apply (lambda (args1428 doc1429 e11430 e21431) (and (string? (syntax-object->datum doc1429)) (not docstring1420))) tmp1427) #f) (apply (lambda (args1432 doc1433 e11434 e21435) (chi-lambda-clause1157 e1419 doc1433 (cons args1432 (cons e11434 e21435)) r1422 w1423 mod1424 k1425)) tmp1427) ((lambda (tmp1437) (if tmp1437 (apply (lambda (id1438 e11439 e21440) (let ((ids1441 id1438)) (if (not (valid-bound-ids?1141 ids1441)) (syntax-error e1419 "invalid parameter list in") (let ((labels1443 (gen-labels1122 ids1441)) (new-vars1444 (map gen-var1164 ids1441))) (k1425 new-vars1444 docstring1420 (chi-body1156 (cons e11439 e21440) e1419 (extend-var-env1111 labels1443 new-vars1444 r1422) (make-binding-wrap1133 ids1441 labels1443 w1423) mod1424)))))) tmp1437) ((lambda (tmp1446) (if tmp1446 (apply (lambda (ids1447 e11448 e21449) (let ((old-ids1450 (lambda-var-list1165 ids1447))) (if (not (valid-bound-ids?1141 old-ids1450)) (syntax-error e1419 "invalid parameter list in") (let ((labels1451 (gen-labels1122 old-ids1450)) (new-vars1452 (map gen-var1164 old-ids1450))) (k1425 (let f1453 ((ls11454 (cdr new-vars1452)) (ls21455 (car new-vars1452))) (if (null? ls11454) ls21455 (f1453 (cdr ls11454) (cons (car ls11454) ls21455)))) docstring1420 (chi-body1156 (cons e11448 e21449) e1419 (extend-var-env1111 labels1451 new-vars1452 r1422) (make-binding-wrap1133 old-ids1450 labels1451 w1423) mod1424)))))) tmp1446) ((lambda (_1457) (syntax-error e1419)) tmp1426))) (syntax-dispatch tmp1426 (quote (any any . each-any)))))) (syntax-dispatch tmp1426 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1426 (quote (any any any . each-any))))) c1421))) (chi-body1156 (lambda (body1458 outer-form1459 r1460 w1461 mod1462) (let ((r1463 (cons (quote ("placeholder" placeholder)) r1460))) (let ((ribcage1464 (make-ribcage1123 (quote ()) (quote ()) (quote ())))) (let ((w1465 (make-wrap1118 (wrap-marks1119 w1461) (cons ribcage1464 (wrap-subst1120 w1461))))) (let parse1466 ((body1467 (map (lambda (x1473) (cons r1463 (wrap1144 x1473 w1465 mod1462))) body1458)) (ids1468 (quote ())) (labels1469 (quote ())) (vars1470 (quote ())) (vals1471 (quote ())) (bindings1472 (quote ()))) (if (null? body1467) (syntax-error outer-form1459 "no expressions in body") (let ((e1474 (cdar body1467)) (er1475 (caar body1467))) (call-with-values (lambda () (syntax-type1150 e1474 er1475 (quote (())) #f ribcage1464 mod1462)) (lambda (type1476 value1477 e1478 w1479 s1480 mod1481) (let ((t1482 type1476)) (if (memv t1482 (quote (define-form))) (let ((id1483 (wrap1144 value1477 w1479 mod1481)) (label1484 (gen-label1121))) (let ((var1485 (gen-var1164 id1483))) (begin (extend-ribcage!1132 ribcage1464 id1483 label1484) (parse1466 (cdr body1467) (cons id1483 ids1468) (cons label1484 labels1469) (cons var1485 vars1470) (cons (cons er1475 (wrap1144 e1478 w1479 mod1481)) vals1471) (cons (cons (quote lexical) var1485) bindings1472))))) (if (memv t1482 (quote (define-syntax-form))) (let ((id1486 (wrap1144 value1477 w1479 mod1481)) (label1487 (gen-label1121))) (begin (extend-ribcage!1132 ribcage1464 id1486 label1487) (parse1466 (cdr body1467) (cons id1486 ids1468) (cons label1487 labels1469) vars1470 vals1471 (cons (cons (quote macro) (cons er1475 (wrap1144 e1478 w1479 mod1481))) bindings1472)))) (if (memv t1482 (quote (begin-form))) ((lambda (tmp1488) ((lambda (tmp1489) (if tmp1489 (apply (lambda (_1490 e11491) (parse1466 (let f1492 ((forms1493 e11491)) (if (null? forms1493) (cdr body1467) (cons (cons er1475 (wrap1144 (car forms1493) w1479 mod1481)) (f1492 (cdr forms1493))))) ids1468 labels1469 vars1470 vals1471 bindings1472)) tmp1489) (syntax-error tmp1488))) (syntax-dispatch tmp1488 (quote (any . each-any))))) e1478) (if (memv t1482 (quote (local-syntax-form))) (chi-local-syntax1158 value1477 e1478 er1475 w1479 s1480 mod1481 (lambda (forms1495 er1496 w1497 s1498 mod1499) (parse1466 (let f1500 ((forms1501 forms1495)) (if (null? forms1501) (cdr body1467) (cons (cons er1496 (wrap1144 (car forms1501) w1497 mod1499)) (f1500 (cdr forms1501))))) ids1468 labels1469 vars1470 vals1471 bindings1472))) (if (null? ids1468) (build-sequence1095 #f (map (lambda (x1502) (chi1152 (cdr x1502) (car x1502) (quote (())) mod1481)) (cons (cons er1475 (source-wrap1145 e1478 w1479 s1480 mod1481)) (cdr body1467)))) (begin (if (not (valid-bound-ids?1141 ids1468)) (syntax-error outer-form1459 "invalid or duplicate identifier in definition")) (let loop1503 ((bs1504 bindings1472) (er-cache1505 #f) (r-cache1506 #f)) (if (not (null? bs1504)) (let ((b1507 (car bs1504))) (if (eq? (car b1507) (quote macro)) (let ((er1508 (cadr b1507))) (let ((r-cache1509 (if (eq? er1508 er-cache1505) r-cache1506 (macros-only-env1112 er1508)))) (begin (set-cdr! b1507 (eval-local-transformer1159 (chi1152 (cddr b1507) r-cache1509 (quote (())) mod1481) mod1481)) (loop1503 (cdr bs1504) er1508 r-cache1509)))) (loop1503 (cdr bs1504) er-cache1505 r-cache1506))))) (set-cdr! r1463 (extend-env1110 labels1469 bindings1472 (cdr r1463))) (build-letrec1098 #f vars1470 (map (lambda (x1510) (chi1152 (cdr x1510) (car x1510) (quote (())) mod1481)) vals1471) (build-sequence1095 #f (map (lambda (x1511) (chi1152 (cdr x1511) (car x1511) (quote (())) mod1481)) (cons (cons er1475 (source-wrap1145 e1478 w1479 s1480 mod1481)) (cdr body1467)))))))))))))))))))))) (chi-macro1155 (lambda (p1512 e1513 r1514 w1515 rib1516 mod1517) (letrec ((rebuild-macro-output1518 (lambda (x1519 m1520) (cond ((pair? x1519) (cons (rebuild-macro-output1518 (car x1519) m1520) (rebuild-macro-output1518 (cdr x1519) m1520))) ((syntax-object?1100 x1519) (let ((w1521 (syntax-object-wrap1102 x1519))) (let ((ms1522 (wrap-marks1119 w1521)) (s1523 (wrap-subst1120 w1521))) (if (and (pair? ms1522) (eq? (car ms1522) #f)) (make-syntax-object1099 (syntax-object-expression1101 x1519) (make-wrap1118 (cdr ms1522) (if rib1516 (cons rib1516 (cdr s1523)) (cdr s1523))) (syntax-object-module1103 x1519)) (make-syntax-object1099 (syntax-object-expression1101 x1519) (make-wrap1118 (cons m1520 ms1522) (if rib1516 (cons rib1516 (cons (quote shift) s1523)) (cons (quote shift) s1523))) (let ((pmod1524 (procedure-module p1512))) (if pmod1524 (cons (quote hygiene) (module-name pmod1524)) (quote (hygiene guile))))))))) ((vector? x1519) (let ((n1525 (vector-length x1519))) (let ((v1526 (make-vector n1525))) (let doloop1527 ((i1528 0)) (if (fx=1085 i1528 n1525) v1526 (begin (vector-set! v1526 i1528 (rebuild-macro-output1518 (vector-ref x1519 i1528) m1520)) (doloop1527 (fx+1083 i1528 1)))))))) ((symbol? x1519) (syntax-error x1519 "encountered raw symbol in macro output")) (else x1519))))) (rebuild-macro-output1518 (p1512 (wrap1144 e1513 (anti-mark1131 w1515) mod1517)) (string #\m))))) (chi-application1154 (lambda (x1529 e1530 r1531 w1532 s1533 mod1534) ((lambda (tmp1535) ((lambda (tmp1536) (if tmp1536 (apply (lambda (e01537 e11538) (build-annotated1093 s1533 (cons x1529 (map (lambda (e1539) (chi1152 e1539 r1531 w1532 mod1534)) e11538)))) tmp1536) (syntax-error tmp1535))) (syntax-dispatch tmp1535 (quote (any . each-any))))) e1530))) (chi-expr1153 (lambda (type1541 value1542 e1543 r1544 w1545 s1546 mod1547) (let ((t1548 type1541)) (if (memv t1548 (quote (lexical))) (build-annotated1093 s1546 value1542) (if (memv t1548 (quote (core external-macro))) (value1542 e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (module-ref))) (call-with-values (lambda () (value1542 e1543)) (lambda (id1549 mod1550) (build-annotated1093 s1546 (if mod1550 (make-module-ref (cdr mod1550) id1549 (car mod1550)) (make-module-ref mod1550 id1549 (quote bare)))))) (if (memv t1548 (quote (lexical-call))) (chi-application1154 (build-annotated1093 (source-annotation1107 (car e1543)) value1542) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (global-call))) (chi-application1154 (build-annotated1093 (source-annotation1107 (car e1543)) (if (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547) (make-module-ref (cdr (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547)) value1542 (car (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547))) (make-module-ref (if (syntax-object?1100 (car e1543)) (syntax-object-module1103 (car e1543)) mod1547) value1542 (quote bare)))) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (constant))) (build-data1094 s1546 (strip1163 (source-wrap1145 e1543 w1545 s1546 mod1547) (quote (())))) (if (memv t1548 (quote (global))) (build-annotated1093 s1546 (if mod1547 (make-module-ref (cdr mod1547) value1542 (car mod1547)) (make-module-ref mod1547 value1542 (quote bare)))) (if (memv t1548 (quote (call))) (chi-application1154 (chi1152 (car e1543) r1544 w1545 mod1547) e1543 r1544 w1545 s1546 mod1547) (if (memv t1548 (quote (begin-form))) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda (_1553 e11554 e21555) (chi-sequence1146 (cons e11554 e21555) r1544 w1545 s1546 mod1547)) tmp1552) (syntax-error tmp1551))) (syntax-dispatch tmp1551 (quote (any any . each-any))))) e1543) (if (memv t1548 (quote (local-syntax-form))) (chi-local-syntax1158 value1542 e1543 r1544 w1545 s1546 mod1547 chi-sequence1146) (if (memv t1548 (quote (eval-when-form))) ((lambda (tmp1557) ((lambda (tmp1558) (if tmp1558 (apply (lambda (_1559 x1560 e11561 e21562) (let ((when-list1563 (chi-when-list1149 e1543 x1560 w1545))) (if (memq (quote eval) when-list1563) (chi-sequence1146 (cons e11561 e21562) r1544 w1545 s1546 mod1547) (chi-void1160)))) tmp1558) (syntax-error tmp1557))) (syntax-dispatch tmp1557 (quote (any each-any any . each-any))))) e1543) (if (memv t1548 (quote (define-form define-syntax-form))) (syntax-error (wrap1144 value1542 w1545 mod1547) "invalid context for definition of") (if (memv t1548 (quote (syntax))) (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547) "reference to pattern variable outside syntax form") (if (memv t1548 (quote (displaced-lexical))) (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547) "reference to identifier outside its scope") (syntax-error (source-wrap1145 e1543 w1545 s1546 mod1547))))))))))))))))))) (chi1152 (lambda (e1566 r1567 w1568 mod1569) (call-with-values (lambda () (syntax-type1150 e1566 r1567 w1568 #f #f mod1569)) (lambda (type1570 value1571 e1572 w1573 s1574 mod1575) (chi-expr1153 type1570 value1571 e1572 r1567 w1573 s1574 mod1575))))) (chi-top1151 (lambda (e1576 r1577 w1578 m1579 esew1580 mod1581) (call-with-values (lambda () (syntax-type1150 e1576 r1577 w1578 #f #f mod1581)) (lambda (type1589 value1590 e1591 w1592 s1593 mod1594) (let ((t1595 type1589)) (if (memv t1595 (quote (begin-form))) ((lambda (tmp1596) ((lambda (tmp1597) (if tmp1597 (apply (lambda (_1598) (chi-void1160)) tmp1597) ((lambda (tmp1599) (if tmp1599 (apply (lambda (_1600 e11601 e21602) (chi-top-sequence1147 (cons e11601 e21602) r1577 w1592 s1593 m1579 esew1580 mod1594)) tmp1599) (syntax-error tmp1596))) (syntax-dispatch tmp1596 (quote (any any . each-any)))))) (syntax-dispatch tmp1596 (quote (any))))) e1591) (if (memv t1595 (quote (local-syntax-form))) (chi-local-syntax1158 value1590 e1591 r1577 w1592 s1593 mod1594 (lambda (body1604 r1605 w1606 s1607 mod1608) (chi-top-sequence1147 body1604 r1605 w1606 s1607 m1579 esew1580 mod1608))) (if (memv t1595 (quote (eval-when-form))) ((lambda (tmp1609) ((lambda (tmp1610) (if tmp1610 (apply (lambda (_1611 x1612 e11613 e21614) (let ((when-list1615 (chi-when-list1149 e1591 x1612 w1592)) (body1616 (cons e11613 e21614))) (cond ((eq? m1579 (quote e)) (if (memq (quote eval) when-list1615) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote e) (quote (eval)) mod1594) (chi-void1160))) ((memq (quote load) when-list1615) (if (or (memq (quote compile) when-list1615) (and (eq? m1579 (quote c&e)) (memq (quote eval) when-list1615))) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote c&e) (quote (compile load)) mod1594) (if (memq m1579 (quote (c c&e))) (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote c) (quote (load)) mod1594) (chi-void1160)))) ((or (memq (quote compile) when-list1615) (and (eq? m1579 (quote c&e)) (memq (quote eval) when-list1615))) (top-level-eval-hook1087 (chi-top-sequence1147 body1616 r1577 w1592 s1593 (quote e) (quote (eval)) mod1594) mod1594) (chi-void1160)) (else (chi-void1160))))) tmp1610) (syntax-error tmp1609))) (syntax-dispatch tmp1609 (quote (any each-any any . each-any))))) e1591) (if (memv t1595 (quote (define-syntax-form))) (let ((n1619 (id-var-name1138 value1590 w1592)) (r1620 (macros-only-env1112 r1577))) (let ((t1621 m1579)) (if (memv t1621 (quote (c))) (if (memq (quote compile) esew1580) (let ((e1622 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)))) (begin (top-level-eval-hook1087 e1622 mod1594) (if (memq (quote load) esew1580) e1622 (chi-void1160)))) (if (memq (quote load) esew1580) (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)) (chi-void1160))) (if (memv t1621 (quote (c&e))) (let ((e1623 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)))) (begin (top-level-eval-hook1087 e1623 mod1594) e1623)) (begin (if (memq (quote eval) esew1580) (top-level-eval-hook1087 (chi-install-global1148 n1619 (chi1152 e1591 r1620 w1592 mod1594)) mod1594)) (chi-void1160)))))) (if (memv t1595 (quote (define-form))) (let ((n1624 (id-var-name1138 value1590 w1592))) (let ((type1625 (binding-type1108 (lookup1113 n1624 r1577 mod1594)))) (let ((t1626 type1625)) (if (memv t1626 (quote (global))) (let ((x1627 (build-annotated1093 s1593 (list (quote define) n1624 (chi1152 e1591 r1577 w1592 mod1594))))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1627 mod1594)) x1627)) (if (memv t1626 (quote (displaced-lexical))) (syntax-error (wrap1144 value1590 w1592 mod1594) "identifier out of context") (if (memv t1626 (quote (core macro module-ref))) (begin (remove-global-definition-hook1091 n1624) (let ((x1628 (build-annotated1093 s1593 (list (quote define) n1624 (chi1152 e1591 r1577 w1592 mod1594))))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1628 mod1594)) x1628))) (syntax-error (wrap1144 value1590 w1592 mod1594) "cannot define keyword at top level"))))))) (let ((x1629 (chi-expr1153 type1589 value1590 e1591 r1577 w1592 s1593 mod1594))) (begin (if (eq? m1579 (quote c&e)) (top-level-eval-hook1087 x1629 mod1594)) x1629)))))))))))) (syntax-type1150 (lambda (e1630 r1631 w1632 s1633 rib1634 mod1635) (cond ((symbol? e1630) (let ((n1636 (id-var-name1138 e1630 w1632))) (let ((b1637 (lookup1113 n1636 r1631 mod1635))) (let ((type1638 (binding-type1108 b1637))) (let ((t1639 type1638)) (if (memv t1639 (quote (lexical))) (values type1638 (binding-value1109 b1637) e1630 w1632 s1633 mod1635) (if (memv t1639 (quote (global))) (values type1638 n1636 e1630 w1632 s1633 mod1635) (if (memv t1639 (quote (macro))) (syntax-type1150 (chi-macro1155 (binding-value1109 b1637) e1630 r1631 w1632 rib1634 mod1635) r1631 (quote (())) s1633 rib1634 mod1635) (values type1638 (binding-value1109 b1637) e1630 w1632 s1633 mod1635))))))))) ((pair? e1630) (let ((first1640 (car e1630))) (if (id?1116 first1640) (let ((n1641 (id-var-name1138 first1640 w1632))) (let ((b1642 (lookup1113 n1641 r1631 (or (and (syntax-object?1100 first1640) (syntax-object-module1103 first1640)) mod1635)))) (let ((type1643 (binding-type1108 b1642))) (let ((t1644 type1643)) (if (memv t1644 (quote (lexical))) (values (quote lexical-call) (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (global))) (values (quote global-call) n1641 e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (macro))) (syntax-type1150 (chi-macro1155 (binding-value1109 b1642) e1630 r1631 w1632 rib1634 mod1635) r1631 (quote (())) s1633 rib1634 mod1635) (if (memv t1644 (quote (core external-macro module-ref))) (values type1643 (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1109 b1642) e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (begin))) (values (quote begin-form) #f e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (eval-when))) (values (quote eval-when-form) #f e1630 w1632 s1633 mod1635) (if (memv t1644 (quote (define))) ((lambda (tmp1645) ((lambda (tmp1646) (if (if tmp1646 (apply (lambda (_1647 name1648 val1649) (id?1116 name1648)) tmp1646) #f) (apply (lambda (_1650 name1651 val1652) (values (quote define-form) name1651 val1652 w1632 s1633 mod1635)) tmp1646) ((lambda (tmp1653) (if (if tmp1653 (apply (lambda (_1654 name1655 args1656 e11657 e21658) (and (id?1116 name1655) (valid-bound-ids?1141 (lambda-var-list1165 args1656)))) tmp1653) #f) (apply (lambda (_1659 name1660 args1661 e11662 e21663) (values (quote define-form) (wrap1144 name1660 w1632 mod1635) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1144 (cons args1661 (cons e11662 e21663)) w1632 mod1635)) (quote (())) s1633 mod1635)) tmp1653) ((lambda (tmp1665) (if (if tmp1665 (apply (lambda (_1666 name1667) (id?1116 name1667)) tmp1665) #f) (apply (lambda (_1668 name1669) (values (quote define-form) (wrap1144 name1669 w1632 mod1635) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1633 mod1635)) tmp1665) (syntax-error tmp1645))) (syntax-dispatch tmp1645 (quote (any any)))))) (syntax-dispatch tmp1645 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1645 (quote (any any any))))) e1630) (if (memv t1644 (quote (define-syntax))) ((lambda (tmp1670) ((lambda (tmp1671) (if (if tmp1671 (apply (lambda (_1672 name1673 val1674) (id?1116 name1673)) tmp1671) #f) (apply (lambda (_1675 name1676 val1677) (values (quote define-syntax-form) name1676 val1677 w1632 s1633 mod1635)) tmp1671) (syntax-error tmp1670))) (syntax-dispatch tmp1670 (quote (any any any))))) e1630) (values (quote call) #f e1630 w1632 s1633 mod1635)))))))))))))) (values (quote call) #f e1630 w1632 s1633 mod1635)))) ((syntax-object?1100 e1630) (syntax-type1150 (syntax-object-expression1101 e1630) r1631 (join-wraps1135 w1632 (syntax-object-wrap1102 e1630)) #f rib1634 (or (syntax-object-module1103 e1630) mod1635))) ((annotation? e1630) (syntax-type1150 (annotation-expression e1630) r1631 w1632 (annotation-source e1630) rib1634 mod1635)) ((self-evaluating? e1630) (values (quote constant) #f e1630 w1632 s1633 mod1635)) (else (values (quote other) #f e1630 w1632 s1633 mod1635))))) (chi-when-list1149 (lambda (e1678 when-list1679 w1680) (let f1681 ((when-list1682 when-list1679) (situations1683 (quote ()))) (if (null? when-list1682) situations1683 (f1681 (cdr when-list1682) (cons (let ((x1684 (car when-list1682))) (cond ((free-id=?1139 x1684 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1139 x1684 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1139 x1684 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1144 x1684 w1680 #f) "invalid eval-when situation")))) situations1683)))))) (chi-install-global1148 (lambda (name1685 e1686) (build-annotated1093 #f (list (build-annotated1093 #f (quote install-global-transformer)) (build-data1094 #f name1685) e1686)))) (chi-top-sequence1147 (lambda (body1687 r1688 w1689 s1690 m1691 esew1692 mod1693) (build-sequence1095 s1690 (let dobody1694 ((body1695 body1687) (r1696 r1688) (w1697 w1689) (m1698 m1691) (esew1699 esew1692) (mod1700 mod1693)) (if (null? body1695) (quote ()) (let ((first1701 (chi-top1151 (car body1695) r1696 w1697 m1698 esew1699 mod1700))) (cons first1701 (dobody1694 (cdr body1695) r1696 w1697 m1698 esew1699 mod1700)))))))) (chi-sequence1146 (lambda (body1702 r1703 w1704 s1705 mod1706) (build-sequence1095 s1705 (let dobody1707 ((body1708 body1702) (r1709 r1703) (w1710 w1704) (mod1711 mod1706)) (if (null? body1708) (quote ()) (let ((first1712 (chi1152 (car body1708) r1709 w1710 mod1711))) (cons first1712 (dobody1707 (cdr body1708) r1709 w1710 mod1711)))))))) (source-wrap1145 (lambda (x1713 w1714 s1715 defmod1716) (wrap1144 (if s1715 (make-annotation x1713 s1715 #f) x1713) w1714 defmod1716))) (wrap1144 (lambda (x1717 w1718 defmod1719) (cond ((and (null? (wrap-marks1119 w1718)) (null? (wrap-subst1120 w1718))) x1717) ((syntax-object?1100 x1717) (make-syntax-object1099 (syntax-object-expression1101 x1717) (join-wraps1135 w1718 (syntax-object-wrap1102 x1717)) (syntax-object-module1103 x1717))) ((null? x1717) x1717) (else (make-syntax-object1099 x1717 w1718 defmod1719))))) (bound-id-member?1143 (lambda (x1720 list1721) (and (not (null? list1721)) (or (bound-id=?1140 x1720 (car list1721)) (bound-id-member?1143 x1720 (cdr list1721)))))) (distinct-bound-ids?1142 (lambda (ids1722) (let distinct?1723 ((ids1724 ids1722)) (or (null? ids1724) (and (not (bound-id-member?1143 (car ids1724) (cdr ids1724))) (distinct?1723 (cdr ids1724))))))) (valid-bound-ids?1141 (lambda (ids1725) (and (let all-ids?1726 ((ids1727 ids1725)) (or (null? ids1727) (and (id?1116 (car ids1727)) (all-ids?1726 (cdr ids1727))))) (distinct-bound-ids?1142 ids1725)))) (bound-id=?1140 (lambda (i1728 j1729) (if (and (syntax-object?1100 i1728) (syntax-object?1100 j1729)) (and (eq? (let ((e1730 (syntax-object-expression1101 i1728))) (if (annotation? e1730) (annotation-expression e1730) e1730)) (let ((e1731 (syntax-object-expression1101 j1729))) (if (annotation? e1731) (annotation-expression e1731) e1731))) (same-marks?1137 (wrap-marks1119 (syntax-object-wrap1102 i1728)) (wrap-marks1119 (syntax-object-wrap1102 j1729)))) (eq? (let ((e1732 i1728)) (if (annotation? e1732) (annotation-expression e1732) e1732)) (let ((e1733 j1729)) (if (annotation? e1733) (annotation-expression e1733) e1733)))))) (free-id=?1139 (lambda (i1734 j1735) (and (eq? (let ((x1736 i1734)) (let ((e1737 (if (syntax-object?1100 x1736) (syntax-object-expression1101 x1736) x1736))) (if (annotation? e1737) (annotation-expression e1737) e1737))) (let ((x1738 j1735)) (let ((e1739 (if (syntax-object?1100 x1738) (syntax-object-expression1101 x1738) x1738))) (if (annotation? e1739) (annotation-expression e1739) e1739)))) (eq? (id-var-name1138 i1734 (quote (()))) (id-var-name1138 j1735 (quote (()))))))) (id-var-name1138 (lambda (id1740 w1741) (letrec ((search-vector-rib1744 (lambda (sym1750 subst1751 marks1752 symnames1753 ribcage1754) (let ((n1755 (vector-length symnames1753))) (let f1756 ((i1757 0)) (cond ((fx=1085 i1757 n1755) (search1742 sym1750 (cdr subst1751) marks1752)) ((and (eq? (vector-ref symnames1753 i1757) sym1750) (same-marks?1137 marks1752 (vector-ref (ribcage-marks1126 ribcage1754) i1757))) (values (vector-ref (ribcage-labels1127 ribcage1754) i1757) marks1752)) (else (f1756 (fx+1083 i1757 1)))))))) (search-list-rib1743 (lambda (sym1758 subst1759 marks1760 symnames1761 ribcage1762) (let f1763 ((symnames1764 symnames1761) (i1765 0)) (cond ((null? symnames1764) (search1742 sym1758 (cdr subst1759) marks1760)) ((and (eq? (car symnames1764) sym1758) (same-marks?1137 marks1760 (list-ref (ribcage-marks1126 ribcage1762) i1765))) (values (list-ref (ribcage-labels1127 ribcage1762) i1765) marks1760)) (else (f1763 (cdr symnames1764) (fx+1083 i1765 1))))))) (search1742 (lambda (sym1766 subst1767 marks1768) (if (null? subst1767) (values #f marks1768) (let ((fst1769 (car subst1767))) (if (eq? fst1769 (quote shift)) (search1742 sym1766 (cdr subst1767) (cdr marks1768)) (let ((symnames1770 (ribcage-symnames1125 fst1769))) (if (vector? symnames1770) (search-vector-rib1744 sym1766 subst1767 marks1768 symnames1770 fst1769) (search-list-rib1743 sym1766 subst1767 marks1768 symnames1770 fst1769))))))))) (cond ((symbol? id1740) (or (call-with-values (lambda () (search1742 id1740 (wrap-subst1120 w1741) (wrap-marks1119 w1741))) (lambda (x1772 . ignore1771) x1772)) id1740)) ((syntax-object?1100 id1740) (let ((id1773 (let ((e1775 (syntax-object-expression1101 id1740))) (if (annotation? e1775) (annotation-expression e1775) e1775))) (w11774 (syntax-object-wrap1102 id1740))) (let ((marks1776 (join-marks1136 (wrap-marks1119 w1741) (wrap-marks1119 w11774)))) (call-with-values (lambda () (search1742 id1773 (wrap-subst1120 w1741) marks1776)) (lambda (new-id1777 marks1778) (or new-id1777 (call-with-values (lambda () (search1742 id1773 (wrap-subst1120 w11774) marks1778)) (lambda (x1780 . ignore1779) x1780)) id1773)))))) ((annotation? id1740) (let ((id1781 (let ((e1782 id1740)) (if (annotation? e1782) (annotation-expression e1782) e1782)))) (or (call-with-values (lambda () (search1742 id1781 (wrap-subst1120 w1741) (wrap-marks1119 w1741))) (lambda (x1784 . ignore1783) x1784)) id1781))) (else (error-hook1089 (quote id-var-name) "invalid id" id1740)))))) (same-marks?1137 (lambda (x1785 y1786) (or (eq? x1785 y1786) (and (not (null? x1785)) (not (null? y1786)) (eq? (car x1785) (car y1786)) (same-marks?1137 (cdr x1785) (cdr y1786)))))) (join-marks1136 (lambda (m11787 m21788) (smart-append1134 m11787 m21788))) (join-wraps1135 (lambda (w11789 w21790) (let ((m11791 (wrap-marks1119 w11789)) (s11792 (wrap-subst1120 w11789))) (if (null? m11791) (if (null? s11792) w21790 (make-wrap1118 (wrap-marks1119 w21790) (smart-append1134 s11792 (wrap-subst1120 w21790)))) (make-wrap1118 (smart-append1134 m11791 (wrap-marks1119 w21790)) (smart-append1134 s11792 (wrap-subst1120 w21790))))))) (smart-append1134 (lambda (m11793 m21794) (if (null? m21794) m11793 (append m11793 m21794)))) (make-binding-wrap1133 (lambda (ids1795 labels1796 w1797) (if (null? ids1795) w1797 (make-wrap1118 (wrap-marks1119 w1797) (cons (let ((labelvec1798 (list->vector labels1796))) (let ((n1799 (vector-length labelvec1798))) (let ((symnamevec1800 (make-vector n1799)) (marksvec1801 (make-vector n1799))) (begin (let f1802 ((ids1803 ids1795) (i1804 0)) (if (not (null? ids1803)) (call-with-values (lambda () (id-sym-name&marks1117 (car ids1803) w1797)) (lambda (symname1805 marks1806) (begin (vector-set! symnamevec1800 i1804 symname1805) (vector-set! marksvec1801 i1804 marks1806) (f1802 (cdr ids1803) (fx+1083 i1804 1))))))) (make-ribcage1123 symnamevec1800 marksvec1801 labelvec1798))))) (wrap-subst1120 w1797)))))) (extend-ribcage!1132 (lambda (ribcage1807 id1808 label1809) (begin (set-ribcage-symnames!1128 ribcage1807 (cons (let ((e1810 (syntax-object-expression1101 id1808))) (if (annotation? e1810) (annotation-expression e1810) e1810)) (ribcage-symnames1125 ribcage1807))) (set-ribcage-marks!1129 ribcage1807 (cons (wrap-marks1119 (syntax-object-wrap1102 id1808)) (ribcage-marks1126 ribcage1807))) (set-ribcage-labels!1130 ribcage1807 (cons label1809 (ribcage-labels1127 ribcage1807)))))) (anti-mark1131 (lambda (w1811) (make-wrap1118 (cons #f (wrap-marks1119 w1811)) (cons (quote shift) (wrap-subst1120 w1811))))) (set-ribcage-labels!1130 (lambda (x1812 update1813) (vector-set! x1812 3 update1813))) (set-ribcage-marks!1129 (lambda (x1814 update1815) (vector-set! x1814 2 update1815))) (set-ribcage-symnames!1128 (lambda (x1816 update1817) (vector-set! x1816 1 update1817))) (ribcage-labels1127 (lambda (x1818) (vector-ref x1818 3))) (ribcage-marks1126 (lambda (x1819) (vector-ref x1819 2))) (ribcage-symnames1125 (lambda (x1820) (vector-ref x1820 1))) (ribcage?1124 (lambda (x1821) (and (vector? x1821) (= (vector-length x1821) 4) (eq? (vector-ref x1821 0) (quote ribcage))))) (make-ribcage1123 (lambda (symnames1822 marks1823 labels1824) (vector (quote ribcage) symnames1822 marks1823 labels1824))) (gen-labels1122 (lambda (ls1825) (if (null? ls1825) (quote ()) (cons (gen-label1121) (gen-labels1122 (cdr ls1825)))))) (gen-label1121 (lambda () (string #\i))) (wrap-subst1120 cdr) (wrap-marks1119 car) (make-wrap1118 cons) (id-sym-name&marks1117 (lambda (x1826 w1827) (if (syntax-object?1100 x1826) (values (let ((e1828 (syntax-object-expression1101 x1826))) (if (annotation? e1828) (annotation-expression e1828) e1828)) (join-marks1136 (wrap-marks1119 w1827) (wrap-marks1119 (syntax-object-wrap1102 x1826)))) (values (let ((e1829 x1826)) (if (annotation? e1829) (annotation-expression e1829) e1829)) (wrap-marks1119 w1827))))) (id?1116 (lambda (x1830) (cond ((symbol? x1830) #t) ((syntax-object?1100 x1830) (symbol? (let ((e1831 (syntax-object-expression1101 x1830))) (if (annotation? e1831) (annotation-expression e1831) e1831)))) ((annotation? x1830) (symbol? (annotation-expression x1830))) (else #f)))) (nonsymbol-id?1115 (lambda (x1832) (and (syntax-object?1100 x1832) (symbol? (let ((e1833 (syntax-object-expression1101 x1832))) (if (annotation? e1833) (annotation-expression e1833) e1833)))))) (global-extend1114 (lambda (type1834 sym1835 val1836) (put-global-definition-hook1090 sym1835 type1834 val1836))) (lookup1113 (lambda (x1837 r1838 mod1839) (cond ((assq x1837 r1838) => cdr) ((symbol? x1837) (or (get-global-definition-hook1092 x1837 mod1839) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1112 (lambda (r1840) (if (null? r1840) (quote ()) (let ((a1841 (car r1840))) (if (eq? (cadr a1841) (quote macro)) (cons a1841 (macros-only-env1112 (cdr r1840))) (macros-only-env1112 (cdr r1840))))))) (extend-var-env1111 (lambda (labels1842 vars1843 r1844) (if (null? labels1842) r1844 (extend-var-env1111 (cdr labels1842) (cdr vars1843) (cons (cons (car labels1842) (cons (quote lexical) (car vars1843))) r1844))))) (extend-env1110 (lambda (labels1845 bindings1846 r1847) (if (null? labels1845) r1847 (extend-env1110 (cdr labels1845) (cdr bindings1846) (cons (cons (car labels1845) (car bindings1846)) r1847))))) (binding-value1109 cdr) (binding-type1108 car) (source-annotation1107 (lambda (x1848) (cond ((annotation? x1848) (annotation-source x1848)) ((syntax-object?1100 x1848) (source-annotation1107 (syntax-object-expression1101 x1848))) (else #f)))) (set-syntax-object-module!1106 (lambda (x1849 update1850) (vector-set! x1849 3 update1850))) (set-syntax-object-wrap!1105 (lambda (x1851 update1852) (vector-set! x1851 2 update1852))) (set-syntax-object-expression!1104 (lambda (x1853 update1854) (vector-set! x1853 1 update1854))) (syntax-object-module1103 (lambda (x1855) (vector-ref x1855 3))) (syntax-object-wrap1102 (lambda (x1856) (vector-ref x1856 2))) (syntax-object-expression1101 (lambda (x1857) (vector-ref x1857 1))) (syntax-object?1100 (lambda (x1858) (and (vector? x1858) (= (vector-length x1858) 4) (eq? (vector-ref x1858 0) (quote syntax-object))))) (make-syntax-object1099 (lambda (expression1859 wrap1860 module1861) (vector (quote syntax-object) expression1859 wrap1860 module1861))) (build-letrec1098 (lambda (src1862 vars1863 val-exps1864 body-exp1865) (if (null? vars1863) (build-annotated1093 src1862 body-exp1865) (build-annotated1093 src1862 (list (quote letrec) (map list vars1863 val-exps1864) body-exp1865))))) (build-named-let1097 (lambda (src1866 vars1867 val-exps1868 body-exp1869) (if (null? vars1867) (build-annotated1093 src1866 body-exp1869) (build-annotated1093 src1866 (list (quote let) (car vars1867) (map list (cdr vars1867) val-exps1868) body-exp1869))))) (build-let1096 (lambda (src1870 vars1871 val-exps1872 body-exp1873) (if (null? vars1871) (build-annotated1093 src1870 body-exp1873) (build-annotated1093 src1870 (list (quote let) (map list vars1871 val-exps1872) body-exp1873))))) (build-sequence1095 (lambda (src1874 exps1875) (if (null? (cdr exps1875)) (build-annotated1093 src1874 (car exps1875)) (build-annotated1093 src1874 (cons (quote begin) exps1875))))) (build-data1094 (lambda (src1876 exp1877) (if (and (self-evaluating? exp1877) (not (vector? exp1877))) (build-annotated1093 src1876 exp1877) (build-annotated1093 src1876 (list (quote quote) exp1877))))) (build-annotated1093 (lambda (src1878 exp1879) (if (and src1878 (not (annotation? exp1879))) (make-annotation exp1879 src1878 #t) exp1879))) (get-global-definition-hook1092 (lambda (symbol1880 module1881) (let ((module1882 (if module1881 (resolve-module (cdr module1881)) (let ((mod1883 (current-module))) (begin (if mod1883 (warn "wha" symbol1880)) mod1883))))) (let ((v1884 (module-variable module1882 symbol1880))) (and v1884 (object-property v1884 (quote *sc-expander*))))))) (remove-global-definition-hook1091 (lambda (symbol1885) (let ((module1886 (current-module))) (let ((v1887 (module-local-variable module1886 symbol1885))) (if v1887 (let ((p1888 (assq (quote *sc-expander*) (object-properties v1887)))) (set-object-properties! v1887 (delq p1888 (object-properties v1887))))))))) (put-global-definition-hook1090 (lambda (symbol1889 type1890 val1891) (let ((module1892 (current-module))) (let ((v1893 (or (module-variable module1892 symbol1889) (let ((v1894 (make-variable val1891))) (begin (module-add! module1892 symbol1889 v1894) v1894))))) (begin (if (not (variable-bound? v1893)) (variable-set! v1893 val1891)) (set-object-property! v1893 (quote *sc-expander*) (cons type1890 val1891))))))) (error-hook1089 (lambda (who1895 why1896 what1897) (error who1895 "~a ~s" why1896 what1897))) (local-eval-hook1088 (lambda (x1898 mod1899) (primitive-eval (list noexpand1082 x1898)))) (top-level-eval-hook1087 (lambda (x1900 mod1901) (primitive-eval (list noexpand1082 x1900)))) (fx<1086 <) (fx=1085 =) (fx-1084 -) (fx+1083 +) (noexpand1082 "noexpand")) (begin (global-extend1114 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1114 (quote local-syntax) (quote let-syntax) #f) (global-extend1114 (quote core) (quote fluid-let-syntax) (lambda (e1902 r1903 w1904 s1905 mod1906) ((lambda (tmp1907) ((lambda (tmp1908) (if (if tmp1908 (apply (lambda (_1909 var1910 val1911 e11912 e21913) (valid-bound-ids?1141 var1910)) tmp1908) #f) (apply (lambda (_1915 var1916 val1917 e11918 e21919) (let ((names1920 (map (lambda (x1921) (id-var-name1138 x1921 w1904)) var1916))) (begin (for-each (lambda (id1923 n1924) (let ((t1925 (binding-type1108 (lookup1113 n1924 r1903 mod1906)))) (if (memv t1925 (quote (displaced-lexical))) (syntax-error (source-wrap1145 id1923 w1904 s1905 mod1906) "identifier out of context")))) var1916 names1920) (chi-body1156 (cons e11918 e21919) (source-wrap1145 e1902 w1904 s1905 mod1906) (extend-env1110 names1920 (let ((trans-r1928 (macros-only-env1112 r1903))) (map (lambda (x1929) (cons (quote macro) (eval-local-transformer1159 (chi1152 x1929 trans-r1928 w1904 mod1906) mod1906))) val1917)) r1903) w1904 mod1906)))) tmp1908) ((lambda (_1931) (syntax-error (source-wrap1145 e1902 w1904 s1905 mod1906))) tmp1907))) (syntax-dispatch tmp1907 (quote (any #(each (any any)) any . each-any))))) e1902))) (global-extend1114 (quote core) (quote quote) (lambda (e1932 r1933 w1934 s1935 mod1936) ((lambda (tmp1937) ((lambda (tmp1938) (if tmp1938 (apply (lambda (_1939 e1940) (build-data1094 s1935 (strip1163 e1940 w1934))) tmp1938) ((lambda (_1941) (syntax-error (source-wrap1145 e1932 w1934 s1935 mod1936))) tmp1937))) (syntax-dispatch tmp1937 (quote (any any))))) e1932))) (global-extend1114 (quote core) (quote syntax) (letrec ((regen1949 (lambda (x1950) (let ((t1951 (car x1950))) (if (memv t1951 (quote (ref))) (build-annotated1093 #f (cadr x1950)) (if (memv t1951 (quote (primitive))) (build-annotated1093 #f (cadr x1950)) (if (memv t1951 (quote (quote))) (build-data1094 #f (cadr x1950)) (if (memv t1951 (quote (lambda))) (build-annotated1093 #f (list (quote lambda) (cadr x1950) (regen1949 (caddr x1950)))) (if (memv t1951 (quote (map))) (let ((ls1952 (map regen1949 (cdr x1950)))) (build-annotated1093 #f (cons (if (fx=1085 (length ls1952) 2) (build-annotated1093 #f (quote map)) (build-annotated1093 #f (quote map))) ls1952))) (build-annotated1093 #f (cons (build-annotated1093 #f (car x1950)) (map regen1949 (cdr x1950)))))))))))) (gen-vector1948 (lambda (x1953) (cond ((eq? (car x1953) (quote list)) (cons (quote vector) (cdr x1953))) ((eq? (car x1953) (quote quote)) (list (quote quote) (list->vector (cadr x1953)))) (else (list (quote list->vector) x1953))))) (gen-append1947 (lambda (x1954 y1955) (if (equal? y1955 (quote (quote ()))) x1954 (list (quote append) x1954 y1955)))) (gen-cons1946 (lambda (x1956 y1957) (let ((t1958 (car y1957))) (if (memv t1958 (quote (quote))) (if (eq? (car x1956) (quote quote)) (list (quote quote) (cons (cadr x1956) (cadr y1957))) (if (eq? (cadr y1957) (quote ())) (list (quote list) x1956) (list (quote cons) x1956 y1957))) (if (memv t1958 (quote (list))) (cons (quote list) (cons x1956 (cdr y1957))) (list (quote cons) x1956 y1957)))))) (gen-map1945 (lambda (e1959 map-env1960) (let ((formals1961 (map cdr map-env1960)) (actuals1962 (map (lambda (x1963) (list (quote ref) (car x1963))) map-env1960))) (cond ((eq? (car e1959) (quote ref)) (car actuals1962)) ((andmap (lambda (x1964) (and (eq? (car x1964) (quote ref)) (memq (cadr x1964) formals1961))) (cdr e1959)) (cons (quote map) (cons (list (quote primitive) (car e1959)) (map (let ((r1965 (map cons formals1961 actuals1962))) (lambda (x1966) (cdr (assq (cadr x1966) r1965)))) (cdr e1959))))) (else (cons (quote map) (cons (list (quote lambda) formals1961 e1959) actuals1962))))))) (gen-mappend1944 (lambda (e1967 map-env1968) (list (quote apply) (quote (primitive append)) (gen-map1945 e1967 map-env1968)))) (gen-ref1943 (lambda (src1969 var1970 level1971 maps1972) (if (fx=1085 level1971 0) (values var1970 maps1972) (if (null? maps1972) (syntax-error src1969 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1943 src1969 var1970 (fx-1084 level1971 1) (cdr maps1972))) (lambda (outer-var1973 outer-maps1974) (let ((b1975 (assq outer-var1973 (car maps1972)))) (if b1975 (values (cdr b1975) maps1972) (let ((inner-var1976 (gen-var1164 (quote tmp)))) (values inner-var1976 (cons (cons (cons outer-var1973 inner-var1976) (car maps1972)) outer-maps1974))))))))))) (gen-syntax1942 (lambda (src1977 e1978 r1979 maps1980 ellipsis?1981 mod1982) (if (id?1116 e1978) (let ((label1983 (id-var-name1138 e1978 (quote (()))))) (let ((b1984 (lookup1113 label1983 r1979 mod1982))) (if (eq? (binding-type1108 b1984) (quote syntax)) (call-with-values (lambda () (let ((var.lev1985 (binding-value1109 b1984))) (gen-ref1943 src1977 (car var.lev1985) (cdr var.lev1985) maps1980))) (lambda (var1986 maps1987) (values (list (quote ref) var1986) maps1987))) (if (ellipsis?1981 e1978) (syntax-error src1977 "misplaced ellipsis in syntax form") (values (list (quote quote) e1978) maps1980))))) ((lambda (tmp1988) ((lambda (tmp1989) (if (if tmp1989 (apply (lambda (dots1990 e1991) (ellipsis?1981 dots1990)) tmp1989) #f) (apply (lambda (dots1992 e1993) (gen-syntax1942 src1977 e1993 r1979 maps1980 (lambda (x1994) #f) mod1982)) tmp1989) ((lambda (tmp1995) (if (if tmp1995 (apply (lambda (x1996 dots1997 y1998) (ellipsis?1981 dots1997)) tmp1995) #f) (apply (lambda (x1999 dots2000 y2001) (let f2002 ((y2003 y2001) (k2004 (lambda (maps2005) (call-with-values (lambda () (gen-syntax1942 src1977 x1999 r1979 (cons (quote ()) maps2005) ellipsis?1981 mod1982)) (lambda (x2006 maps2007) (if (null? (car maps2007)) (syntax-error src1977 "extra ellipsis in syntax form") (values (gen-map1945 x2006 (car maps2007)) (cdr maps2007)))))))) ((lambda (tmp2008) ((lambda (tmp2009) (if (if tmp2009 (apply (lambda (dots2010 y2011) (ellipsis?1981 dots2010)) tmp2009) #f) (apply (lambda (dots2012 y2013) (f2002 y2013 (lambda (maps2014) (call-with-values (lambda () (k2004 (cons (quote ()) maps2014))) (lambda (x2015 maps2016) (if (null? (car maps2016)) (syntax-error src1977 "extra ellipsis in syntax form") (values (gen-mappend1944 x2015 (car maps2016)) (cdr maps2016)))))))) tmp2009) ((lambda (_2017) (call-with-values (lambda () (gen-syntax1942 src1977 y2003 r1979 maps1980 ellipsis?1981 mod1982)) (lambda (y2018 maps2019) (call-with-values (lambda () (k2004 maps2019)) (lambda (x2020 maps2021) (values (gen-append1947 x2020 y2018) maps2021)))))) tmp2008))) (syntax-dispatch tmp2008 (quote (any . any))))) y2003))) tmp1995) ((lambda (tmp2022) (if tmp2022 (apply (lambda (x2023 y2024) (call-with-values (lambda () (gen-syntax1942 src1977 x2023 r1979 maps1980 ellipsis?1981 mod1982)) (lambda (x2025 maps2026) (call-with-values (lambda () (gen-syntax1942 src1977 y2024 r1979 maps2026 ellipsis?1981 mod1982)) (lambda (y2027 maps2028) (values (gen-cons1946 x2025 y2027) maps2028)))))) tmp2022) ((lambda (tmp2029) (if tmp2029 (apply (lambda (e12030 e22031) (call-with-values (lambda () (gen-syntax1942 src1977 (cons e12030 e22031) r1979 maps1980 ellipsis?1981 mod1982)) (lambda (e2033 maps2034) (values (gen-vector1948 e2033) maps2034)))) tmp2029) ((lambda (_2035) (values (list (quote quote) e1978) maps1980)) tmp1988))) (syntax-dispatch tmp1988 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1988 (quote (any . any)))))) (syntax-dispatch tmp1988 (quote (any any . any)))))) (syntax-dispatch tmp1988 (quote (any any))))) e1978))))) (lambda (e2036 r2037 w2038 s2039 mod2040) (let ((e2041 (source-wrap1145 e2036 w2038 s2039 mod2040))) ((lambda (tmp2042) ((lambda (tmp2043) (if tmp2043 (apply (lambda (_2044 x2045) (call-with-values (lambda () (gen-syntax1942 e2041 x2045 r2037 (quote ()) ellipsis?1161 mod2040)) (lambda (e2046 maps2047) (regen1949 e2046)))) tmp2043) ((lambda (_2048) (syntax-error e2041)) tmp2042))) (syntax-dispatch tmp2042 (quote (any any))))) e2041))))) (global-extend1114 (quote core) (quote lambda) (lambda (e2049 r2050 w2051 s2052 mod2053) ((lambda (tmp2054) ((lambda (tmp2055) (if tmp2055 (apply (lambda (_2056 c2057) (chi-lambda-clause1157 (source-wrap1145 e2049 w2051 s2052 mod2053) #f c2057 r2050 w2051 mod2053 (lambda (vars2058 docstring2059 body2060) (build-annotated1093 s2052 (cons (quote lambda) (cons vars2058 (append (if docstring2059 (list docstring2059) (quote ())) (list body2060)))))))) tmp2055) (syntax-error tmp2054))) (syntax-dispatch tmp2054 (quote (any . any))))) e2049))) (global-extend1114 (quote core) (quote let) (letrec ((chi-let2061 (lambda (e2062 r2063 w2064 s2065 mod2066 constructor2067 ids2068 vals2069 exps2070) (if (not (valid-bound-ids?1141 ids2068)) (syntax-error e2062 "duplicate bound variable in") (let ((labels2071 (gen-labels1122 ids2068)) (new-vars2072 (map gen-var1164 ids2068))) (let ((nw2073 (make-binding-wrap1133 ids2068 labels2071 w2064)) (nr2074 (extend-var-env1111 labels2071 new-vars2072 r2063))) (constructor2067 s2065 new-vars2072 (map (lambda (x2075) (chi1152 x2075 r2063 w2064 mod2066)) vals2069) (chi-body1156 exps2070 (source-wrap1145 e2062 nw2073 s2065 mod2066) nr2074 nw2073 mod2066)))))))) (lambda (e2076 r2077 w2078 s2079 mod2080) ((lambda (tmp2081) ((lambda (tmp2082) (if tmp2082 (apply (lambda (_2083 id2084 val2085 e12086 e22087) (chi-let2061 e2076 r2077 w2078 s2079 mod2080 build-let1096 id2084 val2085 (cons e12086 e22087))) tmp2082) ((lambda (tmp2091) (if (if tmp2091 (apply (lambda (_2092 f2093 id2094 val2095 e12096 e22097) (id?1116 f2093)) tmp2091) #f) (apply (lambda (_2098 f2099 id2100 val2101 e12102 e22103) (chi-let2061 e2076 r2077 w2078 s2079 mod2080 build-named-let1097 (cons f2099 id2100) val2101 (cons e12102 e22103))) tmp2091) ((lambda (_2107) (syntax-error (source-wrap1145 e2076 w2078 s2079 mod2080))) tmp2081))) (syntax-dispatch tmp2081 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2081 (quote (any #(each (any any)) any . each-any))))) e2076)))) (global-extend1114 (quote core) (quote letrec) (lambda (e2108 r2109 w2110 s2111 mod2112) ((lambda (tmp2113) ((lambda (tmp2114) (if tmp2114 (apply (lambda (_2115 id2116 val2117 e12118 e22119) (let ((ids2120 id2116)) (if (not (valid-bound-ids?1141 ids2120)) (syntax-error e2108 "duplicate bound variable in") (let ((labels2122 (gen-labels1122 ids2120)) (new-vars2123 (map gen-var1164 ids2120))) (let ((w2124 (make-binding-wrap1133 ids2120 labels2122 w2110)) (r2125 (extend-var-env1111 labels2122 new-vars2123 r2109))) (build-letrec1098 s2111 new-vars2123 (map (lambda (x2126) (chi1152 x2126 r2125 w2124 mod2112)) val2117) (chi-body1156 (cons e12118 e22119) (source-wrap1145 e2108 w2124 s2111 mod2112) r2125 w2124 mod2112))))))) tmp2114) ((lambda (_2129) (syntax-error (source-wrap1145 e2108 w2110 s2111 mod2112))) tmp2113))) (syntax-dispatch tmp2113 (quote (any #(each (any any)) any . each-any))))) e2108))) (global-extend1114 (quote core) (quote set!) (lambda (e2130 r2131 w2132 s2133 mod2134) ((lambda (tmp2135) ((lambda (tmp2136) (if (if tmp2136 (apply (lambda (_2137 id2138 val2139) (id?1116 id2138)) tmp2136) #f) (apply (lambda (_2140 id2141 val2142) (let ((val2143 (chi1152 val2142 r2131 w2132 mod2134)) (n2144 (id-var-name1138 id2141 w2132))) (let ((b2145 (lookup1113 n2144 r2131 mod2134))) (let ((t2146 (binding-type1108 b2145))) (if (memv t2146 (quote (lexical))) (build-annotated1093 s2133 (list (quote set!) (binding-value1109 b2145) val2143)) (if (memv t2146 (quote (global))) (build-annotated1093 s2133 (list (quote set!) (if mod2134 (make-module-ref (cdr mod2134) n2144 (car mod2134)) (make-module-ref mod2134 n2144 (quote bare))) val2143)) (if (memv t2146 (quote (displaced-lexical))) (syntax-error (wrap1144 id2141 w2132 mod2134) "identifier out of context") (syntax-error (source-wrap1145 e2130 w2132 s2133 mod2134))))))))) tmp2136) ((lambda (tmp2147) (if tmp2147 (apply (lambda (_2148 head2149 tail2150 val2151) (call-with-values (lambda () (syntax-type1150 head2149 r2131 (quote (())) #f #f mod2134)) (lambda (type2152 value2153 ee2154 ww2155 ss2156 modmod2157) (let ((t2158 type2152)) (if (memv t2158 (quote (module-ref))) (let ((val2159 (chi1152 val2151 r2131 w2132 mod2134))) (call-with-values (lambda () (value2153 (cons head2149 tail2150))) (lambda (id2161 mod2162) (build-annotated1093 s2133 (list (quote set!) (if mod2162 (make-module-ref (cdr mod2162) id2161 (car mod2162)) (make-module-ref mod2162 id2161 (quote bare))) val2159))))) (build-annotated1093 s2133 (cons (chi1152 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail 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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2149) r2131 w2132 mod2134) (map (lambda (e2163) (chi1152 e2163 r2131 w2132 mod2134)) (append tail2150 (list val2151)))))))))) tmp2147) ((lambda (_2165) (syntax-error (source-wrap1145 e2130 w2132 s2133 mod2134))) tmp2135))) (syntax-dispatch tmp2135 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2135 (quote (any any any))))) e2130))) (global-extend1114 (quote module-ref) (quote @) (lambda (e2166) ((lambda (tmp2167) ((lambda (tmp2168) (if (if tmp2168 (apply (lambda (_2169 mod2170 id2171) (and (andmap id?1116 mod2170) (id?1116 id2171))) tmp2168) #f) (apply (lambda (_2173 mod2174 id2175) (values (syntax-object->datum id2175) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2174)))) tmp2168) (syntax-error tmp2167))) (syntax-dispatch tmp2167 (quote (any each-any any))))) e2166))) (global-extend1114 (quote module-ref) (quote @@) (lambda (e2177) ((lambda (tmp2178) ((lambda (tmp2179) (if (if tmp2179 (apply (lambda (_2180 mod2181 id2182) (and (andmap id?1116 mod2181) (id?1116 id2182))) tmp2179) #f) (apply (lambda (_2184 mod2185 id2186) (values (syntax-object->datum id2186) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2185)))) tmp2179) (syntax-error tmp2178))) (syntax-dispatch tmp2178 (quote (any each-any any))))) e2177))) (global-extend1114 (quote begin) (quote begin) (quote ())) (global-extend1114 (quote define) (quote define) (quote ())) (global-extend1114 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1114 (quote eval-when) (quote eval-when) (quote ())) (global-extend1114 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2191 (lambda (x2192 keys2193 clauses2194 r2195 mod2196) (if (null? clauses2194) (build-annotated1093 #f (list (build-annotated1093 #f (quote syntax-error)) x2192)) ((lambda (tmp2197) ((lambda (tmp2198) (if tmp2198 (apply (lambda (pat2199 exp2200) (if (and (id?1116 pat2199) (andmap (lambda (x2201) (not (free-id=?1139 pat2199 x2201))) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2193))) (let ((labels2202 (list (gen-label1121))) (var2203 (gen-var1164 pat2199))) (build-annotated1093 #f (list (build-annotated1093 #f (list (quote lambda) (list var2203) (chi1152 exp2200 (extend-env1110 labels2202 (list (cons (quote syntax) (cons var2203 0))) r2195) (make-binding-wrap1133 (list pat2199) labels2202 (quote (()))) mod2196))) x2192))) (gen-clause2190 x2192 keys2193 (cdr clauses2194) r2195 pat2199 #t exp2200 mod2196))) tmp2198) ((lambda (tmp2204) (if tmp2204 (apply (lambda (pat2205 fender2206 exp2207) (gen-clause2190 x2192 keys2193 (cdr clauses2194) r2195 pat2205 fender2206 exp2207 mod2196)) tmp2204) ((lambda (_2208) (syntax-error (car clauses2194) "invalid syntax-case clause")) tmp2197))) (syntax-dispatch tmp2197 (quote (any any any)))))) (syntax-dispatch tmp2197 (quote (any any))))) (car clauses2194))))) (gen-clause2190 (lambda (x2209 keys2210 clauses2211 r2212 pat2213 fender2214 exp2215 mod2216) (call-with-values (lambda () (convert-pattern2188 pat2213 keys2210)) (lambda (p2217 pvars2218) (cond ((not (distinct-bound-ids?1142 (map car pvars2218))) (syntax-error pat2213 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2219) (not (ellipsis?1161 (car x2219)))) pvars2218)) (syntax-error pat2213 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2220 (gen-var1164 (quote tmp)))) (build-annotated1093 #f (list (build-annotated1093 #f (list (quote lambda) (list y2220) (let ((y2221 (build-annotated1093 #f y2220))) (build-annotated1093 #f (list (quote if) ((lambda (tmp2222) ((lambda (tmp2223) (if tmp2223 (apply (lambda () y2221) tmp2223) ((lambda (_2224) (build-annotated1093 #f (list (quote if) y2221 (build-dispatch-call2189 pvars2218 fender2214 y2221 r2212 mod2216) (build-data1094 #f #f)))) tmp2222))) (syntax-dispatch tmp2222 (quote #(atom #t))))) fender2214) (build-dispatch-call2189 pvars2218 exp2215 y2221 r2212 mod2216) (gen-syntax-case2191 x2209 keys2210 clauses2211 r2212 mod2216)))))) (if (eq? p2217 (quote any)) (build-annotated1093 #f (list (build-annotated1093 #f (quote list)) x2209)) (build-annotated1093 #f (list (build-annotated1093 #f (quote syntax-dispatch)) x2209 (build-data1094 #f p2217))))))))))))) (build-dispatch-call2189 (lambda (pvars2225 exp2226 y2227 r2228 mod2229) (let ((ids2230 (map car pvars2225)) (levels2231 (map cdr pvars2225))) (let ((labels2232 (gen-labels1122 ids2230)) (new-vars2233 (map gen-var1164 ids2230))) (build-annotated1093 #f (list (build-annotated1093 #f (quote apply)) (build-annotated1093 #f (list (quote lambda) new-vars2233 (chi1152 exp2226 (extend-env1110 labels2232 (map (lambda (var2234 level2235) (cons (quote syntax) (cons var2234 level2235))) new-vars2233 (map cdr pvars2225)) r2228) (make-binding-wrap1133 ids2230 labels2232 (quote (()))) mod2229))) y2227)))))) (convert-pattern2188 (lambda (pattern2236 keys2237) (let cvt2238 ((p2239 pattern2236) (n2240 0) (ids2241 (quote ()))) (if (id?1116 p2239) (if (bound-id-member?1143 p2239 keys2237) (values (vector (quote free-id) p2239) ids2241) (values (quote any) (cons (cons p2239 n2240) ids2241))) ((lambda (tmp2242) ((lambda (tmp2243) (if (if tmp2243 (apply (lambda (x2244 dots2245) (ellipsis?1161 dots2245)) tmp2243) #f) (apply (lambda (x2246 dots2247) (call-with-values (lambda () (cvt2238 x2246 (fx+1083 n2240 1) ids2241)) (lambda (p2248 ids2249) (values (if (eq? p2248 (quote any)) (quote each-any) (vector (quote each) p2248)) ids2249)))) tmp2243) ((lambda (tmp2250) (if tmp2250 (apply (lambda (x2251 y2252) (call-with-values (lambda () (cvt2238 y2252 n2240 ids2241)) (lambda (y2253 ids2254) (call-with-values (lambda () (cvt2238 x2251 n2240 ids2254)) (lambda (x2255 ids2256) (values (cons x2255 y2253) ids2256)))))) tmp2250) ((lambda (tmp2257) (if tmp2257 (apply (lambda () (values (quote ()) ids2241)) tmp2257) ((lambda (tmp2258) (if tmp2258 (apply (lambda (x2259) (call-with-values (lambda () (cvt2238 x2259 n2240 ids2241)) (lambda (p2261 ids2262) (values (vector (quote vector) p2261) ids2262)))) tmp2258) ((lambda (x2263) (values (vector (quote atom) (strip1163 p2239 (quote (())))) ids2241)) tmp2242))) (syntax-dispatch tmp2242 (quote #(vector each-any)))))) (syntax-dispatch tmp2242 (quote ()))))) (syntax-dispatch tmp2242 (quote (any . any)))))) (syntax-dispatch tmp2242 (quote (any any))))) p2239)))))) (lambda (e2264 r2265 w2266 s2267 mod2268) (let ((e2269 (source-wrap1145 e2264 w2266 s2267 mod2268))) ((lambda (tmp2270) ((lambda (tmp2271) (if tmp2271 (apply (lambda (_2272 val2273 key2274 m2275) (if (andmap (lambda (x2276) (and (id?1116 x2276) (not (ellipsis?1161 x2276)))) key2274) (let ((x2278 (gen-var1164 (quote tmp)))) (build-annotated1093 s2267 (list (build-annotated1093 #f (list (quote lambda) (list x2278) (gen-syntax-case2191 (build-annotated1093 #f x2278) key2274 m2275 r2265 mod2268))) (chi1152 val2273 r2265 (quote (())) mod2268)))) (syntax-error e2269 "invalid literals list in"))) tmp2271) (syntax-error tmp2270))) (syntax-dispatch tmp2270 (quote (any any each-any . each-any))))) e2269))))) (set! sc-expand (let ((m2281 (quote e)) (esew2282 (quote (eval)))) (lambda (x2283) (if (and (pair? x2283) (equal? (car x2283) noexpand1082)) (cadr x2283) (chi-top1151 x2283 (quote ()) (quote ((top))) m2281 esew2282 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2284 (quote e)) (esew2285 (quote (eval)))) (lambda (x2287 . rest2286) (if (and (pair? x2287) (equal? (car x2287) noexpand1082)) (cadr x2287) (chi-top1151 x2287 (quote ()) (quote ((top))) (if (null? rest2286) m2284 (car rest2286)) (if (or (null? rest2286) (null? (cdr rest2286))) esew2285 (cadr rest2286)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2288) (nonsymbol-id?1115 x2288))) (set! datum->syntax-object (lambda (id2289 datum2290) (make-syntax-object1099 datum2290 (syntax-object-wrap1102 id2289) #f))) (set! syntax-object->datum (lambda (x2291) (strip1163 x2291 (quote (()))))) (set! generate-temporaries (lambda (ls2292) (begin (let ((x2293 ls2292)) (if (not (list? x2293)) (error-hook1089 (quote generate-temporaries) "invalid argument" x2293))) (map (lambda (x2294) (wrap1144 (gensym) (quote ((top))) #f)) ls2292)))) (set! free-identifier=? (lambda (x2295 y2296) (begin (let ((x2297 x2295)) (if (not (nonsymbol-id?1115 x2297)) (error-hook1089 (quote free-identifier=?) "invalid argument" x2297))) (let ((x2298 y2296)) (if (not (nonsymbol-id?1115 x2298)) (error-hook1089 (quote free-identifier=?) "invalid argument" x2298))) (free-id=?1139 x2295 y2296)))) (set! bound-identifier=? (lambda (x2299 y2300) (begin (let ((x2301 x2299)) (if (not (nonsymbol-id?1115 x2301)) (error-hook1089 (quote bound-identifier=?) "invalid argument" x2301))) (let ((x2302 y2300)) (if (not (nonsymbol-id?1115 x2302)) (error-hook1089 (quote bound-identifier=?) "invalid argument" x2302))) (bound-id=?1140 x2299 y2300)))) (set! syntax-error (lambda (object2304 . messages2303) (begin (for-each (lambda (x2305) (let ((x2306 x2305)) (if (not (string? x2306)) (error-hook1089 (quote syntax-error) "invalid argument" x2306)))) messages2303) (let ((message2307 (if (null? messages2303) "invalid syntax" (apply string-append messages2303)))) (error-hook1089 #f message2307 (strip1163 object2304 (quote (())))))))) (set! install-global-transformer (lambda (sym2308 v2309) (begin (let ((x2310 sym2308)) (if (not (symbol? x2310)) (error-hook1089 (quote define-syntax) "invalid argument" x2310))) (let ((x2311 v2309)) (if (not (procedure? x2311)) (error-hook1089 (quote define-syntax) "invalid argument" x2311))) (global-extend1114 (quote macro) sym2308 v2309)))) (letrec ((match2316 (lambda (e2317 p2318 w2319 r2320 mod2321) (cond ((not r2320) #f) ((eq? p2318 (quote any)) (cons (wrap1144 e2317 w2319 mod2321) r2320)) ((syntax-object?1100 e2317) (match*2315 (let ((e2322 (syntax-object-expression1101 e2317))) (if (annotation? e2322) (annotation-expression e2322) e2322)) p2318 (join-wraps1135 w2319 (syntax-object-wrap1102 e2317)) r2320 (syntax-object-module1103 e2317))) (else (match*2315 (let ((e2323 e2317)) (if (annotation? e2323) (annotation-expression e2323) e2323)) p2318 w2319 r2320 mod2321))))) (match*2315 (lambda (e2324 p2325 w2326 r2327 mod2328) (cond ((null? p2325) (and (null? e2324) r2327)) ((pair? p2325) (and (pair? e2324) (match2316 (car e2324) (car p2325) w2326 (match2316 (cdr e2324) (cdr p2325) w2326 r2327 mod2328) mod2328))) ((eq? p2325 (quote each-any)) (let ((l2329 (match-each-any2313 e2324 w2326 mod2328))) (and l2329 (cons l2329 r2327)))) (else (let ((t2330 (vector-ref p2325 0))) (if (memv t2330 (quote (each))) (if (null? e2324) (match-empty2314 (vector-ref p2325 1) r2327) (let ((l2331 (match-each2312 e2324 (vector-ref p2325 1) w2326 mod2328))) (and l2331 (let collect2332 ((l2333 l2331)) (if (null? (car l2333)) r2327 (cons (map car l2333) (collect2332 (map cdr l2333)))))))) (if (memv t2330 (quote (free-id))) (and (id?1116 e2324) (free-id=?1139 (wrap1144 e2324 w2326 mod2328) (vector-ref p2325 1)) r2327) (if (memv t2330 (quote (atom))) (and (equal? (vector-ref p2325 1) (strip1163 e2324 w2326)) r2327) (if (memv t2330 (quote (vector))) (and (vector? e2324) (match2316 (vector->list e2324) (vector-ref p2325 1) w2326 r2327 mod2328))))))))))) (match-empty2314 (lambda (p2334 r2335) (cond ((null? p2334) r2335) ((eq? p2334 (quote any)) (cons (quote ()) r2335)) ((pair? p2334) (match-empty2314 (car p2334) (match-empty2314 (cdr p2334) r2335))) ((eq? p2334 (quote each-any)) (cons (quote ()) r2335)) (else (let ((t2336 (vector-ref p2334 0))) (if (memv t2336 (quote (each))) (match-empty2314 (vector-ref p2334 1) r2335) (if (memv t2336 (quote (free-id atom))) r2335 (if (memv t2336 (quote (vector))) (match-empty2314 (vector-ref p2334 1) r2335))))))))) (match-each-any2313 (lambda (e2337 w2338 mod2339) (cond ((annotation? e2337) (match-each-any2313 (annotation-expression e2337) w2338 mod2339)) ((pair? e2337) (let ((l2340 (match-each-any2313 (cdr e2337) w2338 mod2339))) (and l2340 (cons (wrap1144 (car e2337) w2338 mod2339) l2340)))) ((null? e2337) (quote ())) ((syntax-object?1100 e2337) (match-each-any2313 (syntax-object-expression1101 e2337) (join-wraps1135 w2338 (syntax-object-wrap1102 e2337)) mod2339)) (else #f)))) (match-each2312 (lambda (e2341 p2342 w2343 mod2344) (cond ((annotation? e2341) (match-each2312 (annotation-expression e2341) p2342 w2343 mod2344)) ((pair? e2341) (let ((first2345 (match2316 (car e2341) p2342 w2343 (quote ()) mod2344))) (and first2345 (let ((rest2346 (match-each2312 (cdr e2341) p2342 w2343 mod2344))) (and rest2346 (cons first2345 rest2346)))))) ((null? e2341) (quote ())) ((syntax-object?1100 e2341) (match-each2312 (syntax-object-expression1101 e2341) p2342 (join-wraps1135 w2343 (syntax-object-wrap1102 e2341)) (syntax-object-module1103 e2341))) (else #f))))) (begin (set! syntax-dispatch (lambda (e2347 p2348) (cond ((eq? p2348 (quote any)) (list e2347)) ((syntax-object?1100 e2347) (match*2315 (let ((e2349 (syntax-object-expression1101 e2347))) (if (annotation? e2349) (annotation-expression e2349) e2349)) p2348 (syntax-object-wrap1102 e2347) (quote ()) (syntax-object-module1103 e2347))) (else (match*2315 (let ((e2350 e2347)) (if (annotation? e2350) (annotation-expression e2350) e2350)) p2348 (quote (())) (quote ()) #f))))) (set! sc-chi chi1152))))) -(install-global-transformer (quote with-syntax) (lambda (x2351) ((lambda (tmp2352) ((lambda (tmp2353) (if tmp2353 (apply (lambda (_2354 e12355 e22356) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12355 e22356))) tmp2353) ((lambda (tmp2358) (if tmp2358 (apply (lambda (_2359 out2360 in2361 e12362 e22363) (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"))) (hygiene guile))) in2361 (quote ()) (list out2360 (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"))) (hygiene guile))) (cons e12362 e22363))))) tmp2358) ((lambda (tmp2365) (if tmp2365 (apply (lambda (_2366 out2367 in2368 e12369 e22370) (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"))) (hygiene guile))) (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"))) (hygiene guile))) in2368) (quote ()) (list out2367 (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"))) (hygiene guile))) (cons e12369 e22370))))) tmp2365) (syntax-error tmp2352))) (syntax-dispatch tmp2352 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2352 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2352 (quote (any () any . each-any))))) x2351))) -(install-global-transformer (quote syntax-rules) (lambda (x2374) ((lambda (tmp2375) ((lambda (tmp2376) (if tmp2376 (apply (lambda (_2377 k2378 keyword2379 pattern2380 template2381) (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"))) (hygiene guile))) (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"))) (hygiene guile)))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (cons k2378 (map (lambda (tmp2384 tmp2383) (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"))) (hygiene guile))) tmp2383) (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"))) (hygiene guile))) tmp2384))) template2381 pattern2380)))))) tmp2376) (syntax-error tmp2375))) (syntax-dispatch tmp2375 (quote (any each-any . #(each ((any . any) any))))))) x2374))) -(install-global-transformer (quote let*) (lambda (x2385) ((lambda (tmp2386) ((lambda (tmp2387) (if (if tmp2387 (apply (lambda (let*2388 x2389 v2390 e12391 e22392) (andmap identifier? x2389)) tmp2387) #f) (apply (lambda (let*2394 x2395 v2396 e12397 e22398) (let f2399 ((bindings2400 (map list x2395 v2396))) (if (null? bindings2400) (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"))) (hygiene guile))) (cons (quote ()) (cons e12397 e22398))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (body2406 binding2407) (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"))) (hygiene guile))) (list binding2407) body2406)) tmp2405) (syntax-error tmp2404))) (syntax-dispatch tmp2404 (quote (any any))))) (list (f2399 (cdr bindings2400)) (car bindings2400)))))) tmp2387) (syntax-error tmp2386))) (syntax-dispatch tmp2386 (quote (any #(each (any any)) any . each-any))))) x2385))) -(install-global-transformer (quote do) (lambda (orig-x2408) ((lambda (tmp2409) ((lambda (tmp2410) (if tmp2410 (apply (lambda (_2411 var2412 init2413 step2414 e02415 e12416 c2417) ((lambda (tmp2418) ((lambda (tmp2419) (if tmp2419 (apply (lambda (step2420) ((lambda (tmp2421) ((lambda (tmp2422) (if tmp2422 (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var2412 init2413) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e02415) (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"))) (hygiene guile))) (append c2417 (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"))) (hygiene guile))) step2420))))))) tmp2422) ((lambda (tmp2427) (if tmp2427 (apply (lambda (e12428 e22429) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var2412 init2413) (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"))) (hygiene guile))) e02415 (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"))) (hygiene guile))) (cons e12428 e22429)) (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"))) (hygiene guile))) (append c2417 (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"))) (hygiene guile))) step2420))))))) tmp2427) (syntax-error tmp2421))) (syntax-dispatch tmp2421 (quote (any . each-any)))))) (syntax-dispatch tmp2421 (quote ())))) e12416)) tmp2419) (syntax-error tmp2418))) (syntax-dispatch tmp2418 (quote each-any)))) (map (lambda (v2436 s2437) ((lambda (tmp2438) ((lambda (tmp2439) (if tmp2439 (apply (lambda () v2436) tmp2439) ((lambda (tmp2440) (if tmp2440 (apply (lambda (e2441) e2441) tmp2440) ((lambda (_2442) (syntax-error orig-x2408)) tmp2438))) (syntax-dispatch tmp2438 (quote (any)))))) (syntax-dispatch tmp2438 (quote ())))) s2437)) var2412 step2414))) tmp2410) (syntax-error tmp2409))) (syntax-dispatch tmp2409 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2408))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2445 (lambda (x2449 y2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (x2453 y2454) ((lambda (tmp2455) ((lambda (tmp2456) (if tmp2456 (apply (lambda (dy2457) ((lambda (tmp2458) ((lambda (tmp2459) (if tmp2459 (apply (lambda (dx2460) (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"))) (hygiene guile))) (cons dx2460 dy2457))) tmp2459) ((lambda (_2461) (if (null? dy2457) (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"))) (hygiene guile))) x2453) (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"))) (hygiene guile))) x2453 y2454))) tmp2458))) (syntax-dispatch tmp2458 (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"))) (hygiene guile))) any))))) x2453)) tmp2456) ((lambda (tmp2462) (if tmp2462 (apply (lambda (stuff2463) (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"))) (hygiene guile))) (cons x2453 stuff2463))) tmp2462) ((lambda (else2464) (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"))) (hygiene guile))) x2453 y2454)) tmp2455))) (syntax-dispatch tmp2455 (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"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2455 (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"))) (hygiene guile))) any))))) y2454)) tmp2452) (syntax-error tmp2451))) (syntax-dispatch tmp2451 (quote (any any))))) (list x2449 y2450)))) (quasiappend2446 (lambda (x2465 y2466) ((lambda (tmp2467) ((lambda (tmp2468) (if tmp2468 (apply (lambda (x2469 y2470) ((lambda (tmp2471) ((lambda (tmp2472) (if tmp2472 (apply (lambda () x2469) tmp2472) ((lambda (_2473) (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"))) (hygiene guile))) x2469 y2470)) tmp2471))) (syntax-dispatch tmp2471 (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"))) (hygiene guile))) ()))))) y2470)) tmp2468) (syntax-error tmp2467))) (syntax-dispatch tmp2467 (quote (any any))))) (list x2465 y2466)))) (quasivector2447 (lambda (x2474) ((lambda (tmp2475) ((lambda (x2476) ((lambda (tmp2477) ((lambda (tmp2478) (if tmp2478 (apply (lambda (x2479) (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"))) (hygiene guile))) (list->vector x2479))) tmp2478) ((lambda (tmp2481) (if tmp2481 (apply (lambda (x2482) (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"))) (hygiene guile))) x2482)) tmp2481) ((lambda (_2484) (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"))) (hygiene guile))) x2476)) tmp2477))) (syntax-dispatch tmp2477 (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"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2477 (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"))) (hygiene guile))) each-any))))) x2476)) tmp2475)) x2474))) (quasi2448 (lambda (p2485 lev2486) ((lambda (tmp2487) ((lambda (tmp2488) (if tmp2488 (apply (lambda (p2489) (if (= lev2486 0) p2489 (quasicons2445 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2448 (list p2489) (- lev2486 1))))) tmp2488) ((lambda (tmp2490) (if tmp2490 (apply (lambda (p2491 q2492) (if (= lev2486 0) (quasiappend2446 p2491 (quasi2448 q2492 lev2486)) (quasicons2445 (quasicons2445 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2448 (list p2491) (- lev2486 1))) (quasi2448 q2492 lev2486)))) tmp2490) ((lambda (tmp2493) (if tmp2493 (apply (lambda (p2494) (quasicons2445 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2448 (list p2494) (+ lev2486 1)))) tmp2493) ((lambda (tmp2495) (if tmp2495 (apply (lambda (p2496 q2497) (quasicons2445 (quasi2448 p2496 lev2486) (quasi2448 q2497 lev2486))) tmp2495) ((lambda (tmp2498) (if tmp2498 (apply (lambda (x2499) (quasivector2447 (quasi2448 x2499 lev2486))) tmp2498) ((lambda (p2501) (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"))) (hygiene guile))) p2501)) tmp2487))) (syntax-dispatch tmp2487 (quote #(vector each-any)))))) (syntax-dispatch tmp2487 (quote (any . any)))))) (syntax-dispatch tmp2487 (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"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2487 (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"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2487 (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"))) (hygiene guile))) any))))) p2485)))) (lambda (x2502) ((lambda (tmp2503) ((lambda (tmp2504) (if tmp2504 (apply (lambda (_2505 e2506) (quasi2448 e2506 0)) tmp2504) (syntax-error tmp2503))) (syntax-dispatch tmp2503 (quote (any any))))) x2502)))) -(install-global-transformer (quote include) (lambda (x2507) (letrec ((read-file2508 (lambda (fn2509 k2510) (let ((p2511 (open-input-file fn2509))) (let f2512 ((x2513 (read p2511))) (if (eof-object? x2513) (begin (close-input-port p2511) (quote ())) (cons (datum->syntax-object k2510 x2513) (f2512 (read p2511))))))))) ((lambda (tmp2514) ((lambda (tmp2515) (if tmp2515 (apply (lambda (k2516 filename2517) (let ((fn2518 (syntax-object->datum filename2517))) ((lambda (tmp2519) ((lambda (tmp2520) (if tmp2520 (apply (lambda (exp2521) (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"))) (hygiene guile))) exp2521)) tmp2520) (syntax-error tmp2519))) (syntax-dispatch tmp2519 (quote each-any)))) (read-file2508 fn2518 k2516)))) tmp2515) (syntax-error tmp2514))) (syntax-dispatch tmp2514 (quote (any any))))) x2507)))) -(install-global-transformer (quote unquote) (lambda (x2523) ((lambda (tmp2524) ((lambda (tmp2525) (if tmp2525 (apply (lambda (_2526 e2527) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2527))) tmp2525) (syntax-error tmp2524))) (syntax-dispatch tmp2524 (quote (any any))))) x2523))) -(install-global-transformer (quote unquote-splicing) (lambda (x2528) ((lambda (tmp2529) ((lambda (tmp2530) (if tmp2530 (apply (lambda (_2531 e2532) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2532))) tmp2530) (syntax-error tmp2529))) (syntax-dispatch tmp2529 (quote (any any))))) x2528))) -(install-global-transformer (quote case) (lambda (x2533) ((lambda (tmp2534) ((lambda (tmp2535) (if tmp2535 (apply (lambda (_2536 e2537 m12538 m22539) ((lambda (tmp2540) ((lambda (body2541) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e2537)) body2541)) tmp2540)) (let f2542 ((clause2543 m12538) (clauses2544 m22539)) (if (null? clauses2544) ((lambda (tmp2546) ((lambda (tmp2547) (if tmp2547 (apply (lambda (e12548 e22549) (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"))) (hygiene guile))) (cons e12548 e22549))) tmp2547) ((lambda (tmp2551) (if tmp2551 (apply (lambda (k2552 e12553 e22554) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k2552)) (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"))) (hygiene guile))) (cons e12553 e22554)))) tmp2551) ((lambda (_2557) (syntax-error x2533)) tmp2546))) (syntax-dispatch tmp2546 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2546 (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"))) (hygiene guile))) any . each-any))))) clause2543) ((lambda (tmp2558) ((lambda (rest2559) ((lambda (tmp2560) ((lambda (tmp2561) (if tmp2561 (apply (lambda (k2562 e12563 e22564) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k2562)) (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"))) (hygiene guile))) (cons e12563 e22564)) rest2559)) tmp2561) ((lambda (_2567) (syntax-error x2533)) tmp2560))) (syntax-dispatch tmp2560 (quote (each-any any . each-any))))) clause2543)) tmp2558)) (f2542 (car clauses2544) (cdr clauses2544))))))) tmp2535) (syntax-error tmp2534))) (syntax-dispatch tmp2534 (quote (any any any . each-any))))) x2533))) -(install-global-transformer (quote identifier-syntax) (lambda (x2568) ((lambda (tmp2569) ((lambda (tmp2570) (if tmp2570 (apply (lambda (_2571 e2572) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2572)) (list (cons _2571 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2572 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2570) (syntax-error tmp2569))) (syntax-dispatch tmp2569 (quote (any any))))) x2568))) +(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-error p1361 "nonprocedure transformer"))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-error e1363 "duplicate bound keyword in") (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-error (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) (syntax-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax-object->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-error e1386 "invalid parameter list in") (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-error e1386 "invalid parameter list in") (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-error e1386)) tmp1393))) (syntax-dispatch tmp1393 (quote (any any . each-any)))))) (syntax-dispatch tmp1393 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-error outer-form1426 "no expressions in body") (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-error tmp1455))) (syntax-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-error outer-form1426 "invalid or duplicate identifier in definition")) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-error x1486 "encountered raw symbol in macro output")) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-error tmp1502))) (syntax-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-error tmp1518))) (syntax-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-error tmp1524))) (syntax-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-error (wrap1111 value1509 w1512 mod1514) "invalid context for definition of") (if (memv t1515 (quote (syntax))) (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to pattern variable outside syntax form") (if (memv t1515 (quote (displaced-lexical))) (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to identifier outside its scope") (syntax-error (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-error tmp1563))) (syntax-dispatch tmp1563 (quote (any any . each-any)))))) (syntax-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-error tmp1576))) (syntax-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-error (wrap1111 value1557 w1559 mod1561) "identifier out of context") (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-error (wrap1111 value1557 w1559 mod1561) "cannot define keyword at top level"))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-error tmp1612))) (syntax-dispatch tmp1612 (quote (any any)))))) (syntax-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-error tmp1637))) (syntax-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-error (wrap1111 x1651 w1647 #f) "invalid eval-when situation")))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-error (source-wrap1112 id1881 w1862 s1863 mod1864) "identifier out of context")))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-error (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) (syntax-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-error (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) (syntax-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-error src1927 "missing ellipsis in syntax form") (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-error src1935 "misplaced ellipsis in syntax form") (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-error src1935 "extra ellipsis in syntax form") (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) (syntax-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) (syntax-dispatch tmp1946 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp1946 (quote (any . any)))))) (syntax-dispatch tmp1946 (quote (any any . any)))))) (syntax-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-error e1999)) tmp2000))) (syntax-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-error tmp2012))) (syntax-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-error e2020 "duplicate bound variable in") (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-error (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) (syntax-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-error e2066 "duplicate bound variable in") (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-error (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) (syntax-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-error (wrap1111 id2099 w2090 mod2092) "identifier out of context") (syntax-error (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail 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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-error (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) (syntax-dispatch tmp2093 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax-object->datum id2133) (syntax-object->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-error tmp2125))) (syntax-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax-object->datum id2144) (syntax-object->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-error tmp2136))) (syntax-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-error)) x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-error (car clauses2152) "invalid syntax-case clause")) tmp2155))) (syntax-dispatch tmp2155 (quote (any any any)))))) (syntax-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-error pat2171 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-error pat2171 "misplaced ellipsis in syntax-case pattern")) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) (syntax-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) (syntax-dispatch tmp2200 (quote #(vector each-any)))))) (syntax-dispatch tmp2200 (quote ()))))) (syntax-dispatch tmp2200 (quote (any . any)))))) (syntax-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-error e2227 "invalid literals list in"))) tmp2229) (syntax-error tmp2228))) (syntax-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax-object (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax-object->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-error (lambda (object2262 . messages2261) (begin (for-each (lambda (x2263) (let ((x2264 x2263)) (if (not (string? x2264)) (error-hook1056 (quote syntax-error) "invalid argument" x2264)))) messages2261) (let ((message2265 (if (null? messages2261) "invalid syntax" (apply string-append messages2261)))) (error-hook1056 #f message2265 (strip1130 object2262 (quote (())))))))) (set! install-global-transformer (lambda (sym2266 v2267) (begin (let ((x2268 sym2266)) (if (not (symbol? x2268)) (error-hook1056 (quote define-syntax) "invalid argument" x2268))) (let ((x2269 v2267)) (if (not (procedure? x2269)) (error-hook1056 (quote define-syntax) "invalid argument" x2269))) (global-extend1081 (quote macro) sym2266 v2267)))) (letrec ((match2274 (lambda (e2275 p2276 w2277 r2278 mod2279) (cond ((not r2278) #f) ((eq? p2276 (quote any)) (cons (wrap1111 e2275 w2277 mod2279) r2278)) ((syntax-object?1067 e2275) (match*2273 (let ((e2280 (syntax-object-expression1068 e2275))) (if (annotation? e2280) (annotation-expression e2280) e2280)) p2276 (join-wraps1102 w2277 (syntax-object-wrap1069 e2275)) r2278 (syntax-object-module1070 e2275))) (else (match*2273 (let ((e2281 e2275)) (if (annotation? e2281) (annotation-expression e2281) e2281)) p2276 w2277 r2278 mod2279))))) (match*2273 (lambda (e2282 p2283 w2284 r2285 mod2286) (cond ((null? p2283) (and (null? e2282) r2285)) ((pair? p2283) (and (pair? e2282) (match2274 (car e2282) (car p2283) w2284 (match2274 (cdr e2282) (cdr p2283) w2284 r2285 mod2286) mod2286))) ((eq? p2283 (quote each-any)) (let ((l2287 (match-each-any2271 e2282 w2284 mod2286))) (and l2287 (cons l2287 r2285)))) (else (let ((t2288 (vector-ref p2283 0))) (if (memv t2288 (quote (each))) (if (null? e2282) (match-empty2272 (vector-ref p2283 1) r2285) (let ((l2289 (match-each2270 e2282 (vector-ref p2283 1) w2284 mod2286))) (and l2289 (let collect2290 ((l2291 l2289)) (if (null? (car l2291)) r2285 (cons (map car l2291) (collect2290 (map cdr l2291)))))))) (if (memv t2288 (quote (free-id))) (and (id?1083 e2282) (free-id=?1106 (wrap1111 e2282 w2284 mod2286) (vector-ref p2283 1)) r2285) (if (memv t2288 (quote (atom))) (and (equal? (vector-ref p2283 1) (strip1130 e2282 w2284)) r2285) (if (memv t2288 (quote (vector))) (and (vector? e2282) (match2274 (vector->list e2282) (vector-ref p2283 1) w2284 r2285 mod2286))))))))))) (match-empty2272 (lambda (p2292 r2293) (cond ((null? p2292) r2293) ((eq? p2292 (quote any)) (cons (quote ()) r2293)) ((pair? p2292) (match-empty2272 (car p2292) (match-empty2272 (cdr p2292) r2293))) ((eq? p2292 (quote each-any)) (cons (quote ()) r2293)) (else (let ((t2294 (vector-ref p2292 0))) (if (memv t2294 (quote (each))) (match-empty2272 (vector-ref p2292 1) r2293) (if (memv t2294 (quote (free-id atom))) r2293 (if (memv t2294 (quote (vector))) (match-empty2272 (vector-ref p2292 1) r2293))))))))) (match-each-any2271 (lambda (e2295 w2296 mod2297) (cond ((annotation? e2295) (match-each-any2271 (annotation-expression e2295) w2296 mod2297)) ((pair? e2295) (let ((l2298 (match-each-any2271 (cdr e2295) w2296 mod2297))) (and l2298 (cons (wrap1111 (car e2295) w2296 mod2297) l2298)))) ((null? e2295) (quote ())) ((syntax-object?1067 e2295) (match-each-any2271 (syntax-object-expression1068 e2295) (join-wraps1102 w2296 (syntax-object-wrap1069 e2295)) mod2297)) (else #f)))) (match-each2270 (lambda (e2299 p2300 w2301 mod2302) (cond ((annotation? e2299) (match-each2270 (annotation-expression e2299) p2300 w2301 mod2302)) ((pair? e2299) (let ((first2303 (match2274 (car e2299) p2300 w2301 (quote ()) mod2302))) (and first2303 (let ((rest2304 (match-each2270 (cdr e2299) p2300 w2301 mod2302))) (and rest2304 (cons first2303 rest2304)))))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each2270 (syntax-object-expression1068 e2299) p2300 (join-wraps1102 w2301 (syntax-object-wrap1069 e2299)) (syntax-object-module1070 e2299))) (else #f))))) (set! syntax-dispatch (lambda (e2305 p2306) (cond ((eq? p2306 (quote any)) (list e2305)) ((syntax-object?1067 e2305) (match*2273 (let ((e2307 (syntax-object-expression1068 e2305))) (if (annotation? e2307) (annotation-expression e2307) e2307)) p2306 (syntax-object-wrap1069 e2305) (quote ()) (syntax-object-module1070 e2305))) (else (match*2273 (let ((e2308 e2305)) (if (annotation? e2308) (annotation-expression e2308) e2308)) p2306 (quote (())) (quote ()) #f)))))))) +(install-global-transformer (quote with-syntax) (lambda (x2309) ((lambda (tmp2310) ((lambda (tmp2311) (if tmp2311 (apply (lambda (_2312 e12313 e22314) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12313 e22314))) tmp2311) ((lambda (tmp2316) (if tmp2316 (apply (lambda (_2317 out2318 in2319 e12320 e22321) (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"))) (hygiene guile))) in2319 (quote ()) (list out2318 (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"))) (hygiene guile))) (cons e12320 e22321))))) tmp2316) ((lambda (tmp2323) (if tmp2323 (apply (lambda (_2324 out2325 in2326 e12327 e22328) (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"))) (hygiene guile))) (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"))) (hygiene guile))) in2326) (quote ()) (list out2325 (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"))) (hygiene guile))) (cons e12327 e22328))))) tmp2323) (syntax-error tmp2310))) (syntax-dispatch tmp2310 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp2310 (quote (any () any . each-any))))) x2309))) +(install-global-transformer (quote syntax-rules) (lambda (x2332) ((lambda (tmp2333) ((lambda (tmp2334) (if tmp2334 (apply (lambda (_2335 k2336 keyword2337 pattern2338 template2339) (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"))) (hygiene guile))) (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"))) (hygiene guile)))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (cons k2336 (map (lambda (tmp2342 tmp2341) (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"))) (hygiene guile))) tmp2341) (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"))) (hygiene guile))) tmp2342))) template2339 pattern2338)))))) tmp2334) (syntax-error tmp2333))) (syntax-dispatch tmp2333 (quote (any each-any . #(each ((any . any) any))))))) x2332))) +(install-global-transformer (quote let*) (lambda (x2343) ((lambda (tmp2344) ((lambda (tmp2345) (if (if tmp2345 (apply (lambda (let*2346 x2347 v2348 e12349 e22350) (andmap identifier? x2347)) tmp2345) #f) (apply (lambda (let*2352 x2353 v2354 e12355 e22356) (let f2357 ((bindings2358 (map list x2353 v2354))) (if (null? bindings2358) (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"))) (hygiene guile))) (cons (quote ()) (cons e12355 e22356))) ((lambda (tmp2362) ((lambda (tmp2363) (if tmp2363 (apply (lambda (body2364 binding2365) (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"))) (hygiene guile))) (list binding2365) body2364)) tmp2363) (syntax-error tmp2362))) (syntax-dispatch tmp2362 (quote (any any))))) (list (f2357 (cdr bindings2358)) (car bindings2358)))))) tmp2345) (syntax-error tmp2344))) (syntax-dispatch tmp2344 (quote (any #(each (any any)) any . each-any))))) x2343))) +(install-global-transformer (quote do) (lambda (orig-x2366) ((lambda (tmp2367) ((lambda (tmp2368) (if tmp2368 (apply (lambda (_2369 var2370 init2371 step2372 e02373 e12374 c2375) ((lambda (tmp2376) ((lambda (tmp2377) (if tmp2377 (apply (lambda (step2378) ((lambda (tmp2379) ((lambda (tmp2380) (if tmp2380 (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var2370 init2371) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e02373) (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"))) (hygiene guile))) (append c2375 (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"))) (hygiene guile))) step2378))))))) tmp2380) ((lambda (tmp2385) (if tmp2385 (apply (lambda (e12386 e22387) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var2370 init2371) (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"))) (hygiene guile))) e02373 (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"))) (hygiene guile))) (cons e12386 e22387)) (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"))) (hygiene guile))) (append c2375 (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"))) (hygiene guile))) step2378))))))) tmp2385) (syntax-error tmp2379))) (syntax-dispatch tmp2379 (quote (any . each-any)))))) (syntax-dispatch tmp2379 (quote ())))) e12374)) tmp2377) (syntax-error tmp2376))) (syntax-dispatch tmp2376 (quote each-any)))) (map (lambda (v2394 s2395) ((lambda (tmp2396) ((lambda (tmp2397) (if tmp2397 (apply (lambda () v2394) tmp2397) ((lambda (tmp2398) (if tmp2398 (apply (lambda (e2399) e2399) tmp2398) ((lambda (_2400) (syntax-error orig-x2366)) tmp2396))) (syntax-dispatch tmp2396 (quote (any)))))) (syntax-dispatch tmp2396 (quote ())))) s2395)) var2370 step2372))) tmp2368) (syntax-error tmp2367))) (syntax-dispatch tmp2367 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2366))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons2403 (lambda (x2407 y2408) ((lambda (tmp2409) ((lambda (tmp2410) (if tmp2410 (apply (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (dy2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda (dx2418) (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"))) (hygiene guile))) (cons dx2418 dy2415))) tmp2417) ((lambda (_2419) (if (null? dy2415) (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"))) (hygiene guile))) x2411) (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"))) (hygiene guile))) x2411 y2412))) tmp2416))) (syntax-dispatch tmp2416 (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"))) (hygiene guile))) any))))) x2411)) tmp2414) ((lambda (tmp2420) (if tmp2420 (apply (lambda (stuff2421) (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"))) (hygiene guile))) (cons x2411 stuff2421))) tmp2420) ((lambda (else2422) (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"))) (hygiene guile))) x2411 y2412)) tmp2413))) (syntax-dispatch tmp2413 (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"))) (hygiene guile))) . any)))))) (syntax-dispatch tmp2413 (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"))) (hygiene guile))) any))))) y2412)) tmp2410) (syntax-error tmp2409))) (syntax-dispatch tmp2409 (quote (any any))))) (list x2407 y2408)))) (quasiappend2404 (lambda (x2423 y2424) ((lambda (tmp2425) ((lambda (tmp2426) (if tmp2426 (apply (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda () x2427) tmp2430) ((lambda (_2431) (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"))) (hygiene guile))) x2427 y2428)) tmp2429))) (syntax-dispatch tmp2429 (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"))) (hygiene guile))) ()))))) y2428)) tmp2426) (syntax-error tmp2425))) (syntax-dispatch tmp2425 (quote (any any))))) (list x2423 y2424)))) (quasivector2405 (lambda (x2432) ((lambda (tmp2433) ((lambda (x2434) ((lambda (tmp2435) ((lambda (tmp2436) (if tmp2436 (apply (lambda (x2437) (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"))) (hygiene guile))) (list->vector x2437))) tmp2436) ((lambda (tmp2439) (if tmp2439 (apply (lambda (x2440) (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"))) (hygiene guile))) x2440)) tmp2439) ((lambda (_2442) (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"))) (hygiene guile))) x2434)) tmp2435))) (syntax-dispatch tmp2435 (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"))) (hygiene guile))) . each-any)))))) (syntax-dispatch tmp2435 (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"))) (hygiene guile))) each-any))))) x2434)) tmp2433)) x2432))) (quasi2406 (lambda (p2443 lev2444) ((lambda (tmp2445) ((lambda (tmp2446) (if tmp2446 (apply (lambda (p2447) (if (= lev2444 0) p2447 (quasicons2403 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2406 (list p2447) (- lev2444 1))))) tmp2446) ((lambda (tmp2448) (if tmp2448 (apply (lambda (p2449 q2450) (if (= lev2444 0) (quasiappend2404 p2449 (quasi2406 q2450 lev2444)) (quasicons2403 (quasicons2403 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2406 (list p2449) (- lev2444 1))) (quasi2406 q2450 lev2444)))) tmp2448) ((lambda (tmp2451) (if tmp2451 (apply (lambda (p2452) (quasicons2403 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2406 (list p2452) (+ lev2444 1)))) tmp2451) ((lambda (tmp2453) (if tmp2453 (apply (lambda (p2454 q2455) (quasicons2403 (quasi2406 p2454 lev2444) (quasi2406 q2455 lev2444))) tmp2453) ((lambda (tmp2456) (if tmp2456 (apply (lambda (x2457) (quasivector2405 (quasi2406 x2457 lev2444))) tmp2456) ((lambda (p2459) (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"))) (hygiene guile))) p2459)) tmp2445))) (syntax-dispatch tmp2445 (quote #(vector each-any)))))) (syntax-dispatch tmp2445 (quote (any . any)))))) (syntax-dispatch tmp2445 (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"))) (hygiene guile))) any)))))) (syntax-dispatch tmp2445 (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"))) (hygiene guile))) any) . any)))))) (syntax-dispatch tmp2445 (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"))) (hygiene guile))) any))))) p2443)))) (lambda (x2460) ((lambda (tmp2461) ((lambda (tmp2462) (if tmp2462 (apply (lambda (_2463 e2464) (quasi2406 e2464 0)) tmp2462) (syntax-error tmp2461))) (syntax-dispatch tmp2461 (quote (any any))))) x2460)))) +(install-global-transformer (quote include) (lambda (x2465) (letrec ((read-file2466 (lambda (fn2467 k2468) (let ((p2469 (open-input-file fn2467))) (let f2470 ((x2471 (read p2469))) (if (eof-object? x2471) (begin (close-input-port p2469) (quote ())) (cons (datum->syntax-object k2468 x2471) (f2470 (read p2469))))))))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (k2474 filename2475) (let ((fn2476 (syntax-object->datum filename2475))) ((lambda (tmp2477) ((lambda (tmp2478) (if tmp2478 (apply (lambda (exp2479) (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"))) (hygiene guile))) exp2479)) tmp2478) (syntax-error tmp2477))) (syntax-dispatch tmp2477 (quote each-any)))) (read-file2466 fn2476 k2474)))) tmp2473) (syntax-error tmp2472))) (syntax-dispatch tmp2472 (quote (any any))))) x2465)))) +(install-global-transformer (quote unquote) (lambda (x2481) ((lambda (tmp2482) ((lambda (tmp2483) (if tmp2483 (apply (lambda (_2484 e2485) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum e2485))) tmp2483) (syntax-error tmp2482))) (syntax-dispatch tmp2482 (quote (any any))))) x2481))) +(install-global-transformer (quote unquote-splicing) (lambda (x2486) ((lambda (tmp2487) ((lambda (tmp2488) (if tmp2488 (apply (lambda (_2489 e2490) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum e2490))) tmp2488) (syntax-error tmp2487))) (syntax-dispatch tmp2487 (quote (any any))))) x2486))) +(install-global-transformer (quote case) (lambda (x2491) ((lambda (tmp2492) ((lambda (tmp2493) (if tmp2493 (apply (lambda (_2494 e2495 m12496 m22497) ((lambda (tmp2498) ((lambda (body2499) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e2495)) body2499)) tmp2498)) (let f2500 ((clause2501 m12496) (clauses2502 m22497)) (if (null? clauses2502) ((lambda (tmp2504) ((lambda (tmp2505) (if tmp2505 (apply (lambda (e12506 e22507) (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"))) (hygiene guile))) (cons e12506 e22507))) tmp2505) ((lambda (tmp2509) (if tmp2509 (apply (lambda (k2510 e12511 e22512) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k2510)) (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"))) (hygiene guile))) (cons e12511 e22512)))) tmp2509) ((lambda (_2515) (syntax-error x2491)) tmp2504))) (syntax-dispatch tmp2504 (quote (each-any any . each-any)))))) (syntax-dispatch tmp2504 (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"))) (hygiene guile))) any . each-any))))) clause2501) ((lambda (tmp2516) ((lambda (rest2517) ((lambda (tmp2518) ((lambda (tmp2519) (if tmp2519 (apply (lambda (k2520 e12521 e22522) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k2520)) (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"))) (hygiene guile))) (cons e12521 e22522)) rest2517)) tmp2519) ((lambda (_2525) (syntax-error x2491)) tmp2518))) (syntax-dispatch tmp2518 (quote (each-any any . each-any))))) clause2501)) tmp2516)) (f2500 (car clauses2502) (cdr clauses2502))))))) tmp2493) (syntax-error tmp2492))) (syntax-dispatch tmp2492 (quote (any any any . each-any))))) x2491))) +(install-global-transformer (quote identifier-syntax) (lambda (x2526) ((lambda (tmp2527) ((lambda (tmp2528) (if tmp2528 (apply (lambda (_2529 e2530) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2530)) (list (cons _2529 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2530 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2528) (syntax-error tmp2527))) (syntax-dispatch tmp2527 (quote (any any))))) x2526))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 8dfab12a5..23a6efdc5 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -339,34 +339,19 @@ (define put-global-definition-hook (lambda (symbol type val) - (let* ((module (current-module)) - (v (or (module-variable module symbol) - (let ((v (make-variable val))) - (module-add! module symbol v) - v)))) - (if (not (variable-bound? v)) - (variable-set! v val)) - ;; Properties are tied to variable objects - (set-object-property! v '*sc-expander* - (make-binding type val))))) + (module-define-keyword! (current-module) symbol type val))) (define remove-global-definition-hook (lambda (symbol) - (let* ((module (current-module)) - (v (module-local-variable module symbol))) - (if v - (let ((p (assq '*sc-expander* (object-properties v)))) - (set-object-properties! v (delq p (object-properties v)))))))) + (module-undefine-keyword! (current-module) symbol))) (define get-global-definition-hook (lambda (symbol module) - (let* ((module (if module - (resolve-module (cdr module)) - (let ((mod (current-module))) - (if mod (warn "wha" symbol)) - mod))) - (v (module-variable module symbol))) - (and v (object-property v '*sc-expander*))))) + (if (and (not module) (current-module)) + (warn "module system is booted, we should have a module" symbol)) + (module-lookup-keyword (if module (resolve-module (cdr module)) + (current-module)) + symbol))) ) @@ -2170,7 +2155,6 @@ p (syntax-object-wrap e) '() (syntax-object-module e))) (else (match* (unannotate e) p empty-wrap '() #f))))) -(set! sc-chi chi) )) ) -- cgit v1.2.3 From 5a0132b3375b35c69c6afb735acbaa8619237fb5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Apr 2009 00:38:12 +0200 Subject: a different tack for syncase macro representation * libguile/macros.c (macro_print): Show syntax-case bindings, if present. (macro_mark): Mark the extra two words if they're there. (scm_make_syncase_macro, scm_make_extended_syncase_macro): OK! A new take at the "how do we represent syncase macros in Guile" problem. Whereas we need a disjoint type, but would like it to be compatible with old predicates (e.g. `macro?'), and need to be able to extend existing syntax definitions (e.g. `cond'), let's add a bit to macros to indicate whether they have syncase macro bindings or not, and a fourth macro type for native syncase macros. (scm_macro_type): Return 'syntax-case for native syntax-case macros. Note that other macro types may have syntax-case bindings. (scm_macro_name): Return #f if the transformer is not a procedure. (scm_syncase_macro_type, scm_syncase_macro_binding): New accessors for the syncase macro bindings. * libguile/macros.h: Add API for syncase macros. * module/ice-9/boot-9.scm (module-define-keyword!): Adapt to use syncase macros, though they are not yet used. Reorder other syncase API. * module/ice-9/psyntax.scm (chi-expr): Fix syntax-violation invocation. --- libguile/macros.c | 109 ++++++++++++++++++++++++++++++++++++++++---- libguile/macros.h | 13 +++++- module/ice-9/boot-9.scm | 35 +++++++------- module/ice-9/psyntax-pp.scm | 2 +- module/ice-9/psyntax.scm | 4 +- 5 files changed, 132 insertions(+), 31 deletions(-) (limited to 'libguile') diff --git a/libguile/macros.c b/libguile/macros.c index d132c0159..535f3e050 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -48,10 +48,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate) || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, macro, port, pstate))) { + scm_puts ("#<", port); + + if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) + scm_puts ("extended-", port); + if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) - scm_puts ("#', port); } return 1; } +static SCM +macro_mark (SCM macro) +{ + if (SCM_MACRO_IS_EXTENDED (macro)) + { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro)); + scm_gc_mark (SCM_SMOB_OBJECT_3 (macro)); + } + return SCM_SMOB_OBJECT (macro); +} + static SCM makmac (SCM code, scm_t_bits flags) { @@ -164,6 +187,40 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, #endif +SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0, + (SCM type, SCM binding), + "Return a @dfn{macro} that requires expansion by syntax-case.\n" + "While users should not call this function, it is useful to know\n" + "that syntax-case macros are represented as Guile primitive macros.") +#define FUNC_NAME s_scm_make_syncase_macro +{ + SCM z; + SCM_VALIDATE_SYMBOL (1, type); + + SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type), + SCM_UNPACK (binding)); + SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED); + return z; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0, + (SCM m, SCM type, SCM binding), + "Extend a core macro @var{m} with a syntax-case binding.") +#define FUNC_NAME s_scm_make_extended_syncase_macro +{ + SCM z; + SCM_VALIDATE_SMOB (1, m, macro); + SCM_VALIDATE_SYMBOL (2, type); + + SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type), + SCM_UNPACK (binding)); + SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED); + return z; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, (SCM obj), @@ -182,14 +239,15 @@ SCM_SYMBOL (scm_sym_macro, "macro"); #endif SCM_SYMBOL (scm_sym_mmacro, "macro!"); SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!"); +SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro"); SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, (SCM m), - "Return one of the symbols @code{syntax}, @code{macro} or\n" - "@code{macro!}, depending on whether @var{m} is a syntax\n" - "transformer, a regular macro, or a memoizing macro,\n" - "respectively. If @var{m} is not a macro, @code{#f} is\n" - "returned.") + "Return one of the symbols @code{syntax}, @code{macro},\n" + "@code{macro!}, or @code{syntax-case}, depending on whether\n" + "@var{m} is a syntax transformer, a regular macro, a memoizing\n" + "macro, or a syntax-case macro, respectively. If @var{m} is\n" + "not a macro, @code{#f} is returned.") #define FUNC_NAME s_scm_macro_type { if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m)) @@ -202,6 +260,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, #endif case 2: return scm_sym_mmacro; case 3: return scm_sym_bimacro; + case 4: return scm_sym_syncase_macro; default: scm_wrong_type_arg (FUNC_NAME, 1, m); } } @@ -214,7 +273,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, #define FUNC_NAME s_scm_macro_name { SCM_VALIDATE_SMOB (1, m, macro); - return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m))); + if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m)))) + return scm_procedure_name (SCM_SMOB_OBJECT (m)); + return SCM_BOOL_F; } #undef FUNC_NAME @@ -236,6 +297,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0, + (SCM m), + "Return the type of the macro @var{m}.") +#define FUNC_NAME s_scm_syncase_macro_type +{ + SCM_VALIDATE_SMOB (1, m, macro); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_2 (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0, + (SCM m), + "Return the binding of the macro @var{m}.") +#define FUNC_NAME s_scm_syncase_macro_binding +{ + SCM_VALIDATE_SMOB (1, m, macro); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_3 (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + SCM scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { @@ -249,7 +338,7 @@ void scm_init_macros () { scm_tc16_macro = scm_make_smob_type ("macro", 0); - scm_set_smob_mark (scm_tc16_macro, scm_markcdr); + scm_set_smob_mark (scm_tc16_macro, macro_mark); scm_set_smob_print (scm_tc16_macro, macro_print); #include "libguile/macros.x" } diff --git a/libguile/macros.h b/libguile/macros.h index e1de77ff9..5e3d64a55 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -29,9 +29,15 @@ #define SCM_ASSYNT(_cond, _msg, _subr) \ if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); +#define SCM_MACRO_TYPE_BITS (3) +#define SCM_MACRO_TYPE_MASK ((1<syntax #f) (define syntax->datum #f) - (define identifier? #f) (define generate-temporaries #f) (define bound-identifier=? #f) (define free-identifier=? #f) +(define sc-expand #f) +(define sc-expand3 #f) + +;;; Implementation detail of psyntax -- the thing that does expand-time +;;; dispatch for syntax-case macros +(define $sc-dispatch #f) + +;;; Useless crap I'd like to get rid of +(define install-global-transformer #f) +(define (annotation? x) #f) + (define andmap (lambda (f first . rest) @@ -213,14 +219,9 @@ (apply f (cons x xr)) (and (apply f (cons x xr)) (andmap first rest))))))))) -(define (syncase-error who format-string why what) - (%start-stack 'syncase-stack - (lambda () - (scm-error 'misc-error who "~A ~S" (list why what) '())))) - -;; Until the module system is booted, this will be the current expander. (primitive-load-path "ice-9/psyntax-pp") +;; Until the module system is booted, this will be the current expander. (define %pre-modules-transformer sc-expand) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 31066c3f2..99510b892 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,6 +1,6 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) ($sc-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) ($sc-dispatch tmp1393 (quote (any any . each-any)))))) ($sc-dispatch tmp1393 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) ($sc-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) ($sc-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) ($sc-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f (source-wrap1112 e1510 w1512 s1513 mod1514) "reference to identifier outside its scope") (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any . each-any)))))) ($sc-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) ($sc-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) ($sc-dispatch tmp1612 (quote (any any)))))) ($sc-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) ($sc-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) ($sc-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) ($sc-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) ($sc-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) ($sc-dispatch tmp1946 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1946 (quote (any . any)))))) ($sc-dispatch tmp1946 (quote (any any . any)))))) ($sc-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) ($sc-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) ($sc-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) ($sc-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) ($sc-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail 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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) ($sc-dispatch tmp2093 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) ($sc-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) ($sc-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) ($sc-dispatch tmp2155 (quote (any any any)))))) ($sc-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) ($sc-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote $sc-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) ($sc-dispatch tmp2200 (quote #(vector each-any)))))) ($sc-dispatch tmp2200 (quote ()))))) ($sc-dispatch tmp2200 (quote (any . any)))))) ($sc-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) ($sc-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! $sc-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) +(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) ($sc-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) ($sc-dispatch tmp1393 (quote (any any . each-any)))))) ($sc-dispatch tmp1393 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) ($sc-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) ($sc-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) ($sc-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1112 e1510 w1512 s1513 mod1514)) (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any . each-any)))))) ($sc-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) ($sc-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) ($sc-dispatch tmp1612 (quote (any any)))))) ($sc-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) ($sc-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) ($sc-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) ($sc-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) ($sc-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) ($sc-dispatch tmp1946 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1946 (quote (any . any)))))) ($sc-dispatch tmp1946 (quote (any any . any)))))) ($sc-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) ($sc-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) ($sc-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) ($sc-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) ($sc-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail 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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) ($sc-dispatch tmp2093 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) ($sc-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) ($sc-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) ($sc-dispatch tmp2155 (quote (any any any)))))) ($sc-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) ($sc-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote $sc-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) ($sc-dispatch tmp2200 (quote #(vector each-any)))))) ($sc-dispatch tmp2200 (quote ()))))) ($sc-dispatch tmp2200 (quote (any . any)))))) ($sc-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) ($sc-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! $sc-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) (install-global-transformer (quote with-syntax) (lambda (x2313) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 e12317 e22318) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12317 e22318))) tmp2315) ((lambda (tmp2320) (if tmp2320 (apply (lambda (_2321 out2322 in2323 e12324 e22325) (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"))) (hygiene guile))) in2323 (quote ()) (list out2322 (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"))) (hygiene guile))) (cons e12324 e22325))))) tmp2320) ((lambda (tmp2327) (if tmp2327 (apply (lambda (_2328 out2329 in2330 e12331 e22332) (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"))) (hygiene guile))) (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"))) (hygiene guile))) in2330) (quote ()) (list out2329 (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"))) (hygiene guile))) (cons e12331 e22332))))) tmp2327) (syntax-violation #f "source expression failed to match any pattern" tmp2314))) ($sc-dispatch tmp2314 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any () any . each-any))))) x2313))) (install-global-transformer (quote syntax-rules) (lambda (x2336) ((lambda (tmp2337) ((lambda (tmp2338) (if tmp2338 (apply (lambda (_2339 k2340 keyword2341 pattern2342 template2343) (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"))) (hygiene guile))) (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"))) (hygiene guile)))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (cons k2340 (map (lambda (tmp2346 tmp2345) (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"))) (hygiene guile))) tmp2345) (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"))) (hygiene guile))) tmp2346))) template2343 pattern2342)))))) tmp2338) (syntax-violation #f "source expression failed to match any pattern" tmp2337))) ($sc-dispatch tmp2337 (quote (any each-any . #(each ((any . any) any))))))) x2336))) (install-global-transformer (quote let*) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if (if tmp2349 (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (andmap identifier? x2351)) tmp2349) #f) (apply (lambda (let*2356 x2357 v2358 e12359 e22360) (let f2361 ((bindings2362 (map list x2357 v2358))) (if (null? bindings2362) (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"))) (hygiene guile))) (cons (quote ()) (cons e12359 e22360))) ((lambda (tmp2366) ((lambda (tmp2367) (if tmp2367 (apply (lambda (body2368 binding2369) (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"))) (hygiene guile))) (list binding2369) body2368)) tmp2367) (syntax-violation #f "source expression failed to match any pattern" tmp2366))) ($sc-dispatch tmp2366 (quote (any any))))) (list (f2361 (cdr bindings2362)) (car bindings2362)))))) tmp2349) (syntax-violation #f "source expression failed to match any pattern" tmp2348))) ($sc-dispatch tmp2348 (quote (any #(each (any any)) any . each-any))))) x2347))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 00ce0b9b1..0af35dca9 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1167,8 +1167,8 @@ (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap e w s mod))) ((displaced-lexical) - (syntax-violation #f (source-wrap e w s mod) - "reference to identifier outside its scope")) + (syntax-violation #f "reference to identifier outside its scope" + (source-wrap e w s mod))) (else (syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))) -- cgit v1.2.3 From 3d5f3091e100550052abc698e980b3e86cc01b65 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Apr 2009 21:19:23 +0200 Subject: first-class macro representation (no bits on variables) * libguile/macros.c (scm_macro_p): Update docs. * module/ice-9/boot-9.scm (module-define!, module-ref): Define pre-boot forms of these functions as well. I suspect module-add! can go soon. (module-lookup-keyword, module-define-keyword!) (module-undefine-keyword!) Remove these. * module/ice-9/psyntax-pp.scm: Regenerate. Notice the difference? * module/ice-9/psyntax.scm (put-global-definition-hook) (get-global-definition-hook): Rework to expect first-class macros. Heh heh. (remove-global-definition-hook): Pleasantly, this hook can go away. (chi-install-global): Terrorism to generate the right kind of output -- will clean up. (chi-top): Unify definition handling for all kinds of values. --- libguile/macros.c | 4 ++-- module/ice-9/boot-9.scm | 35 ++++++++-------------------- module/ice-9/psyntax-pp.scm | 22 +++++++++--------- module/ice-9/psyntax.scm | 56 ++++++++++++++++++++++++++++++++------------- 4 files changed, 63 insertions(+), 54 deletions(-) (limited to 'libguile') diff --git a/libguile/macros.c b/libguile/macros.c index 535f3e050..ca3e83e29 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -224,8 +224,8 @@ SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0 SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, (SCM obj), - "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n" - "syntax transformer.") + "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n" + "syntax transformer, or a syntax-case macro.") #define FUNC_NAME s_scm_macro_p { return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj)); diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 078801cf7..c12dc967b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -140,6 +140,16 @@ '(guile)) (define (module-add! module sym var) (hashq-set! (%get-pre-modules-obarray) sym var)) +(define (module-define! module sym val) + (let ((v (hashq-ref (%get-pre-modules-obarray) sym))) + (if v + (variable-set! v val) + (hashq-set! (%get-pre-modules-obarray) sym + (make-variable val))))) +(define (module-ref module sym) + (let ((v (module-variable module sym))) + (if v (variable-ref v) (error "badness!" (pk module) (pk sym))))) + (define (make-module-ref mod var kind) (case kind ((public) (if mod `(@ ,mod ,var) var)) @@ -156,31 +166,6 @@ (define (resolve-module . args) #f) -;;; Here we use "keyword" in the sense that R6RS uses it, as in "a -;;; definition may be a keyword definition or a variable definition". -;;; Keywords are syntactic bindings; variables are value bindings. -(define (module-define-keyword! mod sym type val) - (let ((v (or (module-local-variable mod sym) - (let ((v (make-undefined-variable))) - (module-add! mod sym v) - v)))) - (variable-set! v - (if (and (variable-bound? v) (macro? (variable-ref v))) - (make-extended-syncase-macro (variable-ref v) type val) - (make-syncase-macro type val))) - (set-object-property! v '*sc-expander* (cons type val)))) - -(define (module-lookup-keyword mod sym) - (let ((v (module-variable mod sym))) - (and v (object-property v '*sc-expander*)))) - -(define (module-undefine-keyword! mod sym) - (let ((v (module-local-variable mod sym))) - (if v - (let ((p (assq '*sc-expander* (object-properties v)))) - ;; probably should unbind the variable too - (set-object-properties! v (delq p (object-properties v))))))) - ;;; API provided by psyntax (define syntax-violation #f) (define datum->syntax #f) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 99510b892..5cb5213d5 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (void) -(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339 vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339) (lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340) w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null? vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338 (syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341 (syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338 (annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339 ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if (syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if (annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym (symbol->string (annotation-expression id1343)))) (build-annotated1060 #f (gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if (memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and (pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f) x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130 (syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair? x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and (eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349)))) ((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353) (cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1354)) (set-car! new1354 (strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129 (cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector? x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357 (- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355 i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051 i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and (nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda () (build-annotated1060 #f (list (build-annotated1060 #f (quote void)))))) (eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361 (local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361 (syntax-violation #f "nonprocedure transformer" p1361))))) (chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368) ((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372 val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108 ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let ((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100 ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077 labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382 (macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367) mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda (_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112 e1363 w1365 s1366 mod1367))) tmp1369))) ($sc-dispatch tmp1369 (quote (any #(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda (e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393) ((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397 e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394) #f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124 e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392)) tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407) (let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131 ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407) e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100 ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413 (apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132 ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation (quote lambda) "invalid parameter list" e1386) (let ((labels1418 (gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417))) (k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419))) (if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421) ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386 (extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100 old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424) (syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) ($sc-dispatch tmp1393 (quote (any any . each-any)))))) ($sc-dispatch tmp1393 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1393 (quote (any any any . each-any))))) c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429) (let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let ((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let ((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087 w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111 x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ())) (vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if (null? body1434) (syntax-violation #f "no expressions in body" outer-form1426) (let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values (lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429)) (lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443)) (if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446 mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450))) (begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452 vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons (cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote (define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448)) (label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453 label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454 labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111 e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form))) ((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458) (parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434) (cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456) (syntax-violation #f "source expression failed to match any pattern" tmp1455))) ($sc-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote (local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447 mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467 ((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463 (wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435 labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435) (build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f) (r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq? (car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if (eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin (set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476 (quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476)))) (loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430 (extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (())) mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122 (lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec ((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons (rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488 (syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490 (wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490))) (syntax-object-module1070 x1486)) (make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490))) (let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene) (module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let ((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set! v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487)) (doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111 e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121 (lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda (tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500 (cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501)) e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any pattern" tmp1502))) ($sc-dispatch tmp1502 (quote (any . each-any))))) e1497))) (chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let ((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060 s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509 e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref))) (call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517) (build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516 (car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (global-call))) (chi-application1121 (build-annotated1060 (source-annotation1074 (car e1510)) (if (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061 s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if (memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514 (make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call))) (chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518) ((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522) (chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519) (syntax-violation #f "source expression failed to match any pattern" tmp1518))) ($sc-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515 (quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512 s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form))) ((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527 e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if (memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511 w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source expression failed to match any pattern" tmp1524))) ($sc-dispatch tmp1524 (quote (any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1112 e1510 w1512 s1513 mod1514)) (syntax-violation #f "unexpected syntax" (source-wrap1112 e1510 w1512 s1513 mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536) (call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536)) (lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537 value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543 r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda () (syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557 e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote (begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda (_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda (_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559 s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any . each-any)))))) ($sc-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562 (quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559 s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575) (chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if (memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582 (chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond ((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e) (quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load)) mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054 (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval)) mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577) (syntax-violation #f "source expression failed to match any pattern" tmp1576))) ($sc-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557 w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589 (chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588 (quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin (if (memq (quote eval) esew1547) (top-level-eval-hook1054 (chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561)) (chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591 (id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075 (lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593 (quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1558 (wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595 (build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596 (chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561)) x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601 mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599))) (let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605 (binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote (lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599 s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if (id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let ((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607) (syntax-object-module1070 first1607)) mod1602)))) (let ((type1610 (binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote (lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call) n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro))) (syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611 (quote (core external-macro module-ref))) (values type1610 (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define))) ((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614 name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617 name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600 mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621 name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108 (lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627 args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599 mod1602) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628 (cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620) ((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083 name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote define-form) (wrap1111 name1636 w1599 mod1602) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600 mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any pattern" tmp1612))) ($sc-dispatch tmp1612 (quote (any any)))))) ($sc-dispatch tmp1612 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1612 (quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax))) ((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639 name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642 name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599 s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to match any pattern" tmp1637))) ($sc-dispatch tmp1637 (quote (any any any))))) e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values (quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597) (syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102 w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070 e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602)) ((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600 mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602))))) (chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648 ((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null? when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651 (car when-list1649))) (cond ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile)) ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load)) ((free-id=?1106 x1651 (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651 w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652 e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote install-global-transformer)) (build-data1061 #f name1652) e1653)))) (chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659 mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663 r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if (null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663 w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662) r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669 r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675 body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675) (quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678))) (cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678)))))))) (source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682 (make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda (x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null? (wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684) (make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102 w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684))) ((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686))))) (bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or (bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690 ((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691))))))) (valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694 ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda (i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696)) (and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation? e1697) (annotation-expression e1697) e1697)) (let ((e1698 (syntax-object-expression1068 j1696))) (if (annotation? e1698) (annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086 (syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069 j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation? e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701 j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067 x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704) (annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if (syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if (annotation? e1706) (annotation-expression e1706) e1706)))) (eq? (id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (()))))))) (id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda (sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722 (vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724 n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref (ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref (ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724 1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727 symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0)) (cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727)) ((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref (ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094 ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732 1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null? subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq? fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735)) (let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737) (search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736) (search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736))))))))) (cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738) x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742 (syntax-object-expression1068 id1707))) (if (annotation? e1742) (annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069 id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708) (wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087 w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740)))))) ((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation? e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda () (search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753) (or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753)))))) (join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755))) (join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756)) (s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757 (make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087 w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757)) (smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101 (lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761)))) (make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762) w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765 (list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let ((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766))) (begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770)) (call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764)) (lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771 symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770) (fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768 labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda (ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774 (cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation? e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092 ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086 (syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774))) (set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094 ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f (wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778))))) (set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3 update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set! x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784) (vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785) (vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786 2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091 (lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq? (vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda (symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789 marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792) (quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792)))))) (gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086 car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if (syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068 x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795)) (join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069 x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796) (annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083 (lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol? (let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798) (annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol? (annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799) (and (syntax-object?1067 x1799) (symbol? (let ((e1800 (syntax-object-expression1068 x1799))) (if (annotation? e1800) (annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801 sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803))) (lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr) ((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda (r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807))) (macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809 vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical) (car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813 r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814))))) (binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda (x1815) (cond ((annotation? x1815) (annotation-source x1815)) ((syntax-object?1067 x1815) (source-annotation1074 (syntax-object-expression1068 x1815))) (else #f)))) (set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3 update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819) (vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda (x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070 (lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823) (vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824) (vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825) (= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object))))) (make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector (quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065 (lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830) (build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list (quote letrec) (map list vars1830 val-exps1831) body-exp1832))))) (build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if (null? vars1834) (build-annotated1060 src1833 body-exp1836) (build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837 vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060 src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841 exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842))))) (build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844) (not (vector? exp1844))) (build-annotated1060 src1843 exp1844) (build-annotated1060 src1843 (list (quote quote) exp1844))))) (build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not (annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846))) (get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and (not module1848) (current-module)) (warn "module system is booted, we should have a module" symbol1847)) (module-lookup-keyword (if module1848 (resolve-module (cdr module1848)) (current-module)) symbol1847)))) (remove-global-definition-hook1058 (lambda (symbol1849) (module-undefine-keyword! (current-module) symbol1849))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (module-define-keyword! (current-module) symbol1850 type1851 val1852))) (error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s" why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857) (primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda (x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1081 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1081 (quote local-syntax) (quote let-syntax) #f) (global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861 w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866 (apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108 var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877) (let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874))) (begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075 (lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874 names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862 s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886 (macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro) (eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864) mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860 w1862 s1863 mod1864))) tmp1865))) ($sc-dispatch tmp1865 (quote (any #(each (any any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda (tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893 (strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895))) ($sc-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if (memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909 (quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908) (regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911) (cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq? (car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911)))) (else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912 y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912 y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if (memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ())) (list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916 (quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons) x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919 (map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920)) ((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922) formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive) (car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda (x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote map) (cons (list (quote lambda) formals1919 e1917) actuals1920))))))) (gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote (primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda (src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928 maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928 (fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932) (let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930)) outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938 ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105 e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if (eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let ((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values (list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936) (syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list (quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if (if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947) #f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937 maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955)) tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959) (k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935 x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964 maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply (lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda (dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda () (k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values (gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda (_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values (lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905 x1978 y1976) maps1979)))))) tmp1966))) ($sc-dispatch tmp1966 (quote (any . any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981 y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937 maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values (lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940)) (lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986)))))) tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989) (call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937 maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values (gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list (quote quote) e1936) maps1938)) tmp1946))) ($sc-dispatch tmp1946 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1946 (quote (any . any)))))) ($sc-dispatch tmp1946 (quote (any any . any)))))) ($sc-dispatch tmp1946 (quote (any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999 (source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda (tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda () (gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda (e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006) (syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000))) ($sc-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda (tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015) (chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015 r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018) (build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013) (syntax-violation #f "source expression failed to match any pattern" tmp2012))) ($sc-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023 mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not (valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029 w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021))) (constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021 w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031 s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037 mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda (_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda (tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054 e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058 val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038 build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049) ((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034 w2036 s2037 mod2038))) tmp2039))) ($sc-dispatch tmp2039 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2039 (quote (any #(each (any any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda (tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let ((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation (quote letrec) "duplicate bound variable" e2066) (let ((labels2080 (gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let ((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083 (extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069 new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075) (chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070) r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071))) ($sc-dispatch tmp2071 (quote (any #(each (any any)) any . each-any))))) e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089 w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094 (apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply (lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090 mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080 n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104 (quote (lexical))) (build-annotated1060 s2091 (list (quote set!) (binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global))) (build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare))) val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092)) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106 head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117 head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112 ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote (module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092))) (call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda (id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120 (make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120 id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail 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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090 mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092))) tmp2093))) ($sc-dispatch tmp2093 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081 (quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda (tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132 id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126) (syntax-violation #f "source expression failed to match any pattern" tmp2125))) ($sc-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081 (quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda (tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143 id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137) (syntax-violation #f "source expression failed to match any pattern" tmp2136))) ($sc-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081 (quote begin) (quote begin) (quote ())) (global-extend1081 (quote define) (quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153 mod2154) (if (null? clauses2152) (build-annotated1060 #f (list (build-annotated1060 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156 (apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda (x2159) (not (free-id=?1106 pat2157 x2159))) (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 remove-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) (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" "i")) #(ribcage (define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let ((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157) labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda (tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165) (gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164 exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2152))) tmp2155))) ($sc-dispatch tmp2155 (quote (any any any)))))) ($sc-dispatch tmp2155 (quote (any any))))) (car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170 pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda () (convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not (distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda (x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131 (quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178))) (build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181) (if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182) (build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147 pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180))) ($sc-dispatch tmp2180 (quote #(atom #t))))) fender2172) (build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174) (gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq? p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote $sc-dispatch)) x2167 (build-data1061 #f p2175))))))))))))) (build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let ((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let ((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131 ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply)) (build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184 (extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186) (make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185)))))) (convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197 pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if (bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197) ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda (tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203) (ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205) (call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda (p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector (quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply (lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198 ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209 n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211) ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values (quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda (x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda (p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216) ((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (())))) ids2199)) tmp2200))) ($sc-dispatch tmp2200 (quote #(vector each-any)))))) ($sc-dispatch tmp2200 (quote ()))))) ($sc-dispatch tmp2200 (quote (any . any)))))) ($sc-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222 r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225 mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda (_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234) (not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp)))) (build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda) (list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233 r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226)))) (syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229) (syntax-violation #f "source expression failed to match any pattern" tmp2228))) ($sc-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set! sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241) (if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241) (chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and (pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118 x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if (or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247 datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247) #f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (()))))) (set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if (not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f)) ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255 x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not (nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=? (lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082 x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259))) (let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258)))) (set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261) (begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266) (string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if (not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269) (strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if who2264 (cons who2264 tail2268) tail2268)) #f)))) (set! install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272 sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax) "invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273)) (error-hook1056 (quote define-syntax) "invalid argument" x2273))) (global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda (e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279) (match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if (annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102 w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279))) (else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285) (annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283))))) (match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and (null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286) (car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290) mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286 w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292 (vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286) (match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286 (vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295 l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286) (free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if (memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286 w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286) (match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289 mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296) r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296) (match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296 (quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296 0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1) r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote (vector))) (match-empty2276 (vector-ref p2296 1) r2297))))))))) (match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299) (match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair? e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302 (cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ())) ((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068 e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else #f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation? e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306)) ((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ()) mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304 w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303) (quote ())) ((syntax-object?1067 e2303) (match-each2274 (syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305 (syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else #f))))) (set! $sc-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any)) (list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311 (syntax-object-expression1068 e2309))) (if (annotation? e2311) (annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309) (quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312 e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310 (quote (())) (quote ()) #f)))))))) -(install-global-transformer (quote with-syntax) (lambda (x2313) ((lambda (tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 e12317 e22318) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12317 e22318))) tmp2315) ((lambda (tmp2320) (if tmp2320 (apply (lambda (_2321 out2322 in2323 e12324 e22325) (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"))) (hygiene guile))) in2323 (quote ()) (list out2322 (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"))) (hygiene guile))) (cons e12324 e22325))))) tmp2320) ((lambda (tmp2327) (if tmp2327 (apply (lambda (_2328 out2329 in2330 e12331 e22332) (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"))) (hygiene guile))) (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"))) (hygiene guile))) in2330) (quote ()) (list out2329 (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"))) (hygiene guile))) (cons e12331 e22332))))) tmp2327) (syntax-violation #f "source expression failed to match any pattern" tmp2314))) ($sc-dispatch tmp2314 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any () any . each-any))))) x2313))) -(install-global-transformer (quote syntax-rules) (lambda (x2336) ((lambda (tmp2337) ((lambda (tmp2338) (if tmp2338 (apply (lambda (_2339 k2340 keyword2341 pattern2342 template2343) (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"))) (hygiene guile))) (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"))) (hygiene guile)))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (cons k2340 (map (lambda (tmp2346 tmp2345) (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"))) (hygiene guile))) tmp2345) (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"))) (hygiene guile))) tmp2346))) template2343 pattern2342)))))) tmp2338) (syntax-violation #f "source expression failed to match any pattern" tmp2337))) ($sc-dispatch tmp2337 (quote (any each-any . #(each ((any . any) any))))))) x2336))) -(install-global-transformer (quote let*) (lambda (x2347) ((lambda (tmp2348) ((lambda (tmp2349) (if (if tmp2349 (apply (lambda (let*2350 x2351 v2352 e12353 e22354) (andmap identifier? x2351)) tmp2349) #f) (apply (lambda (let*2356 x2357 v2358 e12359 e22360) (let f2361 ((bindings2362 (map list x2357 v2358))) (if (null? bindings2362) (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"))) (hygiene guile))) (cons (quote ()) (cons e12359 e22360))) ((lambda (tmp2366) ((lambda (tmp2367) (if tmp2367 (apply (lambda (body2368 binding2369) (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"))) (hygiene guile))) (list binding2369) body2368)) tmp2367) (syntax-violation #f "source expression failed to match any pattern" tmp2366))) ($sc-dispatch tmp2366 (quote (any any))))) (list (f2361 (cdr bindings2362)) (car bindings2362)))))) tmp2349) (syntax-violation #f "source expression failed to match any pattern" tmp2348))) ($sc-dispatch tmp2348 (quote (any #(each (any any)) any . each-any))))) x2347))) -(install-global-transformer (quote do) (lambda (orig-x2370) ((lambda (tmp2371) ((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 var2374 init2375 step2376 e02377 e12378 c2379) ((lambda (tmp2380) ((lambda (tmp2381) (if tmp2381 (apply (lambda (step2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var2374 init2375) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e02377) (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"))) (hygiene guile))) (append c2379 (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"))) (hygiene guile))) step2382))))))) tmp2384) ((lambda (tmp2389) (if tmp2389 (apply (lambda (e12390 e22391) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var2374 init2375) (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"))) (hygiene guile))) e02377 (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"))) (hygiene guile))) (cons e12390 e22391)) (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"))) (hygiene guile))) (append c2379 (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"))) (hygiene guile))) step2382))))))) tmp2389) (syntax-violation #f "source expression failed to match any pattern" tmp2383))) ($sc-dispatch tmp2383 (quote (any . each-any)))))) ($sc-dispatch tmp2383 (quote ())))) e12378)) tmp2381) (syntax-violation #f "source expression failed to match any pattern" tmp2380))) ($sc-dispatch tmp2380 (quote each-any)))) (map (lambda (v2398 s2399) ((lambda (tmp2400) ((lambda (tmp2401) (if tmp2401 (apply (lambda () v2398) tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda (e2403) e2403) tmp2402) ((lambda (_2404) (syntax-violation (quote do) "bad step expression" orig-x2370 s2399)) tmp2400))) ($sc-dispatch tmp2400 (quote (any)))))) ($sc-dispatch tmp2400 (quote ())))) s2399)) var2374 step2376))) tmp2372) (syntax-violation #f "source expression failed to match any pattern" tmp2371))) ($sc-dispatch tmp2371 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2370))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons2407 (lambda (x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda (x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda (dy2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda (dx2422) (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"))) (hygiene guile))) (cons dx2422 dy2419))) tmp2421) ((lambda (_2423) (if (null? dy2419) (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"))) (hygiene guile))) x2415) (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"))) (hygiene guile))) x2415 y2416))) tmp2420))) ($sc-dispatch tmp2420 (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"))) (hygiene guile))) any))))) x2415)) tmp2418) ((lambda (tmp2424) (if tmp2424 (apply (lambda (stuff2425) (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"))) (hygiene guile))) (cons x2415 stuff2425))) tmp2424) ((lambda (else2426) (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"))) (hygiene guile))) x2415 y2416)) tmp2417))) ($sc-dispatch tmp2417 (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"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2417 (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"))) (hygiene guile))) any))))) y2416)) tmp2414) (syntax-violation #f "source expression failed to match any pattern" tmp2413))) ($sc-dispatch tmp2413 (quote (any any))))) (list x2411 y2412)))) (quasiappend2408 (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430) (if tmp2430 (apply (lambda (x2431 y2432) ((lambda (tmp2433) ((lambda (tmp2434) (if tmp2434 (apply (lambda () x2431) tmp2434) ((lambda (_2435) (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"))) (hygiene guile))) x2431 y2432)) tmp2433))) ($sc-dispatch tmp2433 (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"))) (hygiene guile))) ()))))) y2432)) tmp2430) (syntax-violation #f "source expression failed to match any pattern" tmp2429))) ($sc-dispatch tmp2429 (quote (any any))))) (list x2427 y2428)))) (quasivector2409 (lambda (x2436) ((lambda (tmp2437) ((lambda (x2438) ((lambda (tmp2439) ((lambda (tmp2440) (if tmp2440 (apply (lambda (x2441) (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"))) (hygiene guile))) (list->vector x2441))) tmp2440) ((lambda (tmp2443) (if tmp2443 (apply (lambda (x2444) (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"))) (hygiene guile))) x2444)) tmp2443) ((lambda (_2446) (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"))) (hygiene guile))) x2438)) tmp2439))) ($sc-dispatch tmp2439 (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"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2439 (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"))) (hygiene guile))) each-any))))) x2438)) tmp2437)) x2436))) (quasi2410 (lambda (p2447 lev2448) ((lambda (tmp2449) ((lambda (tmp2450) (if tmp2450 (apply (lambda (p2451) (if (= lev2448 0) p2451 (quasicons2407 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2410 (list p2451) (- lev2448 1))))) tmp2450) ((lambda (tmp2452) (if tmp2452 (apply (lambda (p2453 q2454) (if (= lev2448 0) (quasiappend2408 p2453 (quasi2410 q2454 lev2448)) (quasicons2407 (quasicons2407 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2410 (list p2453) (- lev2448 1))) (quasi2410 q2454 lev2448)))) tmp2452) ((lambda (tmp2455) (if tmp2455 (apply (lambda (p2456) (quasicons2407 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2410 (list p2456) (+ lev2448 1)))) tmp2455) ((lambda (tmp2457) (if tmp2457 (apply (lambda (p2458 q2459) (quasicons2407 (quasi2410 p2458 lev2448) (quasi2410 q2459 lev2448))) tmp2457) ((lambda (tmp2460) (if tmp2460 (apply (lambda (x2461) (quasivector2409 (quasi2410 x2461 lev2448))) tmp2460) ((lambda (p2463) (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"))) (hygiene guile))) p2463)) tmp2449))) ($sc-dispatch tmp2449 (quote #(vector each-any)))))) ($sc-dispatch tmp2449 (quote (any . any)))))) ($sc-dispatch tmp2449 (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"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2449 (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"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2449 (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"))) (hygiene guile))) any))))) p2447)))) (lambda (x2464) ((lambda (tmp2465) ((lambda (tmp2466) (if tmp2466 (apply (lambda (_2467 e2468) (quasi2410 e2468 0)) tmp2466) (syntax-violation #f "source expression failed to match any pattern" tmp2465))) ($sc-dispatch tmp2465 (quote (any any))))) x2464)))) -(install-global-transformer (quote include) (lambda (x2469) (letrec ((read-file2470 (lambda (fn2471 k2472) (let ((p2473 (open-input-file fn2471))) (let f2474 ((x2475 (read p2473))) (if (eof-object? x2475) (begin (close-input-port p2473) (quote ())) (cons (datum->syntax k2472 x2475) (f2474 (read p2473))))))))) ((lambda (tmp2476) ((lambda (tmp2477) (if tmp2477 (apply (lambda (k2478 filename2479) (let ((fn2480 (syntax->datum filename2479))) ((lambda (tmp2481) ((lambda (tmp2482) (if tmp2482 (apply (lambda (exp2483) (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"))) (hygiene guile))) exp2483)) tmp2482) (syntax-violation #f "source expression failed to match any pattern" tmp2481))) ($sc-dispatch tmp2481 (quote each-any)))) (read-file2470 fn2480 k2478)))) tmp2477) (syntax-violation #f "source expression failed to match any pattern" tmp2476))) ($sc-dispatch tmp2476 (quote (any any))))) x2469)))) -(install-global-transformer (quote unquote) (lambda (x2485) ((lambda (tmp2486) ((lambda (tmp2487) (if tmp2487 (apply (lambda (_2488 e2489) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2489))) tmp2487) (syntax-violation #f "source expression failed to match any pattern" tmp2486))) ($sc-dispatch tmp2486 (quote (any any))))) x2485))) -(install-global-transformer (quote unquote-splicing) (lambda (x2490) ((lambda (tmp2491) ((lambda (tmp2492) (if tmp2492 (apply (lambda (_2493 e2494) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2494))) tmp2492) (syntax-violation #f "source expression failed to match any pattern" tmp2491))) ($sc-dispatch tmp2491 (quote (any any))))) x2490))) -(install-global-transformer (quote case) (lambda (x2495) ((lambda (tmp2496) ((lambda (tmp2497) (if tmp2497 (apply (lambda (_2498 e2499 m12500 m22501) ((lambda (tmp2502) ((lambda (body2503) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e2499)) body2503)) tmp2502)) (let f2504 ((clause2505 m12500) (clauses2506 m22501)) (if (null? clauses2506) ((lambda (tmp2508) ((lambda (tmp2509) (if tmp2509 (apply (lambda (e12510 e22511) (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"))) (hygiene guile))) (cons e12510 e22511))) tmp2509) ((lambda (tmp2513) (if tmp2513 (apply (lambda (k2514 e12515 e22516) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k2514)) (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"))) (hygiene guile))) (cons e12515 e22516)))) tmp2513) ((lambda (_2519) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2508))) ($sc-dispatch tmp2508 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2508 (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"))) (hygiene guile))) any . each-any))))) clause2505) ((lambda (tmp2520) ((lambda (rest2521) ((lambda (tmp2522) ((lambda (tmp2523) (if tmp2523 (apply (lambda (k2524 e12525 e22526) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k2524)) (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"))) (hygiene guile))) (cons e12525 e22526)) rest2521)) tmp2523) ((lambda (_2529) (syntax-violation (quote case) "bad clause" x2495 clause2505)) tmp2522))) ($sc-dispatch tmp2522 (quote (each-any any . each-any))))) clause2505)) tmp2520)) (f2504 (car clauses2506) (cdr clauses2506))))))) tmp2497) (syntax-violation #f "source expression failed to match any pattern" tmp2496))) ($sc-dispatch tmp2496 (quote (any any any . each-any))))) x2495))) -(install-global-transformer (quote identifier-syntax) (lambda (x2530) ((lambda (tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (_2533 e2534) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2534)) (list (cons _2533 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2534 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2532) (syntax-violation #f "source expression failed to match any pattern" tmp2531))) ($sc-dispatch tmp2531 (quote (any any))))) x2530))) +(letrec ((lambda-var-list1131 (lambda (vars1336) (let lvl1337 ((vars1338 vars1336) (ls1339 (quote ())) (w1340 (quote (())))) (cond ((pair? vars1338) (lvl1337 (cdr vars1338) (cons (wrap1110 (car vars1338) w1340 #f) ls1339) w1340)) ((id?1082 vars1338) (cons (wrap1110 vars1338 w1340 #f) ls1339)) ((null? vars1338) ls1339) ((syntax-object?1066 vars1338) (lvl1337 (syntax-object-expression1067 vars1338) ls1339 (join-wraps1101 w1340 (syntax-object-wrap1068 vars1338)))) ((annotation? vars1338) (lvl1337 (annotation-expression vars1338) ls1339 w1340)) (else (cons vars1338 ls1339)))))) (gen-var1130 (lambda (id1341) (let ((id1342 (if (syntax-object?1066 id1341) (syntax-object-expression1067 id1341) id1341))) (if (annotation? id1342) (build-annotated1059 (annotation-source id1342) (gensym (symbol->string (annotation-expression id1342)))) (build-annotated1059 #f (gensym (symbol->string id1342))))))) (strip1129 (lambda (x1343 w1344) (if (memq (quote top) (wrap-marks1085 w1344)) (if (or (annotation? x1343) (and (pair? x1343) (annotation? (car x1343)))) (strip-annotation1128 x1343 #f) x1343) (let f1345 ((x1346 x1343)) (cond ((syntax-object?1066 x1346) (strip1129 (syntax-object-expression1067 x1346) (syntax-object-wrap1068 x1346))) ((pair? x1346) (let ((a1347 (f1345 (car x1346))) (d1348 (f1345 (cdr x1346)))) (if (and (eq? a1347 (car x1346)) (eq? d1348 (cdr x1346))) x1346 (cons a1347 d1348)))) ((vector? x1346) (let ((old1349 (vector->list x1346))) (let ((new1350 (map f1345 old1349))) (if (andmap eq? old1349 new1350) x1346 (list->vector new1350))))) (else x1346)))))) (strip-annotation1128 (lambda (x1351 parent1352) (cond ((pair? x1351) (let ((new1353 (cons #f #f))) (begin (if parent1352 (set-annotation-stripped! parent1352 new1353)) (set-car! new1353 (strip-annotation1128 (car x1351) #f)) (set-cdr! new1353 (strip-annotation1128 (cdr x1351) #f)) new1353))) ((annotation? x1351) (or (annotation-stripped x1351) (strip-annotation1128 (annotation-expression x1351) x1351))) ((vector? x1351) (let ((new1354 (make-vector (vector-length x1351)))) (begin (if parent1352 (set-annotation-stripped! parent1352 new1354)) (let loop1355 ((i1356 (- (vector-length x1351) 1))) (unless (fx<1053 i1356 0) (vector-set! new1354 i1356 (strip-annotation1128 (vector-ref x1351 i1356) #f)) (loop1355 (fx-1051 i1356 1)))) new1354))) (else x1351)))) (ellipsis?1127 (lambda (x1357) (and (nonsymbol-id?1081 x1357) (free-id=?1105 x1357 (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"))) (hygiene guile))))))) (chi-void1126 (lambda () (build-annotated1059 #f (list (build-annotated1059 #f (quote void)))))) (eval-local-transformer1125 (lambda (expanded1358 mod1359) (let ((p1360 (local-eval-hook1055 expanded1358 mod1359))) (if (procedure? p1360) p1360 (syntax-violation #f "nonprocedure transformer" p1360))))) (chi-local-syntax1124 (lambda (rec?1361 e1362 r1363 w1364 s1365 mod1366 k1367) ((lambda (tmp1368) ((lambda (tmp1369) (if tmp1369 (apply (lambda (_1370 id1371 val1372 e11373 e21374) (let ((ids1375 id1371)) (if (not (valid-bound-ids?1107 ids1375)) (syntax-violation #f "duplicate bound keyword" e1362) (let ((labels1377 (gen-labels1088 ids1375))) (let ((new-w1378 (make-binding-wrap1099 ids1375 labels1377 w1364))) (k1367 (cons e11373 e21374) (extend-env1076 labels1377 (let ((w1380 (if rec?1361 new-w1378 w1364)) (trans-r1381 (macros-only-env1078 r1363))) (map (lambda (x1382) (cons (quote macro) (eval-local-transformer1125 (chi1118 x1382 trans-r1381 w1380 mod1366) mod1366))) val1372)) r1363) new-w1378 s1365 mod1366)))))) tmp1369) ((lambda (_1384) (syntax-violation #f "bad local syntax definition" (source-wrap1111 e1362 w1364 s1365 mod1366))) tmp1368))) ($sc-dispatch tmp1368 (quote (any #(each (any any)) any . each-any))))) e1362))) (chi-lambda-clause1123 (lambda (e1385 docstring1386 c1387 r1388 w1389 mod1390 k1391) ((lambda (tmp1392) ((lambda (tmp1393) (if (if tmp1393 (apply (lambda (args1394 doc1395 e11396 e21397) (and (string? (syntax->datum doc1395)) (not docstring1386))) tmp1393) #f) (apply (lambda (args1398 doc1399 e11400 e21401) (chi-lambda-clause1123 e1385 doc1399 (cons args1398 (cons e11400 e21401)) r1388 w1389 mod1390 k1391)) tmp1393) ((lambda (tmp1403) (if tmp1403 (apply (lambda (id1404 e11405 e21406) (let ((ids1407 id1404)) (if (not (valid-bound-ids?1107 ids1407)) (syntax-violation (quote lambda) "invalid parameter list" e1385) (let ((labels1409 (gen-labels1088 ids1407)) (new-vars1410 (map gen-var1130 ids1407))) (k1391 new-vars1410 docstring1386 (chi-body1122 (cons e11405 e21406) e1385 (extend-var-env1077 labels1409 new-vars1410 r1388) (make-binding-wrap1099 ids1407 labels1409 w1389) mod1390)))))) tmp1403) ((lambda (tmp1412) (if tmp1412 (apply (lambda (ids1413 e11414 e21415) (let ((old-ids1416 (lambda-var-list1131 ids1413))) (if (not (valid-bound-ids?1107 old-ids1416)) (syntax-violation (quote lambda) "invalid parameter list" e1385) (let ((labels1417 (gen-labels1088 old-ids1416)) (new-vars1418 (map gen-var1130 old-ids1416))) (k1391 (let f1419 ((ls11420 (cdr new-vars1418)) (ls21421 (car new-vars1418))) (if (null? ls11420) ls21421 (f1419 (cdr ls11420) (cons (car ls11420) ls21421)))) docstring1386 (chi-body1122 (cons e11414 e21415) e1385 (extend-var-env1077 labels1417 new-vars1418 r1388) (make-binding-wrap1099 old-ids1416 labels1417 w1389) mod1390)))))) tmp1412) ((lambda (_1423) (syntax-violation (quote lambda) "bad lambda" e1385)) tmp1392))) ($sc-dispatch tmp1392 (quote (any any . each-any)))))) ($sc-dispatch tmp1392 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1392 (quote (any any any . each-any))))) c1387))) (chi-body1122 (lambda (body1424 outer-form1425 r1426 w1427 mod1428) (let ((r1429 (cons (quote ("placeholder" placeholder)) r1426))) (let ((ribcage1430 (make-ribcage1089 (quote ()) (quote ()) (quote ())))) (let ((w1431 (make-wrap1084 (wrap-marks1085 w1427) (cons ribcage1430 (wrap-subst1086 w1427))))) (let parse1432 ((body1433 (map (lambda (x1439) (cons r1429 (wrap1110 x1439 w1431 mod1428))) body1424)) (ids1434 (quote ())) (labels1435 (quote ())) (vars1436 (quote ())) (vals1437 (quote ())) (bindings1438 (quote ()))) (if (null? body1433) (syntax-violation #f "no expressions in body" outer-form1425) (let ((e1440 (cdar body1433)) (er1441 (caar body1433))) (call-with-values (lambda () (syntax-type1116 e1440 er1441 (quote (())) #f ribcage1430 mod1428)) (lambda (type1442 value1443 e1444 w1445 s1446 mod1447) (let ((t1448 type1442)) (if (memv t1448 (quote (define-form))) (let ((id1449 (wrap1110 value1443 w1445 mod1447)) (label1450 (gen-label1087))) (let ((var1451 (gen-var1130 id1449))) (begin (extend-ribcage!1098 ribcage1430 id1449 label1450) (parse1432 (cdr body1433) (cons id1449 ids1434) (cons label1450 labels1435) (cons var1451 vars1436) (cons (cons er1441 (wrap1110 e1444 w1445 mod1447)) vals1437) (cons (cons (quote lexical) var1451) bindings1438))))) (if (memv t1448 (quote (define-syntax-form))) (let ((id1452 (wrap1110 value1443 w1445 mod1447)) (label1453 (gen-label1087))) (begin (extend-ribcage!1098 ribcage1430 id1452 label1453) (parse1432 (cdr body1433) (cons id1452 ids1434) (cons label1453 labels1435) vars1436 vals1437 (cons (cons (quote macro) (cons er1441 (wrap1110 e1444 w1445 mod1447))) bindings1438)))) (if (memv t1448 (quote (begin-form))) ((lambda (tmp1454) ((lambda (tmp1455) (if tmp1455 (apply (lambda (_1456 e11457) (parse1432 (let f1458 ((forms1459 e11457)) (if (null? forms1459) (cdr body1433) (cons (cons er1441 (wrap1110 (car forms1459) w1445 mod1447)) (f1458 (cdr forms1459))))) ids1434 labels1435 vars1436 vals1437 bindings1438)) tmp1455) (syntax-violation #f "source expression failed to match any pattern" tmp1454))) ($sc-dispatch tmp1454 (quote (any . each-any))))) e1444) (if (memv t1448 (quote (local-syntax-form))) (chi-local-syntax1124 value1443 e1444 er1441 w1445 s1446 mod1447 (lambda (forms1461 er1462 w1463 s1464 mod1465) (parse1432 (let f1466 ((forms1467 forms1461)) (if (null? forms1467) (cdr body1433) (cons (cons er1462 (wrap1110 (car forms1467) w1463 mod1465)) (f1466 (cdr forms1467))))) ids1434 labels1435 vars1436 vals1437 bindings1438))) (if (null? ids1434) (build-sequence1061 #f (map (lambda (x1468) (chi1118 (cdr x1468) (car x1468) (quote (())) mod1447)) (cons (cons er1441 (source-wrap1111 e1444 w1445 s1446 mod1447)) (cdr body1433)))) (begin (if (not (valid-bound-ids?1107 ids1434)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form1425)) (let loop1469 ((bs1470 bindings1438) (er-cache1471 #f) (r-cache1472 #f)) (if (not (null? bs1470)) (let ((b1473 (car bs1470))) (if (eq? (car b1473) (quote macro)) (let ((er1474 (cadr b1473))) (let ((r-cache1475 (if (eq? er1474 er-cache1471) r-cache1472 (macros-only-env1078 er1474)))) (begin (set-cdr! b1473 (eval-local-transformer1125 (chi1118 (cddr b1473) r-cache1475 (quote (())) mod1447) mod1447)) (loop1469 (cdr bs1470) er1474 r-cache1475)))) (loop1469 (cdr bs1470) er-cache1471 r-cache1472))))) (set-cdr! r1429 (extend-env1076 labels1435 bindings1438 (cdr r1429))) (build-letrec1064 #f vars1436 (map (lambda (x1476) (chi1118 (cdr x1476) (car x1476) (quote (())) mod1447)) vals1437) (build-sequence1061 #f (map (lambda (x1477) (chi1118 (cdr x1477) (car x1477) (quote (())) mod1447)) (cons (cons er1441 (source-wrap1111 e1444 w1445 s1446 mod1447)) (cdr body1433)))))))))))))))))))))) (chi-macro1121 (lambda (p1478 e1479 r1480 w1481 rib1482 mod1483) (letrec ((rebuild-macro-output1484 (lambda (x1485 m1486) (cond ((pair? x1485) (cons (rebuild-macro-output1484 (car x1485) m1486) (rebuild-macro-output1484 (cdr x1485) m1486))) ((syntax-object?1066 x1485) (let ((w1487 (syntax-object-wrap1068 x1485))) (let ((ms1488 (wrap-marks1085 w1487)) (s1489 (wrap-subst1086 w1487))) (if (and (pair? ms1488) (eq? (car ms1488) #f)) (make-syntax-object1065 (syntax-object-expression1067 x1485) (make-wrap1084 (cdr ms1488) (if rib1482 (cons rib1482 (cdr s1489)) (cdr s1489))) (syntax-object-module1069 x1485)) (make-syntax-object1065 (syntax-object-expression1067 x1485) (make-wrap1084 (cons m1486 ms1488) (if rib1482 (cons rib1482 (cons (quote shift) s1489)) (cons (quote shift) s1489))) (let ((pmod1490 (procedure-module p1478))) (if pmod1490 (cons (quote hygiene) (module-name pmod1490)) (quote (hygiene guile))))))))) ((vector? x1485) (let ((n1491 (vector-length x1485))) (let ((v1492 (make-vector n1491))) (let doloop1493 ((i1494 0)) (if (fx=1052 i1494 n1491) v1492 (begin (vector-set! v1492 i1494 (rebuild-macro-output1484 (vector-ref x1485 i1494) m1486)) (doloop1493 (fx+1050 i1494 1)))))))) ((symbol? x1485) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap1111 e1479 w1481 s mod1483) x1485)) (else x1485))))) (rebuild-macro-output1484 (p1478 (wrap1110 e1479 (anti-mark1097 w1481) mod1483)) (string #\m))))) (chi-application1120 (lambda (x1495 e1496 r1497 w1498 s1499 mod1500) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (e01503 e11504) (build-annotated1059 s1499 (cons x1495 (map (lambda (e1505) (chi1118 e1505 r1497 w1498 mod1500)) e11504)))) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote (any . each-any))))) e1496))) (chi-expr1119 (lambda (type1507 value1508 e1509 r1510 w1511 s1512 mod1513) (let ((t1514 type1507)) (if (memv t1514 (quote (lexical))) (build-annotated1059 s1512 value1508) (if (memv t1514 (quote (core external-macro))) (value1508 e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (module-ref))) (call-with-values (lambda () (value1508 e1509)) (lambda (id1515 mod1516) (build-annotated1059 s1512 (if mod1516 (make-module-ref (cdr mod1516) id1515 (car mod1516)) (make-module-ref mod1516 id1515 (quote bare)))))) (if (memv t1514 (quote (lexical-call))) (chi-application1120 (build-annotated1059 (source-annotation1073 (car e1509)) value1508) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (global-call))) (chi-application1120 (build-annotated1059 (source-annotation1073 (car e1509)) (if (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513) (make-module-ref (cdr (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513)) value1508 (car (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513))) (make-module-ref (if (syntax-object?1066 (car e1509)) (syntax-object-module1069 (car e1509)) mod1513) value1508 (quote bare)))) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (constant))) (build-data1060 s1512 (strip1129 (source-wrap1111 e1509 w1511 s1512 mod1513) (quote (())))) (if (memv t1514 (quote (global))) (build-annotated1059 s1512 (if mod1513 (make-module-ref (cdr mod1513) value1508 (car mod1513)) (make-module-ref mod1513 value1508 (quote bare)))) (if (memv t1514 (quote (call))) (chi-application1120 (chi1118 (car e1509) r1510 w1511 mod1513) e1509 r1510 w1511 s1512 mod1513) (if (memv t1514 (quote (begin-form))) ((lambda (tmp1517) ((lambda (tmp1518) (if tmp1518 (apply (lambda (_1519 e11520 e21521) (chi-sequence1112 (cons e11520 e21521) r1510 w1511 s1512 mod1513)) tmp1518) (syntax-violation #f "source expression failed to match any pattern" tmp1517))) ($sc-dispatch tmp1517 (quote (any any . each-any))))) e1509) (if (memv t1514 (quote (local-syntax-form))) (chi-local-syntax1124 value1508 e1509 r1510 w1511 s1512 mod1513 chi-sequence1112) (if (memv t1514 (quote (eval-when-form))) ((lambda (tmp1523) ((lambda (tmp1524) (if tmp1524 (apply (lambda (_1525 x1526 e11527 e21528) (let ((when-list1529 (chi-when-list1115 e1509 x1526 w1511))) (if (memq (quote eval) when-list1529) (chi-sequence1112 (cons e11527 e21528) r1510 w1511 s1512 mod1513) (chi-void1126)))) tmp1524) (syntax-violation #f "source expression failed to match any pattern" tmp1523))) ($sc-dispatch tmp1523 (quote (any each-any any . each-any))))) e1509) (if (memv t1514 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e1509 (wrap1110 value1508 w1511 mod1513)) (if (memv t1514 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap1111 e1509 w1511 s1512 mod1513)) (if (memv t1514 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap1111 e1509 w1511 s1512 mod1513)) (syntax-violation #f "unexpected syntax" (source-wrap1111 e1509 w1511 s1512 mod1513))))))))))))))))))) (chi1118 (lambda (e1532 r1533 w1534 mod1535) (call-with-values (lambda () (syntax-type1116 e1532 r1533 w1534 #f #f mod1535)) (lambda (type1536 value1537 e1538 w1539 s1540 mod1541) (chi-expr1119 type1536 value1537 e1538 r1533 w1539 s1540 mod1541))))) (chi-top1117 (lambda (e1542 r1543 w1544 m1545 esew1546 mod1547) (call-with-values (lambda () (syntax-type1116 e1542 r1543 w1544 #f #f mod1547)) (lambda (type1555 value1556 e1557 w1558 s1559 mod1560) (let ((t1561 type1555)) (if (memv t1561 (quote (begin-form))) ((lambda (tmp1562) ((lambda (tmp1563) (if tmp1563 (apply (lambda (_1564) (chi-void1126)) tmp1563) ((lambda (tmp1565) (if tmp1565 (apply (lambda (_1566 e11567 e21568) (chi-top-sequence1113 (cons e11567 e21568) r1543 w1558 s1559 m1545 esew1546 mod1560)) tmp1565) (syntax-violation #f "source expression failed to match any pattern" tmp1562))) ($sc-dispatch tmp1562 (quote (any any . each-any)))))) ($sc-dispatch tmp1562 (quote (any))))) e1557) (if (memv t1561 (quote (local-syntax-form))) (chi-local-syntax1124 value1556 e1557 r1543 w1558 s1559 mod1560 (lambda (body1570 r1571 w1572 s1573 mod1574) (chi-top-sequence1113 body1570 r1571 w1572 s1573 m1545 esew1546 mod1574))) (if (memv t1561 (quote (eval-when-form))) ((lambda (tmp1575) ((lambda (tmp1576) (if tmp1576 (apply (lambda (_1577 x1578 e11579 e21580) (let ((when-list1581 (chi-when-list1115 e1557 x1578 w1558)) (body1582 (cons e11579 e21580))) (cond ((eq? m1545 (quote e)) (if (memq (quote eval) when-list1581) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote e) (quote (eval)) mod1560) (chi-void1126))) ((memq (quote load) when-list1581) (if (or (memq (quote compile) when-list1581) (and (eq? m1545 (quote c&e)) (memq (quote eval) when-list1581))) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote c&e) (quote (compile load)) mod1560) (if (memq m1545 (quote (c c&e))) (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote c) (quote (load)) mod1560) (chi-void1126)))) ((or (memq (quote compile) when-list1581) (and (eq? m1545 (quote c&e)) (memq (quote eval) when-list1581))) (top-level-eval-hook1054 (chi-top-sequence1113 body1582 r1543 w1558 s1559 (quote e) (quote (eval)) mod1560) mod1560) (chi-void1126)) (else (chi-void1126))))) tmp1576) (syntax-violation #f "source expression failed to match any pattern" tmp1575))) ($sc-dispatch tmp1575 (quote (any each-any any . each-any))))) e1557) (if (memv t1561 (quote (define-syntax-form))) (let ((n1585 (id-var-name1104 value1556 w1558)) (r1586 (macros-only-env1078 r1543))) (let ((t1587 m1545)) (if (memv t1587 (quote (c))) (if (memq (quote compile) esew1546) (let ((e1588 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)))) (begin (top-level-eval-hook1054 e1588 mod1560) (if (memq (quote load) esew1546) e1588 (chi-void1126)))) (if (memq (quote load) esew1546) (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)) (chi-void1126))) (if (memv t1587 (quote (c&e))) (let ((e1589 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)))) (begin (top-level-eval-hook1054 e1589 mod1560) e1589)) (begin (if (memq (quote eval) esew1546) (top-level-eval-hook1054 (chi-install-global1114 n1585 (chi1118 e1557 r1586 w1558 mod1560)) mod1560)) (chi-void1126)))))) (if (memv t1561 (quote (define-form))) (let ((n1590 (id-var-name1104 value1556 w1558))) (let ((type1591 (binding-type1074 (lookup1079 n1590 r1543 mod1560)))) (let ((t1592 type1591)) (if (memv t1592 (quote (global core macro module-ref))) (let ((x1593 (build-annotated1059 s1559 (list (quote define) n1590 (chi1118 e1557 r1543 w1558 mod1560))))) (begin (if (eq? m1545 (quote c&e)) (top-level-eval-hook1054 x1593 mod1560)) x1593)) (if (memv t1592 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e1557 (wrap1110 value1556 w1558 mod1560)) (syntax-violation #f "cannot define keyword at top level" e1557 (wrap1110 value1556 w1558 mod1560))))))) (let ((x1594 (chi-expr1119 type1555 value1556 e1557 r1543 w1558 s1559 mod1560))) (begin (if (eq? m1545 (quote c&e)) (top-level-eval-hook1054 x1594 mod1560)) x1594)))))))))))) (syntax-type1116 (lambda (e1595 r1596 w1597 s1598 rib1599 mod1600) (cond ((symbol? e1595) (let ((n1601 (id-var-name1104 e1595 w1597))) (let ((b1602 (lookup1079 n1601 r1596 mod1600))) (let ((type1603 (binding-type1074 b1602))) (let ((t1604 type1603)) (if (memv t1604 (quote (lexical))) (values type1603 (binding-value1075 b1602) e1595 w1597 s1598 mod1600) (if (memv t1604 (quote (global))) (values type1603 n1601 e1595 w1597 s1598 mod1600) (if (memv t1604 (quote (macro))) (syntax-type1116 (chi-macro1121 (binding-value1075 b1602) e1595 r1596 w1597 rib1599 mod1600) r1596 (quote (())) s1598 rib1599 mod1600) (values type1603 (binding-value1075 b1602) e1595 w1597 s1598 mod1600))))))))) ((pair? e1595) (let ((first1605 (car e1595))) (if (id?1082 first1605) (let ((n1606 (id-var-name1104 first1605 w1597))) (let ((b1607 (lookup1079 n1606 r1596 (or (and (syntax-object?1066 first1605) (syntax-object-module1069 first1605)) mod1600)))) (let ((type1608 (binding-type1074 b1607))) (let ((t1609 type1608)) (if (memv t1609 (quote (lexical))) (values (quote lexical-call) (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (global))) (values (quote global-call) n1606 e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (macro))) (syntax-type1116 (chi-macro1121 (binding-value1075 b1607) e1595 r1596 w1597 rib1599 mod1600) r1596 (quote (())) s1598 rib1599 mod1600) (if (memv t1609 (quote (core external-macro module-ref))) (values type1608 (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1075 b1607) e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (begin))) (values (quote begin-form) #f e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (eval-when))) (values (quote eval-when-form) #f e1595 w1597 s1598 mod1600) (if (memv t1609 (quote (define))) ((lambda (tmp1610) ((lambda (tmp1611) (if (if tmp1611 (apply (lambda (_1612 name1613 val1614) (id?1082 name1613)) tmp1611) #f) (apply (lambda (_1615 name1616 val1617) (values (quote define-form) name1616 val1617 w1597 s1598 mod1600)) tmp1611) ((lambda (tmp1618) (if (if tmp1618 (apply (lambda (_1619 name1620 args1621 e11622 e21623) (and (id?1082 name1620) (valid-bound-ids?1107 (lambda-var-list1131 args1621)))) tmp1618) #f) (apply (lambda (_1624 name1625 args1626 e11627 e21628) (values (quote define-form) (wrap1110 name1625 w1597 mod1600) (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"))) (hygiene guile))) (wrap1110 (cons args1626 (cons e11627 e21628)) w1597 mod1600)) (quote (())) s1598 mod1600)) tmp1618) ((lambda (tmp1630) (if (if tmp1630 (apply (lambda (_1631 name1632) (id?1082 name1632)) tmp1630) #f) (apply (lambda (_1633 name1634) (values (quote define-form) (wrap1110 name1634 w1597 mod1600) (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"))) (hygiene guile)))) (quote (())) s1598 mod1600)) tmp1630) (syntax-violation #f "source expression failed to match any pattern" tmp1610))) ($sc-dispatch tmp1610 (quote (any any)))))) ($sc-dispatch tmp1610 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1610 (quote (any any any))))) e1595) (if (memv t1609 (quote (define-syntax))) ((lambda (tmp1635) ((lambda (tmp1636) (if (if tmp1636 (apply (lambda (_1637 name1638 val1639) (id?1082 name1638)) tmp1636) #f) (apply (lambda (_1640 name1641 val1642) (values (quote define-syntax-form) name1641 val1642 w1597 s1598 mod1600)) tmp1636) (syntax-violation #f "source expression failed to match any pattern" tmp1635))) ($sc-dispatch tmp1635 (quote (any any any))))) e1595) (values (quote call) #f e1595 w1597 s1598 mod1600)))))))))))))) (values (quote call) #f e1595 w1597 s1598 mod1600)))) ((syntax-object?1066 e1595) (syntax-type1116 (syntax-object-expression1067 e1595) r1596 (join-wraps1101 w1597 (syntax-object-wrap1068 e1595)) #f rib1599 (or (syntax-object-module1069 e1595) mod1600))) ((annotation? e1595) (syntax-type1116 (annotation-expression e1595) r1596 w1597 (annotation-source e1595) rib1599 mod1600)) ((self-evaluating? e1595) (values (quote constant) #f e1595 w1597 s1598 mod1600)) (else (values (quote other) #f e1595 w1597 s1598 mod1600))))) (chi-when-list1115 (lambda (e1643 when-list1644 w1645) (let f1646 ((when-list1647 when-list1644) (situations1648 (quote ()))) (if (null? when-list1647) situations1648 (f1646 (cdr when-list1647) (cons (let ((x1649 (car when-list1647))) (cond ((free-id=?1105 x1649 (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"))) (hygiene guile)))) (quote compile)) ((free-id=?1105 x1649 (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"))) (hygiene guile)))) (quote load)) ((free-id=?1105 x1649 (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"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e1643 (wrap1110 x1649 w1645 #f))))) situations1648)))))) (chi-install-global1114 (lambda (name1650 e1651) (build-annotated1059 #f (list (build-annotated1059 #f (quote define)) name1650 (if (let ((v1652 (module-variable (current-module) name1650))) (and v1652 (variable-bound? v1652) (macro? (variable-ref v1652)) (not (eq? (macro-type (variable-ref v1652)) (quote syncase-macro))))) (build-annotated1059 #f (list (build-annotated1059 #f (quote make-extended-syncase-macro)) (build-annotated1059 #f (list (build-annotated1059 #f (quote module-ref)) (build-annotated1059 #f (quote (current-module))) (build-data1060 #f name1650))) (build-data1060 #f (quote macro)) e1651)) (build-annotated1059 #f (list (build-annotated1059 #f (quote make-syncase-macro)) (build-data1060 #f (quote macro)) e1651))))))) (chi-top-sequence1113 (lambda (body1653 r1654 w1655 s1656 m1657 esew1658 mod1659) (build-sequence1061 s1656 (let dobody1660 ((body1661 body1653) (r1662 r1654) (w1663 w1655) (m1664 m1657) (esew1665 esew1658) (mod1666 mod1659)) (if (null? body1661) (quote ()) (let ((first1667 (chi-top1117 (car body1661) r1662 w1663 m1664 esew1665 mod1666))) (cons first1667 (dobody1660 (cdr body1661) r1662 w1663 m1664 esew1665 mod1666)))))))) (chi-sequence1112 (lambda (body1668 r1669 w1670 s1671 mod1672) (build-sequence1061 s1671 (let dobody1673 ((body1674 body1668) (r1675 r1669) (w1676 w1670) (mod1677 mod1672)) (if (null? body1674) (quote ()) (let ((first1678 (chi1118 (car body1674) r1675 w1676 mod1677))) (cons first1678 (dobody1673 (cdr body1674) r1675 w1676 mod1677)))))))) (source-wrap1111 (lambda (x1679 w1680 s1681 defmod1682) (wrap1110 (if s1681 (make-annotation x1679 s1681 #f) x1679) w1680 defmod1682))) (wrap1110 (lambda (x1683 w1684 defmod1685) (cond ((and (null? (wrap-marks1085 w1684)) (null? (wrap-subst1086 w1684))) x1683) ((syntax-object?1066 x1683) (make-syntax-object1065 (syntax-object-expression1067 x1683) (join-wraps1101 w1684 (syntax-object-wrap1068 x1683)) (syntax-object-module1069 x1683))) ((null? x1683) x1683) (else (make-syntax-object1065 x1683 w1684 defmod1685))))) (bound-id-member?1109 (lambda (x1686 list1687) (and (not (null? list1687)) (or (bound-id=?1106 x1686 (car list1687)) (bound-id-member?1109 x1686 (cdr list1687)))))) (distinct-bound-ids?1108 (lambda (ids1688) (let distinct?1689 ((ids1690 ids1688)) (or (null? ids1690) (and (not (bound-id-member?1109 (car ids1690) (cdr ids1690))) (distinct?1689 (cdr ids1690))))))) (valid-bound-ids?1107 (lambda (ids1691) (and (let all-ids?1692 ((ids1693 ids1691)) (or (null? ids1693) (and (id?1082 (car ids1693)) (all-ids?1692 (cdr ids1693))))) (distinct-bound-ids?1108 ids1691)))) (bound-id=?1106 (lambda (i1694 j1695) (if (and (syntax-object?1066 i1694) (syntax-object?1066 j1695)) (and (eq? (let ((e1696 (syntax-object-expression1067 i1694))) (if (annotation? e1696) (annotation-expression e1696) e1696)) (let ((e1697 (syntax-object-expression1067 j1695))) (if (annotation? e1697) (annotation-expression e1697) e1697))) (same-marks?1103 (wrap-marks1085 (syntax-object-wrap1068 i1694)) (wrap-marks1085 (syntax-object-wrap1068 j1695)))) (eq? (let ((e1698 i1694)) (if (annotation? e1698) (annotation-expression e1698) e1698)) (let ((e1699 j1695)) (if (annotation? e1699) (annotation-expression e1699) e1699)))))) (free-id=?1105 (lambda (i1700 j1701) (and (eq? (let ((x1702 i1700)) (let ((e1703 (if (syntax-object?1066 x1702) (syntax-object-expression1067 x1702) x1702))) (if (annotation? e1703) (annotation-expression e1703) e1703))) (let ((x1704 j1701)) (let ((e1705 (if (syntax-object?1066 x1704) (syntax-object-expression1067 x1704) x1704))) (if (annotation? e1705) (annotation-expression e1705) e1705)))) (eq? (id-var-name1104 i1700 (quote (()))) (id-var-name1104 j1701 (quote (()))))))) (id-var-name1104 (lambda (id1706 w1707) (letrec ((search-vector-rib1710 (lambda (sym1716 subst1717 marks1718 symnames1719 ribcage1720) (let ((n1721 (vector-length symnames1719))) (let f1722 ((i1723 0)) (cond ((fx=1052 i1723 n1721) (search1708 sym1716 (cdr subst1717) marks1718)) ((and (eq? (vector-ref symnames1719 i1723) sym1716) (same-marks?1103 marks1718 (vector-ref (ribcage-marks1092 ribcage1720) i1723))) (values (vector-ref (ribcage-labels1093 ribcage1720) i1723) marks1718)) (else (f1722 (fx+1050 i1723 1)))))))) (search-list-rib1709 (lambda (sym1724 subst1725 marks1726 symnames1727 ribcage1728) (let f1729 ((symnames1730 symnames1727) (i1731 0)) (cond ((null? symnames1730) (search1708 sym1724 (cdr subst1725) marks1726)) ((and (eq? (car symnames1730) sym1724) (same-marks?1103 marks1726 (list-ref (ribcage-marks1092 ribcage1728) i1731))) (values (list-ref (ribcage-labels1093 ribcage1728) i1731) marks1726)) (else (f1729 (cdr symnames1730) (fx+1050 i1731 1))))))) (search1708 (lambda (sym1732 subst1733 marks1734) (if (null? subst1733) (values #f marks1734) (let ((fst1735 (car subst1733))) (if (eq? fst1735 (quote shift)) (search1708 sym1732 (cdr subst1733) (cdr marks1734)) (let ((symnames1736 (ribcage-symnames1091 fst1735))) (if (vector? symnames1736) (search-vector-rib1710 sym1732 subst1733 marks1734 symnames1736 fst1735) (search-list-rib1709 sym1732 subst1733 marks1734 symnames1736 fst1735))))))))) (cond ((symbol? id1706) (or (call-with-values (lambda () (search1708 id1706 (wrap-subst1086 w1707) (wrap-marks1085 w1707))) (lambda (x1738 . ignore1737) x1738)) id1706)) ((syntax-object?1066 id1706) (let ((id1739 (let ((e1741 (syntax-object-expression1067 id1706))) (if (annotation? e1741) (annotation-expression e1741) e1741))) (w11740 (syntax-object-wrap1068 id1706))) (let ((marks1742 (join-marks1102 (wrap-marks1085 w1707) (wrap-marks1085 w11740)))) (call-with-values (lambda () (search1708 id1739 (wrap-subst1086 w1707) marks1742)) (lambda (new-id1743 marks1744) (or new-id1743 (call-with-values (lambda () (search1708 id1739 (wrap-subst1086 w11740) marks1744)) (lambda (x1746 . ignore1745) x1746)) id1739)))))) ((annotation? id1706) (let ((id1747 (let ((e1748 id1706)) (if (annotation? e1748) (annotation-expression e1748) e1748)))) (or (call-with-values (lambda () (search1708 id1747 (wrap-subst1086 w1707) (wrap-marks1085 w1707))) (lambda (x1750 . ignore1749) x1750)) id1747))) (else (error-hook1056 (quote id-var-name) "invalid id" id1706)))))) (same-marks?1103 (lambda (x1751 y1752) (or (eq? x1751 y1752) (and (not (null? x1751)) (not (null? y1752)) (eq? (car x1751) (car y1752)) (same-marks?1103 (cdr x1751) (cdr y1752)))))) (join-marks1102 (lambda (m11753 m21754) (smart-append1100 m11753 m21754))) (join-wraps1101 (lambda (w11755 w21756) (let ((m11757 (wrap-marks1085 w11755)) (s11758 (wrap-subst1086 w11755))) (if (null? m11757) (if (null? s11758) w21756 (make-wrap1084 (wrap-marks1085 w21756) (smart-append1100 s11758 (wrap-subst1086 w21756)))) (make-wrap1084 (smart-append1100 m11757 (wrap-marks1085 w21756)) (smart-append1100 s11758 (wrap-subst1086 w21756))))))) (smart-append1100 (lambda (m11759 m21760) (if (null? m21760) m11759 (append m11759 m21760)))) (make-binding-wrap1099 (lambda (ids1761 labels1762 w1763) (if (null? ids1761) w1763 (make-wrap1084 (wrap-marks1085 w1763) (cons (let ((labelvec1764 (list->vector labels1762))) (let ((n1765 (vector-length labelvec1764))) (let ((symnamevec1766 (make-vector n1765)) (marksvec1767 (make-vector n1765))) (begin (let f1768 ((ids1769 ids1761) (i1770 0)) (if (not (null? ids1769)) (call-with-values (lambda () (id-sym-name&marks1083 (car ids1769) w1763)) (lambda (symname1771 marks1772) (begin (vector-set! symnamevec1766 i1770 symname1771) (vector-set! marksvec1767 i1770 marks1772) (f1768 (cdr ids1769) (fx+1050 i1770 1))))))) (make-ribcage1089 symnamevec1766 marksvec1767 labelvec1764))))) (wrap-subst1086 w1763)))))) (extend-ribcage!1098 (lambda (ribcage1773 id1774 label1775) (begin (set-ribcage-symnames!1094 ribcage1773 (cons (let ((e1776 (syntax-object-expression1067 id1774))) (if (annotation? e1776) (annotation-expression e1776) e1776)) (ribcage-symnames1091 ribcage1773))) (set-ribcage-marks!1095 ribcage1773 (cons (wrap-marks1085 (syntax-object-wrap1068 id1774)) (ribcage-marks1092 ribcage1773))) (set-ribcage-labels!1096 ribcage1773 (cons label1775 (ribcage-labels1093 ribcage1773)))))) (anti-mark1097 (lambda (w1777) (make-wrap1084 (cons #f (wrap-marks1085 w1777)) (cons (quote shift) (wrap-subst1086 w1777))))) (set-ribcage-labels!1096 (lambda (x1778 update1779) (vector-set! x1778 3 update1779))) (set-ribcage-marks!1095 (lambda (x1780 update1781) (vector-set! x1780 2 update1781))) (set-ribcage-symnames!1094 (lambda (x1782 update1783) (vector-set! x1782 1 update1783))) (ribcage-labels1093 (lambda (x1784) (vector-ref x1784 3))) (ribcage-marks1092 (lambda (x1785) (vector-ref x1785 2))) (ribcage-symnames1091 (lambda (x1786) (vector-ref x1786 1))) (ribcage?1090 (lambda (x1787) (and (vector? x1787) (= (vector-length x1787) 4) (eq? (vector-ref x1787 0) (quote ribcage))))) (make-ribcage1089 (lambda (symnames1788 marks1789 labels1790) (vector (quote ribcage) symnames1788 marks1789 labels1790))) (gen-labels1088 (lambda (ls1791) (if (null? ls1791) (quote ()) (cons (gen-label1087) (gen-labels1088 (cdr ls1791)))))) (gen-label1087 (lambda () (string #\i))) (wrap-subst1086 cdr) (wrap-marks1085 car) (make-wrap1084 cons) (id-sym-name&marks1083 (lambda (x1792 w1793) (if (syntax-object?1066 x1792) (values (let ((e1794 (syntax-object-expression1067 x1792))) (if (annotation? e1794) (annotation-expression e1794) e1794)) (join-marks1102 (wrap-marks1085 w1793) (wrap-marks1085 (syntax-object-wrap1068 x1792)))) (values (let ((e1795 x1792)) (if (annotation? e1795) (annotation-expression e1795) e1795)) (wrap-marks1085 w1793))))) (id?1082 (lambda (x1796) (cond ((symbol? x1796) #t) ((syntax-object?1066 x1796) (symbol? (let ((e1797 (syntax-object-expression1067 x1796))) (if (annotation? e1797) (annotation-expression e1797) e1797)))) ((annotation? x1796) (symbol? (annotation-expression x1796))) (else #f)))) (nonsymbol-id?1081 (lambda (x1798) (and (syntax-object?1066 x1798) (symbol? (let ((e1799 (syntax-object-expression1067 x1798))) (if (annotation? e1799) (annotation-expression e1799) e1799)))))) (global-extend1080 (lambda (type1800 sym1801 val1802) (put-global-definition-hook1057 sym1801 type1800 val1802))) (lookup1079 (lambda (x1803 r1804 mod1805) (cond ((assq x1803 r1804) => cdr) ((symbol? x1803) (or (get-global-definition-hook1058 x1803 mod1805) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1078 (lambda (r1806) (if (null? r1806) (quote ()) (let ((a1807 (car r1806))) (if (eq? (cadr a1807) (quote macro)) (cons a1807 (macros-only-env1078 (cdr r1806))) (macros-only-env1078 (cdr r1806))))))) (extend-var-env1077 (lambda (labels1808 vars1809 r1810) (if (null? labels1808) r1810 (extend-var-env1077 (cdr labels1808) (cdr vars1809) (cons (cons (car labels1808) (cons (quote lexical) (car vars1809))) r1810))))) (extend-env1076 (lambda (labels1811 bindings1812 r1813) (if (null? labels1811) r1813 (extend-env1076 (cdr labels1811) (cdr bindings1812) (cons (cons (car labels1811) (car bindings1812)) r1813))))) (binding-value1075 cdr) (binding-type1074 car) (source-annotation1073 (lambda (x1814) (cond ((annotation? x1814) (annotation-source x1814)) ((syntax-object?1066 x1814) (source-annotation1073 (syntax-object-expression1067 x1814))) (else #f)))) (set-syntax-object-module!1072 (lambda (x1815 update1816) (vector-set! x1815 3 update1816))) (set-syntax-object-wrap!1071 (lambda (x1817 update1818) (vector-set! x1817 2 update1818))) (set-syntax-object-expression!1070 (lambda (x1819 update1820) (vector-set! x1819 1 update1820))) (syntax-object-module1069 (lambda (x1821) (vector-ref x1821 3))) (syntax-object-wrap1068 (lambda (x1822) (vector-ref x1822 2))) (syntax-object-expression1067 (lambda (x1823) (vector-ref x1823 1))) (syntax-object?1066 (lambda (x1824) (and (vector? x1824) (= (vector-length x1824) 4) (eq? (vector-ref x1824 0) (quote syntax-object))))) (make-syntax-object1065 (lambda (expression1825 wrap1826 module1827) (vector (quote syntax-object) expression1825 wrap1826 module1827))) (build-letrec1064 (lambda (src1828 vars1829 val-exps1830 body-exp1831) (if (null? vars1829) (build-annotated1059 src1828 body-exp1831) (build-annotated1059 src1828 (list (quote letrec) (map list vars1829 val-exps1830) body-exp1831))))) (build-named-let1063 (lambda (src1832 vars1833 val-exps1834 body-exp1835) (if (null? vars1833) (build-annotated1059 src1832 body-exp1835) (build-annotated1059 src1832 (list (quote let) (car vars1833) (map list (cdr vars1833) val-exps1834) body-exp1835))))) (build-let1062 (lambda (src1836 vars1837 val-exps1838 body-exp1839) (if (null? vars1837) (build-annotated1059 src1836 body-exp1839) (build-annotated1059 src1836 (list (quote let) (map list vars1837 val-exps1838) body-exp1839))))) (build-sequence1061 (lambda (src1840 exps1841) (if (null? (cdr exps1841)) (build-annotated1059 src1840 (car exps1841)) (build-annotated1059 src1840 (cons (quote begin) exps1841))))) (build-data1060 (lambda (src1842 exp1843) (if (and (self-evaluating? exp1843) (not (vector? exp1843))) (build-annotated1059 src1842 exp1843) (build-annotated1059 src1842 (list (quote quote) exp1843))))) (build-annotated1059 (lambda (src1844 exp1845) (if (and src1844 (not (annotation? exp1845))) (make-annotation exp1845 src1844 #t) exp1845))) (get-global-definition-hook1058 (lambda (symbol1846 module1847) (begin (if (and (not module1847) (current-module)) (warn "module system is booted, we should have a module" symbol1846)) (let ((v1848 (module-variable (if module1847 (resolve-module (cdr module1847)) (current-module)) symbol1846))) (and v1848 (variable-bound? v1848) (let ((val1849 (variable-ref v1848))) (and (macro? val1849) (syncase-macro-type val1849) (cons (syncase-macro-type val1849) (syncase-macro-binding val1849))))))))) (put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852) (let ((existing1853 (let ((v1854 (module-variable (current-module) symbol1850))) (and v1854 (variable-bound? v1854) (let ((val1855 (variable-ref v1854))) (and (macro? val1855) (not (syncase-macro-type val1855)) val1855)))))) (module-define! (current-module) symbol1850 (if existing1853 (make-extended-syncase-macro existing1853 type1851 val1852) (make-syncase-macro type1851 val1852)))))) (error-hook1056 (lambda (who1856 why1857 what1858) (error who1856 "~a ~s" why1857 what1858))) (local-eval-hook1055 (lambda (x1859 mod1860) (primitive-eval (list noexpand1049 x1859)))) (top-level-eval-hook1054 (lambda (x1861 mod1862) (primitive-eval (list noexpand1049 x1861)))) (fx<1053 <) (fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin (global-extend1080 (quote local-syntax) (quote letrec-syntax) #t) (global-extend1080 (quote local-syntax) (quote let-syntax) #f) (global-extend1080 (quote core) (quote fluid-let-syntax) (lambda (e1863 r1864 w1865 s1866 mod1867) ((lambda (tmp1868) ((lambda (tmp1869) (if (if tmp1869 (apply (lambda (_1870 var1871 val1872 e11873 e21874) (valid-bound-ids?1107 var1871)) tmp1869) #f) (apply (lambda (_1876 var1877 val1878 e11879 e21880) (let ((names1881 (map (lambda (x1882) (id-var-name1104 x1882 w1865)) var1877))) (begin (for-each (lambda (id1884 n1885) (let ((t1886 (binding-type1074 (lookup1079 n1885 r1864 mod1867)))) (if (memv t1886 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1863 (source-wrap1111 id1884 w1865 s1866 mod1867))))) var1877 names1881) (chi-body1122 (cons e11879 e21880) (source-wrap1111 e1863 w1865 s1866 mod1867) (extend-env1076 names1881 (let ((trans-r1889 (macros-only-env1078 r1864))) (map (lambda (x1890) (cons (quote macro) (eval-local-transformer1125 (chi1118 x1890 trans-r1889 w1865 mod1867) mod1867))) val1878)) r1864) w1865 mod1867)))) tmp1869) ((lambda (_1892) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1111 e1863 w1865 s1866 mod1867))) tmp1868))) ($sc-dispatch tmp1868 (quote (any #(each (any any)) any . each-any))))) e1863))) (global-extend1080 (quote core) (quote quote) (lambda (e1893 r1894 w1895 s1896 mod1897) ((lambda (tmp1898) ((lambda (tmp1899) (if tmp1899 (apply (lambda (_1900 e1901) (build-data1060 s1896 (strip1129 e1901 w1895))) tmp1899) ((lambda (_1902) (syntax-violation (quote quote) "bad syntax" (source-wrap1111 e1893 w1895 s1896 mod1897))) tmp1898))) ($sc-dispatch tmp1898 (quote (any any))))) e1893))) (global-extend1080 (quote core) (quote syntax) (letrec ((regen1910 (lambda (x1911) (let ((t1912 (car x1911))) (if (memv t1912 (quote (ref))) (build-annotated1059 #f (cadr x1911)) (if (memv t1912 (quote (primitive))) (build-annotated1059 #f (cadr x1911)) (if (memv t1912 (quote (quote))) (build-data1060 #f (cadr x1911)) (if (memv t1912 (quote (lambda))) (build-annotated1059 #f (list (quote lambda) (cadr x1911) (regen1910 (caddr x1911)))) (if (memv t1912 (quote (map))) (let ((ls1913 (map regen1910 (cdr x1911)))) (build-annotated1059 #f (cons (if (fx=1052 (length ls1913) 2) (build-annotated1059 #f (quote map)) (build-annotated1059 #f (quote map))) ls1913))) (build-annotated1059 #f (cons (build-annotated1059 #f (car x1911)) (map regen1910 (cdr x1911)))))))))))) (gen-vector1909 (lambda (x1914) (cond ((eq? (car x1914) (quote list)) (cons (quote vector) (cdr x1914))) ((eq? (car x1914) (quote quote)) (list (quote quote) (list->vector (cadr x1914)))) (else (list (quote list->vector) x1914))))) (gen-append1908 (lambda (x1915 y1916) (if (equal? y1916 (quote (quote ()))) x1915 (list (quote append) x1915 y1916)))) (gen-cons1907 (lambda (x1917 y1918) (let ((t1919 (car y1918))) (if (memv t1919 (quote (quote))) (if (eq? (car x1917) (quote quote)) (list (quote quote) (cons (cadr x1917) (cadr y1918))) (if (eq? (cadr y1918) (quote ())) (list (quote list) x1917) (list (quote cons) x1917 y1918))) (if (memv t1919 (quote (list))) (cons (quote list) (cons x1917 (cdr y1918))) (list (quote cons) x1917 y1918)))))) (gen-map1906 (lambda (e1920 map-env1921) (let ((formals1922 (map cdr map-env1921)) (actuals1923 (map (lambda (x1924) (list (quote ref) (car x1924))) map-env1921))) (cond ((eq? (car e1920) (quote ref)) (car actuals1923)) ((andmap (lambda (x1925) (and (eq? (car x1925) (quote ref)) (memq (cadr x1925) formals1922))) (cdr e1920)) (cons (quote map) (cons (list (quote primitive) (car e1920)) (map (let ((r1926 (map cons formals1922 actuals1923))) (lambda (x1927) (cdr (assq (cadr x1927) r1926)))) (cdr e1920))))) (else (cons (quote map) (cons (list (quote lambda) formals1922 e1920) actuals1923))))))) (gen-mappend1905 (lambda (e1928 map-env1929) (list (quote apply) (quote (primitive append)) (gen-map1906 e1928 map-env1929)))) (gen-ref1904 (lambda (src1930 var1931 level1932 maps1933) (if (fx=1052 level1932 0) (values var1931 maps1933) (if (null? maps1933) (syntax-violation (quote syntax) "missing ellipsis" src1930) (call-with-values (lambda () (gen-ref1904 src1930 var1931 (fx-1051 level1932 1) (cdr maps1933))) (lambda (outer-var1934 outer-maps1935) (let ((b1936 (assq outer-var1934 (car maps1933)))) (if b1936 (values (cdr b1936) maps1933) (let ((inner-var1937 (gen-var1130 (quote tmp)))) (values inner-var1937 (cons (cons (cons outer-var1934 inner-var1937) (car maps1933)) outer-maps1935))))))))))) (gen-syntax1903 (lambda (src1938 e1939 r1940 maps1941 ellipsis?1942 mod1943) (if (id?1082 e1939) (let ((label1944 (id-var-name1104 e1939 (quote (()))))) (let ((b1945 (lookup1079 label1944 r1940 mod1943))) (if (eq? (binding-type1074 b1945) (quote syntax)) (call-with-values (lambda () (let ((var.lev1946 (binding-value1075 b1945))) (gen-ref1904 src1938 (car var.lev1946) (cdr var.lev1946) maps1941))) (lambda (var1947 maps1948) (values (list (quote ref) var1947) maps1948))) (if (ellipsis?1942 e1939) (syntax-violation (quote syntax) "misplaced ellipsis" src1938) (values (list (quote quote) e1939) maps1941))))) ((lambda (tmp1949) ((lambda (tmp1950) (if (if tmp1950 (apply (lambda (dots1951 e1952) (ellipsis?1942 dots1951)) tmp1950) #f) (apply (lambda (dots1953 e1954) (gen-syntax1903 src1938 e1954 r1940 maps1941 (lambda (x1955) #f) mod1943)) tmp1950) ((lambda (tmp1956) (if (if tmp1956 (apply (lambda (x1957 dots1958 y1959) (ellipsis?1942 dots1958)) tmp1956) #f) (apply (lambda (x1960 dots1961 y1962) (let f1963 ((y1964 y1962) (k1965 (lambda (maps1966) (call-with-values (lambda () (gen-syntax1903 src1938 x1960 r1940 (cons (quote ()) maps1966) ellipsis?1942 mod1943)) (lambda (x1967 maps1968) (if (null? (car maps1968)) (syntax-violation (quote syntax) "extra ellipsis" src1938) (values (gen-map1906 x1967 (car maps1968)) (cdr maps1968)))))))) ((lambda (tmp1969) ((lambda (tmp1970) (if (if tmp1970 (apply (lambda (dots1971 y1972) (ellipsis?1942 dots1971)) tmp1970) #f) (apply (lambda (dots1973 y1974) (f1963 y1974 (lambda (maps1975) (call-with-values (lambda () (k1965 (cons (quote ()) maps1975))) (lambda (x1976 maps1977) (if (null? (car maps1977)) (syntax-violation (quote syntax) "extra ellipsis" src1938) (values (gen-mappend1905 x1976 (car maps1977)) (cdr maps1977)))))))) tmp1970) ((lambda (_1978) (call-with-values (lambda () (gen-syntax1903 src1938 y1964 r1940 maps1941 ellipsis?1942 mod1943)) (lambda (y1979 maps1980) (call-with-values (lambda () (k1965 maps1980)) (lambda (x1981 maps1982) (values (gen-append1908 x1981 y1979) maps1982)))))) tmp1969))) ($sc-dispatch tmp1969 (quote (any . any))))) y1964))) tmp1956) ((lambda (tmp1983) (if tmp1983 (apply (lambda (x1984 y1985) (call-with-values (lambda () (gen-syntax1903 src1938 x1984 r1940 maps1941 ellipsis?1942 mod1943)) (lambda (x1986 maps1987) (call-with-values (lambda () (gen-syntax1903 src1938 y1985 r1940 maps1987 ellipsis?1942 mod1943)) (lambda (y1988 maps1989) (values (gen-cons1907 x1986 y1988) maps1989)))))) tmp1983) ((lambda (tmp1990) (if tmp1990 (apply (lambda (e11991 e21992) (call-with-values (lambda () (gen-syntax1903 src1938 (cons e11991 e21992) r1940 maps1941 ellipsis?1942 mod1943)) (lambda (e1994 maps1995) (values (gen-vector1909 e1994) maps1995)))) tmp1990) ((lambda (_1996) (values (list (quote quote) e1939) maps1941)) tmp1949))) ($sc-dispatch tmp1949 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1949 (quote (any . any)))))) ($sc-dispatch tmp1949 (quote (any any . any)))))) ($sc-dispatch tmp1949 (quote (any any))))) e1939))))) (lambda (e1997 r1998 w1999 s2000 mod2001) (let ((e2002 (source-wrap1111 e1997 w1999 s2000 mod2001))) ((lambda (tmp2003) ((lambda (tmp2004) (if tmp2004 (apply (lambda (_2005 x2006) (call-with-values (lambda () (gen-syntax1903 e2002 x2006 r1998 (quote ()) ellipsis?1127 mod2001)) (lambda (e2007 maps2008) (regen1910 e2007)))) tmp2004) ((lambda (_2009) (syntax-violation (quote syntax) "bad `syntax' form" e2002)) tmp2003))) ($sc-dispatch tmp2003 (quote (any any))))) e2002))))) (global-extend1080 (quote core) (quote lambda) (lambda (e2010 r2011 w2012 s2013 mod2014) ((lambda (tmp2015) ((lambda (tmp2016) (if tmp2016 (apply (lambda (_2017 c2018) (chi-lambda-clause1123 (source-wrap1111 e2010 w2012 s2013 mod2014) #f c2018 r2011 w2012 mod2014 (lambda (vars2019 docstring2020 body2021) (build-annotated1059 s2013 (cons (quote lambda) (cons vars2019 (append (if docstring2020 (list docstring2020) (quote ())) (list body2021)))))))) tmp2016) (syntax-violation #f "source expression failed to match any pattern" tmp2015))) ($sc-dispatch tmp2015 (quote (any . any))))) e2010))) (global-extend1080 (quote core) (quote let) (letrec ((chi-let2022 (lambda (e2023 r2024 w2025 s2026 mod2027 constructor2028 ids2029 vals2030 exps2031) (if (not (valid-bound-ids?1107 ids2029)) (syntax-violation (quote let) "duplicate bound variable" e2023) (let ((labels2032 (gen-labels1088 ids2029)) (new-vars2033 (map gen-var1130 ids2029))) (let ((nw2034 (make-binding-wrap1099 ids2029 labels2032 w2025)) (nr2035 (extend-var-env1077 labels2032 new-vars2033 r2024))) (constructor2028 s2026 new-vars2033 (map (lambda (x2036) (chi1118 x2036 r2024 w2025 mod2027)) vals2030) (chi-body1122 exps2031 (source-wrap1111 e2023 nw2034 s2026 mod2027) nr2035 nw2034 mod2027)))))))) (lambda (e2037 r2038 w2039 s2040 mod2041) ((lambda (tmp2042) ((lambda (tmp2043) (if tmp2043 (apply (lambda (_2044 id2045 val2046 e12047 e22048) (chi-let2022 e2037 r2038 w2039 s2040 mod2041 build-let1062 id2045 val2046 (cons e12047 e22048))) tmp2043) ((lambda (tmp2052) (if (if tmp2052 (apply (lambda (_2053 f2054 id2055 val2056 e12057 e22058) (id?1082 f2054)) tmp2052) #f) (apply (lambda (_2059 f2060 id2061 val2062 e12063 e22064) (chi-let2022 e2037 r2038 w2039 s2040 mod2041 build-named-let1063 (cons f2060 id2061) val2062 (cons e12063 e22064))) tmp2052) ((lambda (_2068) (syntax-violation (quote let) "bad let" (source-wrap1111 e2037 w2039 s2040 mod2041))) tmp2042))) ($sc-dispatch tmp2042 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2042 (quote (any #(each (any any)) any . each-any))))) e2037)))) (global-extend1080 (quote core) (quote letrec) (lambda (e2069 r2070 w2071 s2072 mod2073) ((lambda (tmp2074) ((lambda (tmp2075) (if tmp2075 (apply (lambda (_2076 id2077 val2078 e12079 e22080) (let ((ids2081 id2077)) (if (not (valid-bound-ids?1107 ids2081)) (syntax-violation (quote letrec) "duplicate bound variable" e2069) (let ((labels2083 (gen-labels1088 ids2081)) (new-vars2084 (map gen-var1130 ids2081))) (let ((w2085 (make-binding-wrap1099 ids2081 labels2083 w2071)) (r2086 (extend-var-env1077 labels2083 new-vars2084 r2070))) (build-letrec1064 s2072 new-vars2084 (map (lambda (x2087) (chi1118 x2087 r2086 w2085 mod2073)) val2078) (chi-body1122 (cons e12079 e22080) (source-wrap1111 e2069 w2085 s2072 mod2073) r2086 w2085 mod2073))))))) tmp2075) ((lambda (_2090) (syntax-violation (quote letrec) "bad letrec" (source-wrap1111 e2069 w2071 s2072 mod2073))) tmp2074))) ($sc-dispatch tmp2074 (quote (any #(each (any any)) any . each-any))))) e2069))) (global-extend1080 (quote core) (quote set!) (lambda (e2091 r2092 w2093 s2094 mod2095) ((lambda (tmp2096) ((lambda (tmp2097) (if (if tmp2097 (apply (lambda (_2098 id2099 val2100) (id?1082 id2099)) tmp2097) #f) (apply (lambda (_2101 id2102 val2103) (let ((val2104 (chi1118 val2103 r2092 w2093 mod2095)) (n2105 (id-var-name1104 id2102 w2093))) (let ((b2106 (lookup1079 n2105 r2092 mod2095))) (let ((t2107 (binding-type1074 b2106))) (if (memv t2107 (quote (lexical))) (build-annotated1059 s2094 (list (quote set!) (binding-value1075 b2106) val2104)) (if (memv t2107 (quote (global))) (build-annotated1059 s2094 (list (quote set!) (if mod2095 (make-module-ref (cdr mod2095) n2105 (car mod2095)) (make-module-ref mod2095 n2105 (quote bare))) val2104)) (if (memv t2107 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap1110 id2102 w2093 mod2095)) (syntax-violation (quote set!) "bad set!" (source-wrap1111 e2091 w2093 s2094 mod2095))))))))) tmp2097) ((lambda (tmp2108) (if tmp2108 (apply (lambda (_2109 head2110 tail2111 val2112) (call-with-values (lambda () (syntax-type1116 head2110 r2092 (quote (())) #f #f mod2095)) (lambda (type2113 value2114 ee2115 ww2116 ss2117 modmod2118) (let ((t2119 type2113)) (if (memv t2119 (quote (module-ref))) (let ((val2120 (chi1118 val2112 r2092 w2093 mod2095))) (call-with-values (lambda () (value2114 (cons head2110 tail2111))) (lambda (id2122 mod2123) (build-annotated1059 s2094 (list (quote set!) (if mod2123 (make-module-ref (cdr mod2123) id2122 (car mod2123)) (make-module-ref mod2123 id2122 (quote bare))) val2120))))) (build-annotated1059 s2094 (cons (chi1118 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail 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"))) (hygiene guile))) head2110) r2092 w2093 mod2095) (map (lambda (e2124) (chi1118 e2124 r2092 w2093 mod2095)) (append tail2111 (list val2112)))))))))) tmp2108) ((lambda (_2126) (syntax-violation (quote set!) "bad set!" (source-wrap1111 e2091 w2093 s2094 mod2095))) tmp2096))) ($sc-dispatch tmp2096 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2096 (quote (any any any))))) e2091))) (global-extend1080 (quote module-ref) (quote @) (lambda (e2127) ((lambda (tmp2128) ((lambda (tmp2129) (if (if tmp2129 (apply (lambda (_2130 mod2131 id2132) (and (andmap id?1082 mod2131) (id?1082 id2132))) tmp2129) #f) (apply (lambda (_2134 mod2135 id2136) (values (syntax->datum id2136) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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"))) (hygiene guile))) mod2135)))) tmp2129) (syntax-violation #f "source expression failed to match any pattern" tmp2128))) ($sc-dispatch tmp2128 (quote (any each-any any))))) e2127))) (global-extend1080 (quote module-ref) (quote @@) (lambda (e2138) ((lambda (tmp2139) ((lambda (tmp2140) (if (if tmp2140 (apply (lambda (_2141 mod2142 id2143) (and (andmap id?1082 mod2142) (id?1082 id2143))) tmp2140) #f) (apply (lambda (_2145 mod2146 id2147) (values (syntax->datum id2147) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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"))) (hygiene guile))) mod2146)))) tmp2140) (syntax-violation #f "source expression failed to match any pattern" tmp2139))) ($sc-dispatch tmp2139 (quote (any each-any any))))) e2138))) (global-extend1080 (quote begin) (quote begin) (quote ())) (global-extend1080 (quote define) (quote define) (quote ())) (global-extend1080 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1080 (quote eval-when) (quote eval-when) (quote ())) (global-extend1080 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2152 (lambda (x2153 keys2154 clauses2155 r2156 mod2157) (if (null? clauses2155) (build-annotated1059 #f (list (build-annotated1059 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x2153)) ((lambda (tmp2158) ((lambda (tmp2159) (if tmp2159 (apply (lambda (pat2160 exp2161) (if (and (id?1082 pat2160) (andmap (lambda (x2162) (not (free-id=?1105 pat2160 x2162))) (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"))) (hygiene guile))) keys2154))) (let ((labels2163 (list (gen-label1087))) (var2164 (gen-var1130 pat2160))) (build-annotated1059 #f (list (build-annotated1059 #f (list (quote lambda) (list var2164) (chi1118 exp2161 (extend-env1076 labels2163 (list (cons (quote syntax) (cons var2164 0))) r2156) (make-binding-wrap1099 (list pat2160) labels2163 (quote (()))) mod2157))) x2153))) (gen-clause2151 x2153 keys2154 (cdr clauses2155) r2156 pat2160 #t exp2161 mod2157))) tmp2159) ((lambda (tmp2165) (if tmp2165 (apply (lambda (pat2166 fender2167 exp2168) (gen-clause2151 x2153 keys2154 (cdr clauses2155) r2156 pat2166 fender2167 exp2168 mod2157)) tmp2165) ((lambda (_2169) (syntax-violation (quote syntax-case) "invalid clause" (car clauses2155))) tmp2158))) ($sc-dispatch tmp2158 (quote (any any any)))))) ($sc-dispatch tmp2158 (quote (any any))))) (car clauses2155))))) (gen-clause2151 (lambda (x2170 keys2171 clauses2172 r2173 pat2174 fender2175 exp2176 mod2177) (call-with-values (lambda () (convert-pattern2149 pat2174 keys2171)) (lambda (p2178 pvars2179) (cond ((not (distinct-bound-ids?1108 (map car pvars2179))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat2174)) ((not (andmap (lambda (x2180) (not (ellipsis?1127 (car x2180)))) pvars2179)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat2174)) (else (let ((y2181 (gen-var1130 (quote tmp)))) (build-annotated1059 #f (list (build-annotated1059 #f (list (quote lambda) (list y2181) (let ((y2182 (build-annotated1059 #f y2181))) (build-annotated1059 #f (list (quote if) ((lambda (tmp2183) ((lambda (tmp2184) (if tmp2184 (apply (lambda () y2182) tmp2184) ((lambda (_2185) (build-annotated1059 #f (list (quote if) y2182 (build-dispatch-call2150 pvars2179 fender2175 y2182 r2173 mod2177) (build-data1060 #f #f)))) tmp2183))) ($sc-dispatch tmp2183 (quote #(atom #t))))) fender2175) (build-dispatch-call2150 pvars2179 exp2176 y2182 r2173 mod2177) (gen-syntax-case2152 x2170 keys2171 clauses2172 r2173 mod2177)))))) (if (eq? p2178 (quote any)) (build-annotated1059 #f (list (build-annotated1059 #f (quote list)) x2170)) (build-annotated1059 #f (list (build-annotated1059 #f (quote $sc-dispatch)) x2170 (build-data1060 #f p2178))))))))))))) (build-dispatch-call2150 (lambda (pvars2186 exp2187 y2188 r2189 mod2190) (let ((ids2191 (map car pvars2186)) (levels2192 (map cdr pvars2186))) (let ((labels2193 (gen-labels1088 ids2191)) (new-vars2194 (map gen-var1130 ids2191))) (build-annotated1059 #f (list (build-annotated1059 #f (quote apply)) (build-annotated1059 #f (list (quote lambda) new-vars2194 (chi1118 exp2187 (extend-env1076 labels2193 (map (lambda (var2195 level2196) (cons (quote syntax) (cons var2195 level2196))) new-vars2194 (map cdr pvars2186)) r2189) (make-binding-wrap1099 ids2191 labels2193 (quote (()))) mod2190))) y2188)))))) (convert-pattern2149 (lambda (pattern2197 keys2198) (let cvt2199 ((p2200 pattern2197) (n2201 0) (ids2202 (quote ()))) (if (id?1082 p2200) (if (bound-id-member?1109 p2200 keys2198) (values (vector (quote free-id) p2200) ids2202) (values (quote any) (cons (cons p2200 n2201) ids2202))) ((lambda (tmp2203) ((lambda (tmp2204) (if (if tmp2204 (apply (lambda (x2205 dots2206) (ellipsis?1127 dots2206)) tmp2204) #f) (apply (lambda (x2207 dots2208) (call-with-values (lambda () (cvt2199 x2207 (fx+1050 n2201 1) ids2202)) (lambda (p2209 ids2210) (values (if (eq? p2209 (quote any)) (quote each-any) (vector (quote each) p2209)) ids2210)))) tmp2204) ((lambda (tmp2211) (if tmp2211 (apply (lambda (x2212 y2213) (call-with-values (lambda () (cvt2199 y2213 n2201 ids2202)) (lambda (y2214 ids2215) (call-with-values (lambda () (cvt2199 x2212 n2201 ids2215)) (lambda (x2216 ids2217) (values (cons x2216 y2214) ids2217)))))) tmp2211) ((lambda (tmp2218) (if tmp2218 (apply (lambda () (values (quote ()) ids2202)) tmp2218) ((lambda (tmp2219) (if tmp2219 (apply (lambda (x2220) (call-with-values (lambda () (cvt2199 x2220 n2201 ids2202)) (lambda (p2222 ids2223) (values (vector (quote vector) p2222) ids2223)))) tmp2219) ((lambda (x2224) (values (vector (quote atom) (strip1129 p2200 (quote (())))) ids2202)) tmp2203))) ($sc-dispatch tmp2203 (quote #(vector each-any)))))) ($sc-dispatch tmp2203 (quote ()))))) ($sc-dispatch tmp2203 (quote (any . any)))))) ($sc-dispatch tmp2203 (quote (any any))))) p2200)))))) (lambda (e2225 r2226 w2227 s2228 mod2229) (let ((e2230 (source-wrap1111 e2225 w2227 s2228 mod2229))) ((lambda (tmp2231) ((lambda (tmp2232) (if tmp2232 (apply (lambda (_2233 val2234 key2235 m2236) (if (andmap (lambda (x2237) (and (id?1082 x2237) (not (ellipsis?1127 x2237)))) key2235) (let ((x2239 (gen-var1130 (quote tmp)))) (build-annotated1059 s2228 (list (build-annotated1059 #f (list (quote lambda) (list x2239) (gen-syntax-case2152 (build-annotated1059 #f x2239) key2235 m2236 r2226 mod2229))) (chi1118 val2234 r2226 (quote (())) mod2229)))) (syntax-violation (quote syntax-case) "invalid literals list" e2230))) tmp2232) (syntax-violation #f "source expression failed to match any pattern" tmp2231))) ($sc-dispatch tmp2231 (quote (any any each-any . each-any))))) e2230))))) (set! sc-expand (let ((m2242 (quote e)) (esew2243 (quote (eval)))) (lambda (x2244) (if (and (pair? x2244) (equal? (car x2244) noexpand1049)) (cadr x2244) (chi-top1117 x2244 (quote ()) (quote ((top))) m2242 esew2243 (cons (quote hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2245 (quote e)) (esew2246 (quote (eval)))) (lambda (x2248 . rest2247) (if (and (pair? x2248) (equal? (car x2248) noexpand1049)) (cadr x2248) (chi-top1117 x2248 (quote ()) (quote ((top))) (if (null? rest2247) m2245 (car rest2247)) (if (or (null? rest2247) (null? (cdr rest2247))) esew2246 (cadr rest2247)) (cons (quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda (x2249) (nonsymbol-id?1081 x2249))) (set! datum->syntax (lambda (id2250 datum2251) (make-syntax-object1065 datum2251 (syntax-object-wrap1068 id2250) #f))) (set! syntax->datum (lambda (x2252) (strip1129 x2252 (quote (()))))) (set! generate-temporaries (lambda (ls2253) (begin (let ((x2254 ls2253)) (if (not (list? x2254)) (error-hook1056 (quote generate-temporaries) "invalid argument" x2254))) (map (lambda (x2255) (wrap1110 (gensym) (quote ((top))) #f)) ls2253)))) (set! free-identifier=? (lambda (x2256 y2257) (begin (let ((x2258 x2256)) (if (not (nonsymbol-id?1081 x2258)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2258))) (let ((x2259 y2257)) (if (not (nonsymbol-id?1081 x2259)) (error-hook1056 (quote free-identifier=?) "invalid argument" x2259))) (free-id=?1105 x2256 y2257)))) (set! bound-identifier=? (lambda (x2260 y2261) (begin (let ((x2262 x2260)) (if (not (nonsymbol-id?1081 x2262)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2262))) (let ((x2263 y2261)) (if (not (nonsymbol-id?1081 x2263)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2263))) (bound-id=?1106 x2260 y2261)))) (set! syntax-violation (lambda (who2267 message2266 form2265 . subform2264) (begin (let ((x2268 who2267)) (if (not ((lambda (x2269) (or (not x2269) (string? x2269) (symbol? x2269))) x2268)) (error-hook1056 (quote syntax-violation) "invalid argument" x2268))) (let ((x2270 message2266)) (if (not (string? x2270)) (error-hook1056 (quote syntax-violation) "invalid argument" x2270))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2267 "~a: " "") "~a " (if (null? subform2264) "in ~a" "in subform `~s' of `~s'")) (let ((tail2271 (cons message2266 (map (lambda (x2272) (strip1129 x2272 (quote (())))) (append subform2264 (list form2265)))))) (if who2267 (cons who2267 tail2271) tail2271)) #f)))) (set! install-global-transformer (lambda (sym2273 v2274) (begin (let ((x2275 sym2273)) (if (not (symbol? x2275)) (error-hook1056 (quote define-syntax) "invalid argument" x2275))) (let ((x2276 v2274)) (if (not (procedure? x2276)) (error-hook1056 (quote define-syntax) "invalid argument" x2276))) (global-extend1080 (quote macro) sym2273 v2274)))) (letrec ((match2281 (lambda (e2282 p2283 w2284 r2285 mod2286) (cond ((not r2285) #f) ((eq? p2283 (quote any)) (cons (wrap1110 e2282 w2284 mod2286) r2285)) ((syntax-object?1066 e2282) (match*2280 (let ((e2287 (syntax-object-expression1067 e2282))) (if (annotation? e2287) (annotation-expression e2287) e2287)) p2283 (join-wraps1101 w2284 (syntax-object-wrap1068 e2282)) r2285 (syntax-object-module1069 e2282))) (else (match*2280 (let ((e2288 e2282)) (if (annotation? e2288) (annotation-expression e2288) e2288)) p2283 w2284 r2285 mod2286))))) (match*2280 (lambda (e2289 p2290 w2291 r2292 mod2293) (cond ((null? p2290) (and (null? e2289) r2292)) ((pair? p2290) (and (pair? e2289) (match2281 (car e2289) (car p2290) w2291 (match2281 (cdr e2289) (cdr p2290) w2291 r2292 mod2293) mod2293))) ((eq? p2290 (quote each-any)) (let ((l2294 (match-each-any2278 e2289 w2291 mod2293))) (and l2294 (cons l2294 r2292)))) (else (let ((t2295 (vector-ref p2290 0))) (if (memv t2295 (quote (each))) (if (null? e2289) (match-empty2279 (vector-ref p2290 1) r2292) (let ((l2296 (match-each2277 e2289 (vector-ref p2290 1) w2291 mod2293))) (and l2296 (let collect2297 ((l2298 l2296)) (if (null? (car l2298)) r2292 (cons (map car l2298) (collect2297 (map cdr l2298)))))))) (if (memv t2295 (quote (free-id))) (and (id?1082 e2289) (free-id=?1105 (wrap1110 e2289 w2291 mod2293) (vector-ref p2290 1)) r2292) (if (memv t2295 (quote (atom))) (and (equal? (vector-ref p2290 1) (strip1129 e2289 w2291)) r2292) (if (memv t2295 (quote (vector))) (and (vector? e2289) (match2281 (vector->list e2289) (vector-ref p2290 1) w2291 r2292 mod2293))))))))))) (match-empty2279 (lambda (p2299 r2300) (cond ((null? p2299) r2300) ((eq? p2299 (quote any)) (cons (quote ()) r2300)) ((pair? p2299) (match-empty2279 (car p2299) (match-empty2279 (cdr p2299) r2300))) ((eq? p2299 (quote each-any)) (cons (quote ()) r2300)) (else (let ((t2301 (vector-ref p2299 0))) (if (memv t2301 (quote (each))) (match-empty2279 (vector-ref p2299 1) r2300) (if (memv t2301 (quote (free-id atom))) r2300 (if (memv t2301 (quote (vector))) (match-empty2279 (vector-ref p2299 1) r2300))))))))) (match-each-any2278 (lambda (e2302 w2303 mod2304) (cond ((annotation? e2302) (match-each-any2278 (annotation-expression e2302) w2303 mod2304)) ((pair? e2302) (let ((l2305 (match-each-any2278 (cdr e2302) w2303 mod2304))) (and l2305 (cons (wrap1110 (car e2302) w2303 mod2304) l2305)))) ((null? e2302) (quote ())) ((syntax-object?1066 e2302) (match-each-any2278 (syntax-object-expression1067 e2302) (join-wraps1101 w2303 (syntax-object-wrap1068 e2302)) mod2304)) (else #f)))) (match-each2277 (lambda (e2306 p2307 w2308 mod2309) (cond ((annotation? e2306) (match-each2277 (annotation-expression e2306) p2307 w2308 mod2309)) ((pair? e2306) (let ((first2310 (match2281 (car e2306) p2307 w2308 (quote ()) mod2309))) (and first2310 (let ((rest2311 (match-each2277 (cdr e2306) p2307 w2308 mod2309))) (and rest2311 (cons first2310 rest2311)))))) ((null? e2306) (quote ())) ((syntax-object?1066 e2306) (match-each2277 (syntax-object-expression1067 e2306) p2307 (join-wraps1101 w2308 (syntax-object-wrap1068 e2306)) (syntax-object-module1069 e2306))) (else #f))))) (set! $sc-dispatch (lambda (e2312 p2313) (cond ((eq? p2313 (quote any)) (list e2312)) ((syntax-object?1066 e2312) (match*2280 (let ((e2314 (syntax-object-expression1067 e2312))) (if (annotation? e2314) (annotation-expression e2314) e2314)) p2313 (syntax-object-wrap1068 e2312) (quote ()) (syntax-object-module1069 e2312))) (else (match*2280 (let ((e2315 e2312)) (if (annotation? e2315) (annotation-expression e2315) e2315)) p2313 (quote (())) (quote ()) #f)))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x2316) ((lambda (tmp2317) ((lambda (tmp2318) (if tmp2318 (apply (lambda (_2319 e12320 e22321) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e12320 e22321))) tmp2318) ((lambda (tmp2323) (if tmp2323 (apply (lambda (_2324 out2325 in2326 e12327 e22328) (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"))) (hygiene guile))) in2326 (quote ()) (list out2325 (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"))) (hygiene guile))) (cons e12327 e22328))))) tmp2323) ((lambda (tmp2330) (if tmp2330 (apply (lambda (_2331 out2332 in2333 e12334 e22335) (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"))) (hygiene guile))) (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"))) (hygiene guile))) in2333) (quote ()) (list out2332 (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"))) (hygiene guile))) (cons e12334 e22335))))) tmp2330) (syntax-violation #f "source expression failed to match any pattern" tmp2317))) ($sc-dispatch tmp2317 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2317 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp2317 (quote (any () any . each-any))))) x2316)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x2339) ((lambda (tmp2340) ((lambda (tmp2341) (if tmp2341 (apply (lambda (_2342 k2343 keyword2344 pattern2345 template2346) (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"))) (hygiene guile))) (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"))) (hygiene guile)))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (cons k2343 (map (lambda (tmp2349 tmp2348) (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"))) (hygiene guile))) tmp2348) (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"))) (hygiene guile))) tmp2349))) template2346 pattern2345)))))) tmp2341) (syntax-violation #f "source expression failed to match any pattern" tmp2340))) ($sc-dispatch tmp2340 (quote (any each-any . #(each ((any . any) any))))))) x2339)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x2350) ((lambda (tmp2351) ((lambda (tmp2352) (if (if tmp2352 (apply (lambda (let*2353 x2354 v2355 e12356 e22357) (andmap identifier? x2354)) tmp2352) #f) (apply (lambda (let*2359 x2360 v2361 e12362 e22363) (let f2364 ((bindings2365 (map list x2360 v2361))) (if (null? bindings2365) (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"))) (hygiene guile))) (cons (quote ()) (cons e12362 e22363))) ((lambda (tmp2369) ((lambda (tmp2370) (if tmp2370 (apply (lambda (body2371 binding2372) (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"))) (hygiene guile))) (list binding2372) body2371)) tmp2370) (syntax-violation #f "source expression failed to match any pattern" tmp2369))) ($sc-dispatch tmp2369 (quote (any any))))) (list (f2364 (cdr bindings2365)) (car bindings2365)))))) tmp2352) (syntax-violation #f "source expression failed to match any pattern" tmp2351))) ($sc-dispatch tmp2351 (quote (any #(each (any any)) any . each-any))))) x2350)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x2373) ((lambda (tmp2374) ((lambda (tmp2375) (if tmp2375 (apply (lambda (_2376 var2377 init2378 step2379 e02380 e12381 c2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (apply (lambda (step2385) ((lambda (tmp2386) ((lambda (tmp2387) (if tmp2387 (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var2377 init2378) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e02380) (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"))) (hygiene guile))) (append c2382 (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"))) (hygiene guile))) step2385))))))) tmp2387) ((lambda (tmp2392) (if tmp2392 (apply (lambda (e12393 e22394) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var2377 init2378) (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"))) (hygiene guile))) e02380 (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"))) (hygiene guile))) (cons e12393 e22394)) (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"))) (hygiene guile))) (append c2382 (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"))) (hygiene guile))) step2385))))))) tmp2392) (syntax-violation #f "source expression failed to match any pattern" tmp2386))) ($sc-dispatch tmp2386 (quote (any . each-any)))))) ($sc-dispatch tmp2386 (quote ())))) e12381)) tmp2384) (syntax-violation #f "source expression failed to match any pattern" tmp2383))) ($sc-dispatch tmp2383 (quote each-any)))) (map (lambda (v2401 s2402) ((lambda (tmp2403) ((lambda (tmp2404) (if tmp2404 (apply (lambda () v2401) tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (e2406) e2406) tmp2405) ((lambda (_2407) (syntax-violation (quote do) "bad step expression" orig-x2373 s2402)) tmp2403))) ($sc-dispatch tmp2403 (quote (any)))))) ($sc-dispatch tmp2403 (quote ())))) s2402)) var2377 step2379))) tmp2375) (syntax-violation #f "source expression failed to match any pattern" tmp2374))) ($sc-dispatch tmp2374 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x2373)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons2410 (lambda (x2414 y2415) ((lambda (tmp2416) ((lambda (tmp2417) (if tmp2417 (apply (lambda (x2418 y2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda (dy2422) ((lambda (tmp2423) ((lambda (tmp2424) (if tmp2424 (apply (lambda (dx2425) (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"))) (hygiene guile))) (cons dx2425 dy2422))) tmp2424) ((lambda (_2426) (if (null? dy2422) (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"))) (hygiene guile))) x2418) (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"))) (hygiene guile))) x2418 y2419))) tmp2423))) ($sc-dispatch tmp2423 (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"))) (hygiene guile))) any))))) x2418)) tmp2421) ((lambda (tmp2427) (if tmp2427 (apply (lambda (stuff2428) (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"))) (hygiene guile))) (cons x2418 stuff2428))) tmp2427) ((lambda (else2429) (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"))) (hygiene guile))) x2418 y2419)) tmp2420))) ($sc-dispatch tmp2420 (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"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp2420 (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"))) (hygiene guile))) any))))) y2419)) tmp2417) (syntax-violation #f "source expression failed to match any pattern" tmp2416))) ($sc-dispatch tmp2416 (quote (any any))))) (list x2414 y2415)))) (quasiappend2411 (lambda (x2430 y2431) ((lambda (tmp2432) ((lambda (tmp2433) (if tmp2433 (apply (lambda (x2434 y2435) ((lambda (tmp2436) ((lambda (tmp2437) (if tmp2437 (apply (lambda () x2434) tmp2437) ((lambda (_2438) (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"))) (hygiene guile))) x2434 y2435)) tmp2436))) ($sc-dispatch tmp2436 (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"))) (hygiene guile))) ()))))) y2435)) tmp2433) (syntax-violation #f "source expression failed to match any pattern" tmp2432))) ($sc-dispatch tmp2432 (quote (any any))))) (list x2430 y2431)))) (quasivector2412 (lambda (x2439) ((lambda (tmp2440) ((lambda (x2441) ((lambda (tmp2442) ((lambda (tmp2443) (if tmp2443 (apply (lambda (x2444) (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"))) (hygiene guile))) (list->vector x2444))) tmp2443) ((lambda (tmp2446) (if tmp2446 (apply (lambda (x2447) (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"))) (hygiene guile))) x2447)) tmp2446) ((lambda (_2449) (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"))) (hygiene guile))) x2441)) tmp2442))) ($sc-dispatch tmp2442 (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"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp2442 (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"))) (hygiene guile))) each-any))))) x2441)) tmp2440)) x2439))) (quasi2413 (lambda (p2450 lev2451) ((lambda (tmp2452) ((lambda (tmp2453) (if tmp2453 (apply (lambda (p2454) (if (= lev2451 0) p2454 (quasicons2410 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2413 (list p2454) (- lev2451 1))))) tmp2453) ((lambda (tmp2455) (if tmp2455 (apply (lambda (p2456 q2457) (if (= lev2451 0) (quasiappend2411 p2456 (quasi2413 q2457 lev2451)) (quasicons2410 (quasicons2410 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2413 (list p2456) (- lev2451 1))) (quasi2413 q2457 lev2451)))) tmp2455) ((lambda (tmp2458) (if tmp2458 (apply (lambda (p2459) (quasicons2410 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi2413 (list p2459) (+ lev2451 1)))) tmp2458) ((lambda (tmp2460) (if tmp2460 (apply (lambda (p2461 q2462) (quasicons2410 (quasi2413 p2461 lev2451) (quasi2413 q2462 lev2451))) tmp2460) ((lambda (tmp2463) (if tmp2463 (apply (lambda (x2464) (quasivector2412 (quasi2413 x2464 lev2451))) tmp2463) ((lambda (p2466) (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"))) (hygiene guile))) p2466)) tmp2452))) ($sc-dispatch tmp2452 (quote #(vector each-any)))))) ($sc-dispatch tmp2452 (quote (any . any)))))) ($sc-dispatch tmp2452 (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"))) (hygiene guile))) any)))))) ($sc-dispatch tmp2452 (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"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp2452 (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"))) (hygiene guile))) any))))) p2450)))) (lambda (x2467) ((lambda (tmp2468) ((lambda (tmp2469) (if tmp2469 (apply (lambda (_2470 e2471) (quasi2413 e2471 0)) tmp2469) (syntax-violation #f "source expression failed to match any pattern" tmp2468))) ($sc-dispatch tmp2468 (quote (any any))))) x2467))))) +(define include (make-syncase-macro (quote macro) (lambda (x2472) (letrec ((read-file2473 (lambda (fn2474 k2475) (let ((p2476 (open-input-file fn2474))) (let f2477 ((x2478 (read p2476))) (if (eof-object? x2478) (begin (close-input-port p2476) (quote ())) (cons (datum->syntax k2475 x2478) (f2477 (read p2476))))))))) ((lambda (tmp2479) ((lambda (tmp2480) (if tmp2480 (apply (lambda (k2481 filename2482) (let ((fn2483 (syntax->datum filename2482))) ((lambda (tmp2484) ((lambda (tmp2485) (if tmp2485 (apply (lambda (exp2486) (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"))) (hygiene guile))) exp2486)) tmp2485) (syntax-violation #f "source expression failed to match any pattern" tmp2484))) ($sc-dispatch tmp2484 (quote each-any)))) (read-file2473 fn2483 k2481)))) tmp2480) (syntax-violation #f "source expression failed to match any pattern" tmp2479))) ($sc-dispatch tmp2479 (quote (any any))))) x2472))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x2488) ((lambda (tmp2489) ((lambda (tmp2490) (if tmp2490 (apply (lambda (_2491 e2492) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum e2492))) tmp2490) (syntax-violation #f "source expression failed to match any pattern" tmp2489))) ($sc-dispatch tmp2489 (quote (any any))))) x2488)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x2493) ((lambda (tmp2494) ((lambda (tmp2495) (if tmp2495 (apply (lambda (_2496 e2497) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax->datum e2497))) tmp2495) (syntax-violation #f "source expression failed to match any pattern" tmp2494))) ($sc-dispatch tmp2494 (quote (any any))))) x2493)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x2498) ((lambda (tmp2499) ((lambda (tmp2500) (if tmp2500 (apply (lambda (_2501 e2502 m12503 m22504) ((lambda (tmp2505) ((lambda (body2506) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e2502)) body2506)) tmp2505)) (let f2507 ((clause2508 m12503) (clauses2509 m22504)) (if (null? clauses2509) ((lambda (tmp2511) ((lambda (tmp2512) (if tmp2512 (apply (lambda (e12513 e22514) (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"))) (hygiene guile))) (cons e12513 e22514))) tmp2512) ((lambda (tmp2516) (if tmp2516 (apply (lambda (k2517 e12518 e22519) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k2517)) (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"))) (hygiene guile))) (cons e12518 e22519)))) tmp2516) ((lambda (_2522) (syntax-violation (quote case) "bad clause" x2498 clause2508)) tmp2511))) ($sc-dispatch tmp2511 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2511 (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"))) (hygiene guile))) any . each-any))))) clause2508) ((lambda (tmp2523) ((lambda (rest2524) ((lambda (tmp2525) ((lambda (tmp2526) (if tmp2526 (apply (lambda (k2527 e12528 e22529) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k2527)) (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"))) (hygiene guile))) (cons e12528 e22529)) rest2524)) tmp2526) ((lambda (_2532) (syntax-violation (quote case) "bad clause" x2498 clause2508)) tmp2525))) ($sc-dispatch tmp2525 (quote (each-any any . each-any))))) clause2508)) tmp2523)) (f2507 (car clauses2509) (cdr clauses2509))))))) tmp2500) (syntax-violation #f "source expression failed to match any pattern" tmp2499))) ($sc-dispatch tmp2499 (quote (any any any . each-any))))) x2498)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x2533) ((lambda (tmp2534) ((lambda (tmp2535) (if tmp2535 (apply (lambda (_2536 e2537) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e2537)) (list (cons _2536 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e2537 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp2535) (syntax-violation #f "source expression failed to match any pattern" tmp2534))) ($sc-dispatch tmp2534 (quote (any any))))) x2533)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 0af35dca9..2cf83f771 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -339,19 +339,31 @@ (define put-global-definition-hook (lambda (symbol type val) - (module-define-keyword! (current-module) symbol type val))) - -(define remove-global-definition-hook - (lambda (symbol) - (module-undefine-keyword! (current-module) symbol))) + (let ((existing (let ((v (module-variable (current-module) symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) + (not (syncase-macro-type val)) + val)))))) + (module-define! (current-module) + symbol + (if existing + (make-extended-syncase-macro existing type val) + (make-syncase-macro type val)))))) (define get-global-definition-hook (lambda (symbol module) (if (and (not module) (current-module)) (warn "module system is booted, we should have a module" symbol)) - (module-lookup-keyword (if module (resolve-module (cdr module)) - (current-module)) - symbol))) + (let ((v (module-variable (if module + (resolve-module (cdr module)) + (current-module)) + symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) (syncase-macro-type val) + (cons (syncase-macro-type val) + (syncase-macro-binding val)))))))) ) @@ -897,8 +909,25 @@ (define chi-install-global (lambda (name e) (build-application no-source - (build-primref no-source 'install-global-transformer) - (list (build-data no-source name) e)))) + (build-primref no-source 'define) + (list + name + ;; FIXME: seems nasty to call current-module here + (if (let ((v (module-variable (current-module) name))) + ;; FIXME use primitive-macro? + (and v (variable-bound? v) (macro? (variable-ref v)) + (not (eq? (macro-type (variable-ref v)) 'syncase-macro)))) + (build-application no-source + (build-primref no-source 'make-extended-syncase-macro) + (list (build-application no-source + (build-primref no-source 'module-ref) + (list (build-application no-source 'current-module '()) + (build-data no-source name))) + (build-data no-source 'macro) + e)) + (build-application no-source + (build-primref no-source 'make-syncase-macro) + (list (build-data no-source 'macro) e))))))) (define chi-when-list (lambda (e when-list w) @@ -1098,18 +1127,13 @@ (let* ((n (id-var-name value w)) (type (binding-type (lookup n r mod)))) (case type - ((global) + ((global core macro module-ref) (eval-if-c&e m (build-global-definition s n (chi e r w mod) mod) mod)) ((displaced-lexical) (syntax-violation #f "identifier out of context" e (wrap value w mod))) - ((core macro module-ref) - (remove-global-definition-hook n) - (eval-if-c&e m - (build-global-definition s n (chi e r w mod) mod) - mod)) (else (syntax-violation #f "cannot define keyword at top level" e (wrap value w mod)))))) -- cgit v1.2.3 From a1a482e0e9518b5711bc2734aa014254f9207919 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 May 2009 11:15:22 +0200 Subject: and, or, cond etc use syntax-rules, compile scheme through tree-il * libguile/vm-i-system.c: * libguile/vm-engine.h (ASSERT_BOUND): New assertion, that a value is bound. Used by local-ref and external-ref in paranoid mode. * module/ice-9/boot-9.scm (and, or, cond, case, do): Since we are switching to use psyntax as the first pass of the compiler, and perhaps soon of the interpreter too, we need to make sure it expands out all forms to primitive expressions. So define expanders for these derived syntax forms, as in the R5RS report. * module/ice-9/psyntax-pp.scm: Regenerate, with core forms fully expanded. * module/ice-9/psyntax.scm (build-void): New constructor, for making undefined values. (build-primref): Add in a hack so that primitive refs in the boot module expand out to toplevel refs, not module refs. (chi-void): Use build-void. (if): Define an expander for if that calls build-conditional. * module/language/scheme/compile-tree-il.scm (compile-tree-il): Use let* so as not to depend on binding order for the result of (current-module). * module/language/scheme/spec.scm (scheme): Switch over to tree-il as the primary intermediate language. Not yet fully tested, but at least it can compile psyntax-pp.scm. * module/language/tree-il/analyze.scm (analyze-lexicals): Arguments don't count towards a function's nlocs. * module/language/tree-il/compile-glil.scm (*comp-module*, compile-glil): Define a "compilation module" fluid. (flatten-lambda): Fix a call to make-glil-argument. Fix bug in heapifying arguments. (flatten): Fix number of arguments passed to apply instruction. Add a special case for `(values ...)'. If inlining primitive-refs fails, try expanding into toplevel-refs if the comp-module's variable is the same as the root variable. * module/language/tree-il/optimize.scm (resolve-primitives!): Add missing src variable for . * test-suite/tests/tree-il.test ("lambda"): Fix nlocs counts. Add a closure test case. --- libguile/vm-engine.h | 4 ++ libguile/vm-i-system.c | 2 + module/ice-9/boot-9.scm | 81 ++++++++++++++++++++++++++++++ module/ice-9/psyntax-pp.scm | 22 ++++---- module/ice-9/psyntax.scm | 35 +++++++++++-- module/language/scheme/compile-tree-il.scm | 6 +-- module/language/scheme/spec.scm | 6 ++- module/language/tree-il/analyze.scm | 2 +- module/language/tree-il/compile-glil.scm | 57 +++++++++++++++------ module/language/tree-il/optimize.scm | 2 +- test-suite/tests/tree-il.test | 28 ++++++++--- 11 files changed, 198 insertions(+), 47 deletions(-) (limited to 'libguile') diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 6bb235401..fbd2c6c75 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -147,8 +147,12 @@ #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) +#define ASSERT_BOUND(x) \ + do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \ + } while (0) #else #define CHECK_IP() +#define ASSERT_BOUND(x) #endif /* Get a local copy of the program's "object table" (i.e. the vector of diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 5468604d2..a6cb66dbc 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -230,6 +230,7 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1) VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); + ASSERT_BOUND (*sp); NEXT; } @@ -244,6 +245,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1) } CHECK_EXTERNAL(e); PUSH (SCM_CAR (e)); + ASSERT_BOUND (*sp); NEXT; } diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 94a9a39e2..cdd840f14 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -210,6 +210,87 @@ ;; module system has booted up. (define %pre-modules-transformer sc-expand) +(define-syntax and + (syntax-rules () + ((_) #t) + ((_ x) x) + ((_ x y ...) (if x (and y ...) #f)))) + +(define-syntax or + (syntax-rules () + ((_) #f) + ((_ x) x) + ((_ x y ...) (let ((t x)) (if t t (or y ...)))))) + +(define-syntax cond + (syntax-rules (else =>) + ((cond (else result1 result2 ...)) + (begin result1 result2 ...)) + ((cond (test => result)) + (let ((temp test)) + (if temp (result temp)))) + ((cond (test => result) clause1 clause2 ...) + (let ((temp test)) + (if temp + (result temp) + (cond clause1 clause2 ...)))) + ((cond (test)) test) + ((cond (test) clause1 clause2 ...) + (let ((temp test)) + (if temp + temp + (cond clause1 clause2 ...)))) + ((cond (test result1 result2 ...)) + (if test (begin result1 result2 ...))) + ((cond (test result1 result2 ...) + clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (cond clause1 clause2 ...))))) + +(define-syntax case + (syntax-rules (else) + ((case (key ...) + clauses ...) + (let ((atom-key (key ...))) + (case atom-key clauses ...))) + ((case key + (else result1 result2 ...)) + (begin result1 result2 ...)) + ((case key + ((atoms ...) result1 result2 ...)) + (if (memv key '(atoms ...)) + (begin result1 result2 ...))) + ((case key + ((atoms ...) result1 result2 ...) + clause clauses ...) + (if (memv key '(atoms ...)) + (begin result1 result2 ...) + (case key clause clauses ...))))) + +(define-syntax do + (syntax-rules () + ((do ((var init step ...) ...) + (test expr ...) + command ...) + (letrec + ((loop + (lambda (var ...) + (if test + (begin + (if #f #f) + expr ...) + (begin + command + ... + (loop (do "step" var step ...) + ...)))))) + (loop init ...))) + ((do "step" x) + x) + ((do "step" x y) + y))) + (define-syntax delay (syntax-rules () ((_ exp) (make-promise (lambda () exp))))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 55064eec8..829812eda 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,13 +1,13 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec ((and-map*17 (lambda (f57 first56 . rest55) (or (null? first56) (if (null? rest55) (letrec ((andmap58 (lambda (first59) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))))) (andmap58 first56)) (letrec ((andmap62 (lambda (first63 rest64) (let ((x65 (car first63)) (xr66 (map car rest64)) (first67 (cdr first63)) (rest68 (map cdr rest64))) (if (null? first67) (apply f57 (cons x65 xr66)) (and (apply f57 (cons x65 xr66)) (andmap62 first67 rest68))))))) (andmap62 first56 rest55))))))) (letrec ((lambda-var-list160 (lambda (vars289) (letrec ((lvl290 (lambda (vars291 ls292 w293) (cond ((pair? vars291) (lvl290 (cdr vars291) (cons (wrap139 (car vars291) w293 #f) ls292) w293)) ((id?111 vars291) (cons (wrap139 vars291 w293 #f) ls292)) ((null? vars291) ls292) ((syntax-object?95 vars291) (lvl290 (syntax-object-expression96 vars291) ls292 (join-wraps130 w293 (syntax-object-wrap97 vars291)))) ((annotation? vars291) (lvl290 (annotation-expression vars291) ls292 w293)) (else (cons vars291 ls292)))))) (lvl290 vars289 (quote ()) (quote (())))))) (gen-var159 (lambda (id294) (let ((id295 (if (syntax-object?95 id294) (syntax-object-expression96 id294) id294))) (if (annotation? id295) (gensym (symbol->string (annotation-expression id295))) (gensym (symbol->string id295)))))) (strip158 (lambda (x296 w297) (if (memq (quote top) (wrap-marks114 w297)) (if (or (annotation? x296) (and (pair? x296) (annotation? (car x296)))) (strip-annotation157 x296 #f) x296) (letrec ((f298 (lambda (x299) (cond ((syntax-object?95 x299) (strip158 (syntax-object-expression96 x299) (syntax-object-wrap97 x299))) ((pair? x299) (let ((a300 (f298 (car x299))) (d301 (f298 (cdr x299)))) (if (and (eq? a300 (car x299)) (eq? d301 (cdr x299))) x299 (cons a300 d301)))) ((vector? x299) (let ((old302 (vector->list x299))) (let ((new303 (map f298 old302))) (if (and-map*17 eq? old302 new303) x299 (list->vector new303))))) (else x299))))) (f298 x296))))) (strip-annotation157 (lambda (x304 parent305) (cond ((pair? x304) (let ((new306 (cons #f #f))) (begin (if parent305 (set-annotation-stripped! parent305 new306)) (set-car! new306 (strip-annotation157 (car x304) #f)) (set-cdr! new306 (strip-annotation157 (cdr x304) #f)) new306))) ((annotation? x304) (or (annotation-stripped x304) (strip-annotation157 (annotation-expression x304) x304))) ((vector? x304) (let ((new307 (make-vector (vector-length x304)))) (begin (if parent305 (set-annotation-stripped! parent305 new307)) (letrec ((loop308 (lambda (i309) (unless (fx<74 i309 0) (vector-set! new307 i309 (strip-annotation157 (vector-ref x304 i309) #f)) (loop308 (fx-72 i309 1)))))) (loop308 (- (vector-length x304) 1))) new307))) (else x304)))) (ellipsis?156 (lambda (x310) (and (nonsymbol-id?110 x310) (free-id=?134 x310 (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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))))))) (chi-void155 (lambda () (build-application79 #f (build-primref88 #f (quote if)) (quote (#f #f))))) (eval-local-transformer154 (lambda (expanded311 mod312) (let ((p313 (local-eval-hook76 expanded311 mod312))) (if (procedure? p313) p313 (syntax-violation #f "nonprocedure transformer" p313))))) (chi-local-syntax153 (lambda (rec?314 e315 r316 w317 s318 mod319 k320) ((lambda (tmp321) ((lambda (tmp322) (if tmp322 (apply (lambda (_323 id324 val325 e1326 e2327) (let ((ids328 id324)) (if (not (valid-bound-ids?136 ids328)) (syntax-violation #f "duplicate bound keyword" e315) (let ((labels330 (gen-labels117 ids328))) (let ((new-w331 (make-binding-wrap128 ids328 labels330 w317))) (k320 (cons e1326 e2327) (extend-env105 labels330 (let ((w333 (if rec?314 new-w331 w317)) (trans-r334 (macros-only-env107 r316))) (map (lambda (x335) (cons (quote macro) (eval-local-transformer154 (chi147 x335 trans-r334 w333 mod319) mod319))) val325)) r316) new-w331 s318 mod319)))))) tmp322) ((lambda (_337) (syntax-violation #f "bad local syntax definition" (source-wrap140 e315 w317 s318 mod319))) tmp321))) ($sc-dispatch tmp321 (quote (any #(each (any any)) any . each-any))))) e315))) (chi-lambda-clause152 (lambda (e338 docstring339 c340 r341 w342 mod343 k344) ((lambda (tmp345) ((lambda (tmp346) (if (if tmp346 (apply (lambda (args347 doc348 e1349 e2350) (and (string? (syntax->datum doc348)) (not docstring339))) tmp346) #f) (apply (lambda (args351 doc352 e1353 e2354) (chi-lambda-clause152 e338 doc352 (cons args351 (cons e1353 e2354)) r341 w342 mod343 k344)) tmp346) ((lambda (tmp356) (if tmp356 (apply (lambda (id357 e1358 e2359) (let ((ids360 id357)) (if (not (valid-bound-ids?136 ids360)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels362 (gen-labels117 ids360)) (new-vars363 (map gen-var159 ids360))) (k344 (map syntax->datum ids360) new-vars363 docstring339 (chi-body151 (cons e1358 e2359) e338 (extend-var-env106 labels362 new-vars363 r341) (make-binding-wrap128 ids360 labels362 w342) mod343)))))) tmp356) ((lambda (tmp365) (if tmp365 (apply (lambda (ids366 e1367 e2368) (let ((old-ids369 (lambda-var-list160 ids366))) (if (not (valid-bound-ids?136 old-ids369)) (syntax-violation (quote lambda) "invalid parameter list" e338) (let ((labels370 (gen-labels117 old-ids369)) (new-vars371 (map gen-var159 old-ids369))) (k344 (letrec ((f372 (lambda (ls1373 ls2374) (if (null? ls1373) (syntax->datum ls2374) (f372 (cdr ls1373) (cons (syntax->datum (car ls1373)) ls2374)))))) (f372 (cdr old-ids369) (car old-ids369))) (letrec ((f375 (lambda (ls1376 ls2377) (if (null? ls1376) ls2377 (f375 (cdr ls1376) (cons (car ls1376) ls2377)))))) (f375 (cdr new-vars371) (car new-vars371))) docstring339 (chi-body151 (cons e1367 e2368) e338 (extend-var-env106 labels370 new-vars371 r341) (make-binding-wrap128 old-ids369 labels370 w342) mod343)))))) tmp365) ((lambda (_379) (syntax-violation (quote lambda) "bad lambda" e338)) tmp345))) ($sc-dispatch tmp345 (quote (any any . each-any)))))) ($sc-dispatch tmp345 (quote (each-any any . each-any)))))) ($sc-dispatch tmp345 (quote (any any any . each-any))))) c340))) (chi-body151 (lambda (body380 outer-form381 r382 w383 mod384) (let ((r385 (cons (quote ("placeholder" placeholder)) r382))) (let ((ribcage386 (make-ribcage118 (quote ()) (quote ()) (quote ())))) (let ((w387 (make-wrap113 (wrap-marks114 w383) (cons ribcage386 (wrap-subst115 w383))))) (letrec ((parse388 (lambda (body389 ids390 labels391 vars392 vals393 bindings394) (if (null? body389) (syntax-violation #f "no expressions in body" outer-form381) (let ((e396 (cdar body389)) (er397 (caar body389))) (call-with-values (lambda () (syntax-type145 e396 er397 (quote (())) #f ribcage386 mod384)) (lambda (type398 value399 e400 w401 s402 mod403) (let ((t404 type398)) (if (memv t404 (quote (define-form))) (let ((id405 (wrap139 value399 w401 mod403)) (label406 (gen-label116))) (let ((var407 (gen-var159 id405))) (begin (extend-ribcage!127 ribcage386 id405 label406) (parse388 (cdr body389) (cons id405 ids390) (cons label406 labels391) (cons var407 vars392) (cons (cons er397 (wrap139 e400 w401 mod403)) vals393) (cons (cons (quote lexical) var407) bindings394))))) (if (memv t404 (quote (define-syntax-form))) (let ((id408 (wrap139 value399 w401 mod403)) (label409 (gen-label116))) (begin (extend-ribcage!127 ribcage386 id408 label409) (parse388 (cdr body389) (cons id408 ids390) (cons label409 labels391) vars392 vals393 (cons (cons (quote macro) (cons er397 (wrap139 e400 w401 mod403))) bindings394)))) (if (memv t404 (quote (begin-form))) ((lambda (tmp410) ((lambda (tmp411) (if tmp411 (apply (lambda (_412 e1413) (parse388 (letrec ((f414 (lambda (forms415) (if (null? forms415) (cdr body389) (cons (cons er397 (wrap139 (car forms415) w401 mod403)) (f414 (cdr forms415))))))) (f414 e1413)) ids390 labels391 vars392 vals393 bindings394)) tmp411) (syntax-violation #f "source expression failed to match any pattern" tmp410))) ($sc-dispatch tmp410 (quote (any . each-any))))) e400) (if (memv t404 (quote (local-syntax-form))) (chi-local-syntax153 value399 e400 er397 w401 s402 mod403 (lambda (forms417 er418 w419 s420 mod421) (parse388 (letrec ((f422 (lambda (forms423) (if (null? forms423) (cdr body389) (cons (cons er418 (wrap139 (car forms423) w419 mod421)) (f422 (cdr forms423))))))) (f422 forms417)) ids390 labels391 vars392 vals393 bindings394))) (if (null? ids390) (build-sequence90 #f (map (lambda (x424) (chi147 (cdr x424) (car x424) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389)))) (begin (if (not (valid-bound-ids?136 ids390)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form381)) (letrec ((loop425 (lambda (bs426 er-cache427 r-cache428) (if (not (null? bs426)) (let ((b429 (car bs426))) (if (eq? (car b429) (quote macro)) (let ((er430 (cadr b429))) (let ((r-cache431 (if (eq? er430 er-cache427) r-cache428 (macros-only-env107 er430)))) (begin (set-cdr! b429 (eval-local-transformer154 (chi147 (cddr b429) r-cache431 (quote (())) mod403) mod403)) (loop425 (cdr bs426) er430 r-cache431)))) (loop425 (cdr bs426) er-cache427 r-cache428))))))) (loop425 bindings394 #f #f)) (set-cdr! r385 (extend-env105 labels391 bindings394 (cdr r385))) (build-letrec93 #f (map syntax->datum ids390) vars392 (map (lambda (x432) (chi147 (cdr x432) (car x432) (quote (())) mod403)) vals393) (build-sequence90 #f (map (lambda (x433) (chi147 (cdr x433) (car x433) (quote (())) mod403)) (cons (cons er397 (source-wrap140 e400 w401 s402 mod403)) (cdr body389))))))))))))))))))) (parse388 (map (lambda (x395) (cons r385 (wrap139 x395 w387 mod384))) body380) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro150 (lambda (p434 e435 r436 w437 rib438 mod439) (letrec ((rebuild-macro-output440 (lambda (x441 m442) (cond ((pair? x441) (cons (rebuild-macro-output440 (car x441) m442) (rebuild-macro-output440 (cdr x441) m442))) ((syntax-object?95 x441) (let ((w443 (syntax-object-wrap97 x441))) (let ((ms444 (wrap-marks114 w443)) (s445 (wrap-subst115 w443))) (if (and (pair? ms444) (eq? (car ms444) #f)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cdr ms444) (if rib438 (cons rib438 (cdr s445)) (cdr s445))) (syntax-object-module98 x441)) (make-syntax-object94 (syntax-object-expression96 x441) (make-wrap113 (cons m442 ms444) (if rib438 (cons rib438 (cons (quote shift) s445)) (cons (quote shift) s445))) (let ((pmod446 (procedure-module p434))) (if pmod446 (cons (quote hygiene) (module-name pmod446)) (quote (hygiene guile))))))))) ((vector? x441) (let ((n447 (vector-length x441))) (let ((v448 (make-vector n447))) (letrec ((doloop449 (lambda (i450) (if (fx=73 i450 n447) v448 (begin (vector-set! v448 i450 (rebuild-macro-output440 (vector-ref x441 i450) m442)) (doloop449 (fx+71 i450 1))))))) (doloop449 0))))) ((symbol? x441) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap140 e435 w437 s mod439) x441)) (else x441))))) (rebuild-macro-output440 (p434 (wrap139 e435 (anti-mark126 w437) mod439)) (string #\m))))) (chi-application149 (lambda (x451 e452 r453 w454 s455 mod456) ((lambda (tmp457) ((lambda (tmp458) (if tmp458 (apply (lambda (e0459 e1460) (build-application79 s455 x451 (map (lambda (e461) (chi147 e461 r453 w454 mod456)) e1460))) tmp458) (syntax-violation #f "source expression failed to match any pattern" tmp457))) ($sc-dispatch tmp457 (quote (any . each-any))))) e452))) (chi-expr148 (lambda (type463 value464 e465 r466 w467 s468 mod469) (let ((t470 type463)) (if (memv t470 (quote (lexical))) (build-lexical-reference81 (quote value) s468 e465 value464) (if (memv t470 (quote (core external-macro))) (value464 e465 r466 w467 s468 mod469) (if (memv t470 (quote (module-ref))) (call-with-values (lambda () (value464 e465)) (lambda (id471 mod472) (build-global-reference84 s468 id471 mod472))) (if (memv t470 (quote (lexical-call))) (chi-application149 (build-lexical-reference81 (quote fun) (source-annotation102 (car e465)) (car e465) value464) e465 r466 w467 s468 mod469) (if (memv t470 (quote (global-call))) (chi-application149 (build-global-reference84 (source-annotation102 (car e465)) value464 (if (syntax-object?95 (car e465)) (syntax-object-module98 (car e465)) mod469)) e465 r466 w467 s468 mod469) (if (memv t470 (quote (constant))) (build-data89 s468 (strip158 (source-wrap140 e465 w467 s468 mod469) (quote (())))) (if (memv t470 (quote (global))) (build-global-reference84 s468 value464 mod469) (if (memv t470 (quote (call))) (chi-application149 (chi147 (car e465) r466 w467 mod469) e465 r466 w467 s468 mod469) (if (memv t470 (quote (begin-form))) ((lambda (tmp473) ((lambda (tmp474) (if tmp474 (apply (lambda (_475 e1476 e2477) (chi-sequence141 (cons e1476 e2477) r466 w467 s468 mod469)) tmp474) (syntax-violation #f "source expression failed to match any pattern" tmp473))) ($sc-dispatch tmp473 (quote (any any . each-any))))) e465) (if (memv t470 (quote (local-syntax-form))) (chi-local-syntax153 value464 e465 r466 w467 s468 mod469 chi-sequence141) (if (memv t470 (quote (eval-when-form))) ((lambda (tmp479) ((lambda (tmp480) (if tmp480 (apply (lambda (_481 x482 e1483 e2484) (let ((when-list485 (chi-when-list144 e465 x482 w467))) (if (memq (quote eval) when-list485) (chi-sequence141 (cons e1483 e2484) r466 w467 s468 mod469) (chi-void155)))) tmp480) (syntax-violation #f "source expression failed to match any pattern" tmp479))) ($sc-dispatch tmp479 (quote (any each-any any . each-any))))) e465) (if (memv t470 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e465 (wrap139 value464 w467 mod469)) (if (memv t470 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap140 e465 w467 s468 mod469)) (if (memv t470 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap140 e465 w467 s468 mod469)) (syntax-violation #f "unexpected syntax" (source-wrap140 e465 w467 s468 mod469))))))))))))))))))) (chi147 (lambda (e488 r489 w490 mod491) (call-with-values (lambda () (syntax-type145 e488 r489 w490 #f #f mod491)) (lambda (type492 value493 e494 w495 s496 mod497) (chi-expr148 type492 value493 e494 r489 w495 s496 mod497))))) (chi-top146 (lambda (e498 r499 w500 m501 esew502 mod503) (call-with-values (lambda () (syntax-type145 e498 r499 w500 #f #f mod503)) (lambda (type511 value512 e513 w514 s515 mod516) (let ((t517 type511)) (if (memv t517 (quote (begin-form))) ((lambda (tmp518) ((lambda (tmp519) (if tmp519 (apply (lambda (_520) (chi-void155)) tmp519) ((lambda (tmp521) (if tmp521 (apply (lambda (_522 e1523 e2524) (chi-top-sequence142 (cons e1523 e2524) r499 w514 s515 m501 esew502 mod516)) tmp521) (syntax-violation #f "source expression failed to match any pattern" tmp518))) ($sc-dispatch tmp518 (quote (any any . each-any)))))) ($sc-dispatch tmp518 (quote (any))))) e513) (if (memv t517 (quote (local-syntax-form))) (chi-local-syntax153 value512 e513 r499 w514 s515 mod516 (lambda (body526 r527 w528 s529 mod530) (chi-top-sequence142 body526 r527 w528 s529 m501 esew502 mod530))) (if (memv t517 (quote (eval-when-form))) ((lambda (tmp531) ((lambda (tmp532) (if tmp532 (apply (lambda (_533 x534 e1535 e2536) (let ((when-list537 (chi-when-list144 e513 x534 w514)) (body538 (cons e1535 e2536))) (cond ((eq? m501 (quote e)) (if (memq (quote eval) when-list537) (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) (chi-void155))) ((memq (quote load) when-list537) (if (or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (chi-top-sequence142 body538 r499 w514 s515 (quote c&e) (quote (compile load)) mod516) (if (memq m501 (quote (c c&e))) (chi-top-sequence142 body538 r499 w514 s515 (quote c) (quote (load)) mod516) (chi-void155)))) ((or (memq (quote compile) when-list537) (and (eq? m501 (quote c&e)) (memq (quote eval) when-list537))) (top-level-eval-hook75 (chi-top-sequence142 body538 r499 w514 s515 (quote e) (quote (eval)) mod516) mod516) (chi-void155)) (else (chi-void155))))) tmp532) (syntax-violation #f "source expression failed to match any pattern" tmp531))) ($sc-dispatch tmp531 (quote (any each-any any . each-any))))) e513) (if (memv t517 (quote (define-syntax-form))) (let ((n541 (id-var-name133 value512 w514)) (r542 (macros-only-env107 r499))) (let ((t543 m501)) (if (memv t543 (quote (c))) (if (memq (quote compile) esew502) (let ((e544 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e544 mod516) (if (memq (quote load) esew502) e544 (chi-void155)))) (if (memq (quote load) esew502) (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) (chi-void155))) (if (memv t543 (quote (c&e))) (let ((e545 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)))) (begin (top-level-eval-hook75 e545 mod516) e545)) (begin (if (memq (quote eval) esew502) (top-level-eval-hook75 (chi-install-global143 n541 (chi147 e513 r542 w514 mod516)) mod516)) (chi-void155)))))) (if (memv t517 (quote (define-form))) (let ((n546 (id-var-name133 value512 w514))) (let ((type547 (binding-type103 (lookup108 n546 r499 mod516)))) (let ((t548 type547)) (if (memv t548 (quote (global core macro module-ref))) (let ((x549 (build-global-definition86 s515 n546 (chi147 e513 r499 w514 mod516)))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x549 mod516)) x549)) (if (memv t548 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e513 (wrap139 value512 w514 mod516)) (syntax-violation #f "cannot define keyword at top level" e513 (wrap139 value512 w514 mod516))))))) (let ((x550 (chi-expr148 type511 value512 e513 r499 w514 s515 mod516))) (begin (if (eq? m501 (quote c&e)) (top-level-eval-hook75 x550 mod516)) x550)))))))))))) (syntax-type145 (lambda (e551 r552 w553 s554 rib555 mod556) (cond ((symbol? e551) (let ((n557 (id-var-name133 e551 w553))) (let ((b558 (lookup108 n557 r552 mod556))) (let ((type559 (binding-type103 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value104 b558) e551 w553 s554 mod556) (if (memv t560 (quote (global))) (values type559 n557 e551 w553 s554 mod556) (if (memv t560 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b558) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (values type559 (binding-value104 b558) e551 w553 s554 mod556))))))))) ((pair? e551) (let ((first561 (car e551))) (if (id?111 first561) (let ((n562 (id-var-name133 first561 w553))) (let ((b563 (lookup108 n562 r552 (or (and (syntax-object?95 first561) (syntax-object-module98 first561)) mod556)))) (let ((type564 (binding-type103 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (global))) (values (quote global-call) n562 e551 w553 s554 mod556) (if (memv t565 (quote (macro))) (syntax-type145 (chi-macro150 (binding-value104 b563) e551 r552 w553 rib555 mod556) r552 (quote (())) s554 rib555 mod556) (if (memv t565 (quote (core external-macro module-ref))) (values type564 (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value104 b563) e551 w553 s554 mod556) (if (memv t565 (quote (begin))) (values (quote begin-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) #f e551 w553 s554 mod556) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?111 name569)) tmp567) #f) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w553 s554 mod556)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?111 name576) (valid-bound-ids?136 (lambda-var-list160 args577)))) tmp574) #f) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap139 name581 w553 mod556) (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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap139 (cons args582 (cons e1583 e2584)) w553 mod556)) (quote (())) s554 mod556)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?111 name588)) tmp586) #f) (apply (lambda (_589 name590) (values (quote define-form) (wrap139 name590 w553 mod556) (quote (#(syntax-object if ((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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s554 mod556)) tmp586) (syntax-violation #f "source expression failed to match any pattern" tmp566))) ($sc-dispatch tmp566 (quote (any any)))))) ($sc-dispatch tmp566 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp566 (quote (any any any))))) e551) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?111 name594)) tmp592) #f) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w553 s554 mod556)) tmp592) (syntax-violation #f "source expression failed to match any pattern" tmp591))) ($sc-dispatch tmp591 (quote (any any any))))) e551) (values (quote call) #f e551 w553 s554 mod556)))))))))))))) (values (quote call) #f e551 w553 s554 mod556)))) ((syntax-object?95 e551) (syntax-type145 (syntax-object-expression96 e551) r552 (join-wraps130 w553 (syntax-object-wrap97 e551)) #f rib555 (or (syntax-object-module98 e551) mod556))) ((annotation? e551) (syntax-type145 (annotation-expression e551) r552 w553 (annotation-source e551) rib555 mod556)) ((self-evaluating? e551) (values (quote constant) #f e551 w553 s554 mod556)) (else (values (quote other) #f e551 w553 s554 mod556))))) (chi-when-list144 (lambda (e599 when-list600 w601) (letrec ((f602 (lambda (when-list603 situations604) (if (null? when-list603) situations604 (f602 (cdr when-list603) (cons (let ((x605 (car when-list603))) (cond ((free-id=?134 x605 (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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile)) ((free-id=?134 x605 (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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load)) ((free-id=?134 x605 (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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval)) (else (syntax-violation (quote eval-when) "invalid situation" e599 (wrap139 x605 w601 #f))))) situations604)))))) (f602 when-list600 (quote ()))))) (chi-install-global143 (lambda (name606 e607) (build-global-definition86 #f name606 (if (let ((v608 (module-variable (current-module) name606))) (and v608 (variable-bound? v608) (macro? (variable-ref v608)) (not (eq? (macro-type (variable-ref v608)) (quote syncase-macro))))) (build-application79 #f (build-primref88 #f (quote make-extended-syncase-macro)) (list (build-application79 #f (build-primref88 #f (quote module-ref)) (list (build-application79 #f (quote current-module) (quote ())) (build-data89 #f name606))) (build-data89 #f (quote macro)) e607)) (build-application79 #f (build-primref88 #f (quote make-syncase-macro)) (list (build-data89 #f (quote macro)) e607)))))) (chi-top-sequence142 (lambda (body609 r610 w611 s612 m613 esew614 mod615) (build-sequence90 s612 (letrec ((dobody616 (lambda (body617 r618 w619 m620 esew621 mod622) (if (null? body617) (quote ()) (let ((first623 (chi-top146 (car body617) r618 w619 m620 esew621 mod622))) (cons first623 (dobody616 (cdr body617) r618 w619 m620 esew621 mod622))))))) (dobody616 body609 r610 w611 m613 esew614 mod615))))) (chi-sequence141 (lambda (body624 r625 w626 s627 mod628) (build-sequence90 s627 (letrec ((dobody629 (lambda (body630 r631 w632 mod633) (if (null? body630) (quote ()) (let ((first634 (chi147 (car body630) r631 w632 mod633))) (cons first634 (dobody629 (cdr body630) r631 w632 mod633))))))) (dobody629 body624 r625 w626 mod628))))) (source-wrap140 (lambda (x635 w636 s637 defmod638) (wrap139 (if s637 (make-annotation x635 s637 #f) x635) w636 defmod638))) (wrap139 (lambda (x639 w640 defmod641) (cond ((and (null? (wrap-marks114 w640)) (null? (wrap-subst115 w640))) x639) ((syntax-object?95 x639) (make-syntax-object94 (syntax-object-expression96 x639) (join-wraps130 w640 (syntax-object-wrap97 x639)) (syntax-object-module98 x639))) ((null? x639) x639) (else (make-syntax-object94 x639 w640 defmod641))))) (bound-id-member?138 (lambda (x642 list643) (and (not (null? list643)) (or (bound-id=?135 x642 (car list643)) (bound-id-member?138 x642 (cdr list643)))))) (distinct-bound-ids?137 (lambda (ids644) (letrec ((distinct?645 (lambda (ids646) (or (null? ids646) (and (not (bound-id-member?138 (car ids646) (cdr ids646))) (distinct?645 (cdr ids646))))))) (distinct?645 ids644)))) (valid-bound-ids?136 (lambda (ids647) (and (letrec ((all-ids?648 (lambda (ids649) (or (null? ids649) (and (id?111 (car ids649)) (all-ids?648 (cdr ids649))))))) (all-ids?648 ids647)) (distinct-bound-ids?137 ids647)))) (bound-id=?135 (lambda (i650 j651) (if (and (syntax-object?95 i650) (syntax-object?95 j651)) (and (eq? (let ((e652 (syntax-object-expression96 i650))) (if (annotation? e652) (annotation-expression e652) e652)) (let ((e653 (syntax-object-expression96 j651))) (if (annotation? e653) (annotation-expression e653) e653))) (same-marks?132 (wrap-marks114 (syntax-object-wrap97 i650)) (wrap-marks114 (syntax-object-wrap97 j651)))) (eq? (let ((e654 i650)) (if (annotation? e654) (annotation-expression e654) e654)) (let ((e655 j651)) (if (annotation? e655) (annotation-expression e655) e655)))))) (free-id=?134 (lambda (i656 j657) (and (eq? (let ((x658 i656)) (let ((e659 (if (syntax-object?95 x658) (syntax-object-expression96 x658) x658))) (if (annotation? e659) (annotation-expression e659) e659))) (let ((x660 j657)) (let ((e661 (if (syntax-object?95 x660) (syntax-object-expression96 x660) x660))) (if (annotation? e661) (annotation-expression e661) e661)))) (eq? (id-var-name133 i656 (quote (()))) (id-var-name133 j657 (quote (()))))))) (id-var-name133 (lambda (id662 w663) (letrec ((search-vector-rib666 (lambda (sym672 subst673 marks674 symnames675 ribcage676) (let ((n677 (vector-length symnames675))) (letrec ((f678 (lambda (i679) (cond ((fx=73 i679 n677) (search664 sym672 (cdr subst673) marks674)) ((and (eq? (vector-ref symnames675 i679) sym672) (same-marks?132 marks674 (vector-ref (ribcage-marks121 ribcage676) i679))) (values (vector-ref (ribcage-labels122 ribcage676) i679) marks674)) (else (f678 (fx+71 i679 1))))))) (f678 0))))) (search-list-rib665 (lambda (sym680 subst681 marks682 symnames683 ribcage684) (letrec ((f685 (lambda (symnames686 i687) (cond ((null? symnames686) (search664 sym680 (cdr subst681) marks682)) ((and (eq? (car symnames686) sym680) (same-marks?132 marks682 (list-ref (ribcage-marks121 ribcage684) i687))) (values (list-ref (ribcage-labels122 ribcage684) i687) marks682)) (else (f685 (cdr symnames686) (fx+71 i687 1))))))) (f685 symnames683 0)))) (search664 (lambda (sym688 subst689 marks690) (if (null? subst689) (values #f marks690) (let ((fst691 (car subst689))) (if (eq? fst691 (quote shift)) (search664 sym688 (cdr subst689) (cdr marks690)) (let ((symnames692 (ribcage-symnames120 fst691))) (if (vector? symnames692) (search-vector-rib666 sym688 subst689 marks690 symnames692 fst691) (search-list-rib665 sym688 subst689 marks690 symnames692 fst691))))))))) (cond ((symbol? id662) (or (call-with-values (lambda () (search664 id662 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x694 . ignore693) x694)) id662)) ((syntax-object?95 id662) (let ((id695 (let ((e697 (syntax-object-expression96 id662))) (if (annotation? e697) (annotation-expression e697) e697))) (w1696 (syntax-object-wrap97 id662))) (let ((marks698 (join-marks131 (wrap-marks114 w663) (wrap-marks114 w1696)))) (call-with-values (lambda () (search664 id695 (wrap-subst115 w663) marks698)) (lambda (new-id699 marks700) (or new-id699 (call-with-values (lambda () (search664 id695 (wrap-subst115 w1696) marks700)) (lambda (x702 . ignore701) x702)) id695)))))) ((annotation? id662) (let ((id703 (let ((e704 id662)) (if (annotation? e704) (annotation-expression e704) e704)))) (or (call-with-values (lambda () (search664 id703 (wrap-subst115 w663) (wrap-marks114 w663))) (lambda (x706 . ignore705) x706)) id703))) (else (syntax-violation (quote id-var-name) "invalid id" id662)))))) (same-marks?132 (lambda (x707 y708) (or (eq? x707 y708) (and (not (null? x707)) (not (null? y708)) (eq? (car x707) (car y708)) (same-marks?132 (cdr x707) (cdr y708)))))) (join-marks131 (lambda (m1709 m2710) (smart-append129 m1709 m2710))) (join-wraps130 (lambda (w1711 w2712) (let ((m1713 (wrap-marks114 w1711)) (s1714 (wrap-subst115 w1711))) (if (null? m1713) (if (null? s1714) w2712 (make-wrap113 (wrap-marks114 w2712) (smart-append129 s1714 (wrap-subst115 w2712)))) (make-wrap113 (smart-append129 m1713 (wrap-marks114 w2712)) (smart-append129 s1714 (wrap-subst115 w2712))))))) (smart-append129 (lambda (m1715 m2716) (if (null? m2716) m1715 (append m1715 m2716)))) (make-binding-wrap128 (lambda (ids717 labels718 w719) (if (null? ids717) w719 (make-wrap113 (wrap-marks114 w719) (cons (let ((labelvec720 (list->vector labels718))) (let ((n721 (vector-length labelvec720))) (let ((symnamevec722 (make-vector n721)) (marksvec723 (make-vector n721))) (begin (letrec ((f724 (lambda (ids725 i726) (if (not (null? ids725)) (call-with-values (lambda () (id-sym-name&marks112 (car ids725) w719)) (lambda (symname727 marks728) (begin (vector-set! symnamevec722 i726 symname727) (vector-set! marksvec723 i726 marks728) (f724 (cdr ids725) (fx+71 i726 1))))))))) (f724 ids717 0)) (make-ribcage118 symnamevec722 marksvec723 labelvec720))))) (wrap-subst115 w719)))))) (extend-ribcage!127 (lambda (ribcage729 id730 label731) (begin (set-ribcage-symnames!123 ribcage729 (cons (let ((e732 (syntax-object-expression96 id730))) (if (annotation? e732) (annotation-expression e732) e732)) (ribcage-symnames120 ribcage729))) (set-ribcage-marks!124 ribcage729 (cons (wrap-marks114 (syntax-object-wrap97 id730)) (ribcage-marks121 ribcage729))) (set-ribcage-labels!125 ribcage729 (cons label731 (ribcage-labels122 ribcage729)))))) (anti-mark126 (lambda (w733) (make-wrap113 (cons #f (wrap-marks114 w733)) (cons (quote shift) (wrap-subst115 w733))))) (set-ribcage-labels!125 (lambda (x734 update735) (vector-set! x734 3 update735))) (set-ribcage-marks!124 (lambda (x736 update737) (vector-set! x736 2 update737))) (set-ribcage-symnames!123 (lambda (x738 update739) (vector-set! x738 1 update739))) (ribcage-labels122 (lambda (x740) (vector-ref x740 3))) (ribcage-marks121 (lambda (x741) (vector-ref x741 2))) (ribcage-symnames120 (lambda (x742) (vector-ref x742 1))) (ribcage?119 (lambda (x743) (and (vector? x743) (= (vector-length x743) 4) (eq? (vector-ref x743 0) (quote ribcage))))) (make-ribcage118 (lambda (symnames744 marks745 labels746) (vector (quote ribcage) symnames744 marks745 labels746))) (gen-labels117 (lambda (ls747) (if (null? ls747) (quote ()) (cons (gen-label116) (gen-labels117 (cdr ls747)))))) (gen-label116 (lambda () (string #\i))) (wrap-subst115 cdr) (wrap-marks114 car) (make-wrap113 cons) (id-sym-name&marks112 (lambda (x748 w749) (if (syntax-object?95 x748) (values (let ((e750 (syntax-object-expression96 x748))) (if (annotation? e750) (annotation-expression e750) e750)) (join-marks131 (wrap-marks114 w749) (wrap-marks114 (syntax-object-wrap97 x748)))) (values (let ((e751 x748)) (if (annotation? e751) (annotation-expression e751) e751)) (wrap-marks114 w749))))) (id?111 (lambda (x752) (cond ((symbol? x752) #t) ((syntax-object?95 x752) (symbol? (let ((e753 (syntax-object-expression96 x752))) (if (annotation? e753) (annotation-expression e753) e753)))) ((annotation? x752) (symbol? (annotation-expression x752))) (else #f)))) (nonsymbol-id?110 (lambda (x754) (and (syntax-object?95 x754) (symbol? (let ((e755 (syntax-object-expression96 x754))) (if (annotation? e755) (annotation-expression e755) e755)))))) (global-extend109 (lambda (type756 sym757 val758) (put-global-definition-hook77 sym757 type756 val758))) (lookup108 (lambda (x759 r760 mod761) (cond ((assq x759 r760) => cdr) ((symbol? x759) (or (get-global-definition-hook78 x759 mod761) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env107 (lambda (r762) (if (null? r762) (quote ()) (let ((a763 (car r762))) (if (eq? (cadr a763) (quote macro)) (cons a763 (macros-only-env107 (cdr r762))) (macros-only-env107 (cdr r762))))))) (extend-var-env106 (lambda (labels764 vars765 r766) (if (null? labels764) r766 (extend-var-env106 (cdr labels764) (cdr vars765) (cons (cons (car labels764) (cons (quote lexical) (car vars765))) r766))))) (extend-env105 (lambda (labels767 bindings768 r769) (if (null? labels767) r769 (extend-env105 (cdr labels767) (cdr bindings768) (cons (cons (car labels767) (car bindings768)) r769))))) (binding-value104 cdr) (binding-type103 car) (source-annotation102 (lambda (x770) (cond ((annotation? x770) (annotation-source x770)) ((syntax-object?95 x770) (source-annotation102 (syntax-object-expression96 x770))) (else #f)))) (set-syntax-object-module!101 (lambda (x771 update772) (vector-set! x771 3 update772))) (set-syntax-object-wrap!100 (lambda (x773 update774) (vector-set! x773 2 update774))) (set-syntax-object-expression!99 (lambda (x775 update776) (vector-set! x775 1 update776))) (syntax-object-module98 (lambda (x777) (vector-ref x777 3))) (syntax-object-wrap97 (lambda (x778) (vector-ref x778 2))) (syntax-object-expression96 (lambda (x779) (vector-ref x779 1))) (syntax-object?95 (lambda (x780) (and (vector? x780) (= (vector-length x780) 4) (eq? (vector-ref x780 0) (quote syntax-object))))) (make-syntax-object94 (lambda (expression781 wrap782 module783) (vector (quote syntax-object) expression781 wrap782 module783))) (build-letrec93 (lambda (src784 ids785 vars786 val-exps787 body-exp788) (if (null? vars786) body-exp788 (let ((t789 (fluid-ref *mode*70))) (if (memv t789 (quote (c))) ((@ (language tree-il) make-letrec) src784 ids785 vars786 val-exps787 body-exp788) (list (quote letrec) (map list vars786 val-exps787) body-exp788)))))) (build-named-let92 (lambda (src790 ids791 vars792 val-exps793 body-exp794) (let ((f795 (car vars792)) (f-name796 (car ids791)) (vars797 (cdr vars792)) (ids798 (cdr ids791))) (let ((t799 (fluid-ref *mode*70))) (if (memv t799 (quote (c))) ((@ (language tree-il) make-letrec) src790 (list f-name796) (list f795) (list (build-lambda87 src790 ids798 vars797 #f body-exp794)) (build-application79 src790 (build-lexical-reference81 (quote fun) src790 f-name796 f795) val-exps793)) (list (quote let) f795 (map list vars797 val-exps793) body-exp794)))))) (build-let91 (lambda (src800 ids801 vars802 val-exps803 body-exp804) (if (null? vars802) body-exp804 (let ((t805 (fluid-ref *mode*70))) (if (memv t805 (quote (c))) ((@ (language tree-il) make-let) src800 ids801 vars802 val-exps803 body-exp804) (list (quote let) (map list vars802 val-exps803) body-exp804)))))) (build-sequence90 (lambda (src806 exps807) (if (null? (cdr exps807)) (car exps807) (let ((t808 (fluid-ref *mode*70))) (if (memv t808 (quote (c))) ((@ (language tree-il) make-sequence) src806 exps807) (cons (quote begin) exps807)))))) (build-data89 (lambda (src809 exp810) (let ((t811 (fluid-ref *mode*70))) (if (memv t811 (quote (c))) ((@ (language tree-il) make-const) src809 exp810) (if (and (self-evaluating? exp810) (not (vector? exp810))) exp810 (list (quote quote) exp810)))))) (build-primref88 (lambda (src812 name813) (let ((t814 (fluid-ref *mode*70))) (if (memv t814 (quote (c))) ((@ (language tree-il) make-primitive-ref) src812 name813) (build-global-reference84 src812 name813 (quote (hygiene guile))))))) (build-lambda87 (lambda (src815 ids816 vars817 docstring818 exp819) (let ((t820 (fluid-ref *mode*70))) (if (memv t820 (quote (c))) ((@ (language tree-il) make-lambda) src815 ids816 vars817 (if docstring818 (list (cons (quote documentation) docstring818)) (quote ())) exp819) (cons (quote lambda) (cons vars817 (append (if docstring818 (list docstring818) (quote ())) (list exp819)))))))) (build-global-definition86 (lambda (source821 var822 exp823) (let ((t824 (fluid-ref *mode*70))) (if (memv t824 (quote (c))) ((@ (language tree-il) make-toplevel-define) source821 var822 exp823) (list (quote define) var822 exp823))))) (build-global-assignment85 (lambda (source825 var826 exp827 mod828) (analyze-variable83 mod828 var826 (lambda (mod829 var830 public?831) (let ((t832 (fluid-ref *mode*70))) (if (memv t832 (quote (c))) ((@ (language tree-il) make-module-set) source825 mod829 var830 public?831 exp827) (list (quote set!) (list (if public?831 (quote @) (quote @@)) mod829 var830) exp827)))) (lambda (var833) (let ((t834 (fluid-ref *mode*70))) (if (memv t834 (quote (c))) ((@ (language tree-il) make-toplevel-set) source825 var833 exp827) (list (quote set!) var833 exp827))))))) (build-global-reference84 (lambda (source835 var836 mod837) (analyze-variable83 mod837 var836 (lambda (mod838 var839 public?840) (let ((t841 (fluid-ref *mode*70))) (if (memv t841 (quote (c))) ((@ (language tree-il) make-module-ref) source835 mod838 var839 public?840) (list (if public?840 (quote @) (quote @@)) mod838 var839)))) (lambda (var842) (let ((t843 (fluid-ref *mode*70))) (if (memv t843 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source835 var842) var842)))))) (analyze-variable83 (lambda (mod844 var845 modref-cont846 bare-cont847) (if (not mod844) (bare-cont847 var845) (let ((kind848 (car mod844)) (mod849 (cdr mod844))) (let ((t850 kind848)) (if (memv t850 (quote (public))) (modref-cont846 mod849 var845 #t) (if (memv t850 (quote (private))) (if (not (equal? mod849 (module-name (current-module)))) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (if (memv t850 (quote (bare))) (bare-cont847 var845) (if (memv t850 (quote (hygiene))) (if (and (not (equal? mod849 (module-name (current-module)))) (module-variable (resolve-module mod849) var845)) (modref-cont846 mod849 var845 #f) (bare-cont847 var845)) (syntax-violation #f "bad module kind" var845 mod849)))))))))) (build-lexical-assignment82 (lambda (source851 name852 var853 exp854) (let ((t855 (fluid-ref *mode*70))) (if (memv t855 (quote (c))) ((@ (language tree-il) make-lexical-set) source851 name852 var853 exp854) (list (quote set!) var853 exp854))))) (build-lexical-reference81 (lambda (type856 source857 name858 var859) (let ((t860 (fluid-ref *mode*70))) (if (memv t860 (quote (c))) ((@ (language tree-il) make-lexical-ref) source857 name858 var859) var859)))) (build-conditional80 (lambda (source861 test-exp862 then-exp863 else-exp864) (let ((t865 (fluid-ref *mode*70))) (if (memv t865 (quote (c))) ((@ (language tree-il) make-conditional) source861 test-exp862 then-exp863 else-exp864) (list (quote if) test-exp862 then-exp863 else-exp864))))) (build-application79 (lambda (source866 fun-exp867 arg-exps868) (let ((t869 (fluid-ref *mode*70))) (if (memv t869 (quote (c))) ((@ (language tree-il) make-application) source866 fun-exp867 arg-exps868) (cons fun-exp867 arg-exps868))))) (get-global-definition-hook78 (lambda (symbol870 module871) (begin (if (and (not module871) (current-module)) (warn "module system is booted, we should have a module" symbol870)) (let ((v872 (module-variable (if module871 (resolve-module (cdr module871)) (current-module)) symbol870))) (and v872 (variable-bound? v872) (let ((val873 (variable-ref v872))) (and (macro? val873) (syncase-macro-type val873) (cons (syncase-macro-type val873) (syncase-macro-binding val873))))))))) (put-global-definition-hook77 (lambda (symbol874 type875 val876) (let ((existing877 (let ((v878 (module-variable (current-module) symbol874))) (and v878 (variable-bound? v878) (let ((val879 (variable-ref v878))) (and (macro? val879) (not (syncase-macro-type val879)) val879)))))) (module-define! (current-module) symbol874 (if existing877 (make-extended-syncase-macro existing877 type875 val876) (make-syncase-macro type875 val876)))))) (local-eval-hook76 (lambda (x880 mod881) (primitive-eval (list noexpand69 (let ((t882 (fluid-ref *mode*70))) (if (memv t882 (quote (c))) ((@ (language tree-il) tree-il->scheme) x880) x880)))))) (top-level-eval-hook75 (lambda (x883 mod884) (primitive-eval (list noexpand69 (let ((t885 (fluid-ref *mode*70))) (if (memv t885 (quote (c))) ((@ (language tree-il) tree-il->scheme) x883) x883)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend109 (quote local-syntax) (quote letrec-syntax) #t) (global-extend109 (quote local-syntax) (quote let-syntax) #f) (global-extend109 (quote core) (quote fluid-let-syntax) (lambda (e886 r887 w888 s889 mod890) ((lambda (tmp891) ((lambda (tmp892) (if (if tmp892 (apply (lambda (_893 var894 val895 e1896 e2897) (valid-bound-ids?136 var894)) tmp892) #f) (apply (lambda (_899 var900 val901 e1902 e2903) (let ((names904 (map (lambda (x905) (id-var-name133 x905 w888)) var900))) (begin (for-each (lambda (id907 n908) (let ((t909 (binding-type103 (lookup108 n908 r887 mod890)))) (if (memv t909 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e886 (source-wrap140 id907 w888 s889 mod890))))) var900 names904) (chi-body151 (cons e1902 e2903) (source-wrap140 e886 w888 s889 mod890) (extend-env105 names904 (let ((trans-r912 (macros-only-env107 r887))) (map (lambda (x913) (cons (quote macro) (eval-local-transformer154 (chi147 x913 trans-r912 w888 mod890) mod890))) val901)) r887) w888 mod890)))) tmp892) ((lambda (_915) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap140 e886 w888 s889 mod890))) tmp891))) ($sc-dispatch tmp891 (quote (any #(each (any any)) any . each-any))))) e886))) (global-extend109 (quote core) (quote quote) (lambda (e916 r917 w918 s919 mod920) ((lambda (tmp921) ((lambda (tmp922) (if tmp922 (apply (lambda (_923 e924) (build-data89 s919 (strip158 e924 w918))) tmp922) ((lambda (_925) (syntax-violation (quote quote) "bad syntax" (source-wrap140 e916 w918 s919 mod920))) tmp921))) ($sc-dispatch tmp921 (quote (any any))))) e916))) (global-extend109 (quote core) (quote syntax) (letrec ((regen933 (lambda (x934) (let ((t935 (car x934))) (if (memv t935 (quote (ref))) (build-lexical-reference81 (quote value) #f (cadr x934) (cadr x934)) (if (memv t935 (quote (primitive))) (build-primref88 #f (cadr x934)) (if (memv t935 (quote (quote))) (build-data89 #f (cadr x934)) (if (memv t935 (quote (lambda))) (build-lambda87 #f (cadr x934) (cadr x934) #f (regen933 (caddr x934))) (if (memv t935 (quote (map))) (let ((ls936 (map regen933 (cdr x934)))) (build-application79 #f (build-primref88 #f (quote map)) ls936)) (build-application79 #f (build-primref88 #f (car x934)) (map regen933 (cdr x934))))))))))) (gen-vector932 (lambda (x937) (cond ((eq? (car x937) (quote list)) (cons (quote vector) (cdr x937))) ((eq? (car x937) (quote quote)) (list (quote quote) (list->vector (cadr x937)))) (else (list (quote list->vector) x937))))) (gen-append931 (lambda (x938 y939) (if (equal? y939 (quote (quote ()))) x938 (list (quote append) x938 y939)))) (gen-cons930 (lambda (x940 y941) (let ((t942 (car y941))) (if (memv t942 (quote (quote))) (if (eq? (car x940) (quote quote)) (list (quote quote) (cons (cadr x940) (cadr y941))) (if (eq? (cadr y941) (quote ())) (list (quote list) x940) (list (quote cons) x940 y941))) (if (memv t942 (quote (list))) (cons (quote list) (cons x940 (cdr y941))) (list (quote cons) x940 y941)))))) (gen-map929 (lambda (e943 map-env944) (let ((formals945 (map cdr map-env944)) (actuals946 (map (lambda (x947) (list (quote ref) (car x947))) map-env944))) (cond ((eq? (car e943) (quote ref)) (car actuals946)) ((and-map (lambda (x948) (and (eq? (car x948) (quote ref)) (memq (cadr x948) formals945))) (cdr e943)) (cons (quote map) (cons (list (quote primitive) (car e943)) (map (let ((r949 (map cons formals945 actuals946))) (lambda (x950) (cdr (assq (cadr x950) r949)))) (cdr e943))))) (else (cons (quote map) (cons (list (quote lambda) formals945 e943) actuals946))))))) (gen-mappend928 (lambda (e951 map-env952) (list (quote apply) (quote (primitive append)) (gen-map929 e951 map-env952)))) (gen-ref927 (lambda (src953 var954 level955 maps956) (if (fx=73 level955 0) (values var954 maps956) (if (null? maps956) (syntax-violation (quote syntax) "missing ellipsis" src953) (call-with-values (lambda () (gen-ref927 src953 var954 (fx-72 level955 1) (cdr maps956))) (lambda (outer-var957 outer-maps958) (let ((b959 (assq outer-var957 (car maps956)))) (if b959 (values (cdr b959) maps956) (let ((inner-var960 (gen-var159 (quote tmp)))) (values inner-var960 (cons (cons (cons outer-var957 inner-var960) (car maps956)) outer-maps958))))))))))) (gen-syntax926 (lambda (src961 e962 r963 maps964 ellipsis?965 mod966) (if (id?111 e962) (let ((label967 (id-var-name133 e962 (quote (()))))) (let ((b968 (lookup108 label967 r963 mod966))) (if (eq? (binding-type103 b968) (quote syntax)) (call-with-values (lambda () (let ((var.lev969 (binding-value104 b968))) (gen-ref927 src961 (car var.lev969) (cdr var.lev969) maps964))) (lambda (var970 maps971) (values (list (quote ref) var970) maps971))) (if (ellipsis?965 e962) (syntax-violation (quote syntax) "misplaced ellipsis" src961) (values (list (quote quote) e962) maps964))))) ((lambda (tmp972) ((lambda (tmp973) (if (if tmp973 (apply (lambda (dots974 e975) (ellipsis?965 dots974)) tmp973) #f) (apply (lambda (dots976 e977) (gen-syntax926 src961 e977 r963 maps964 (lambda (x978) #f) mod966)) tmp973) ((lambda (tmp979) (if (if tmp979 (apply (lambda (x980 dots981 y982) (ellipsis?965 dots981)) tmp979) #f) (apply (lambda (x983 dots984 y985) (letrec ((f986 (lambda (y987 k988) ((lambda (tmp992) ((lambda (tmp993) (if (if tmp993 (apply (lambda (dots994 y995) (ellipsis?965 dots994)) tmp993) #f) (apply (lambda (dots996 y997) (f986 y997 (lambda (maps998) (call-with-values (lambda () (k988 (cons (quote ()) maps998))) (lambda (x999 maps1000) (if (null? (car maps1000)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-mappend928 x999 (car maps1000)) (cdr maps1000)))))))) tmp993) ((lambda (_1001) (call-with-values (lambda () (gen-syntax926 src961 y987 r963 maps964 ellipsis?965 mod966)) (lambda (y1002 maps1003) (call-with-values (lambda () (k988 maps1003)) (lambda (x1004 maps1005) (values (gen-append931 x1004 y1002) maps1005)))))) tmp992))) ($sc-dispatch tmp992 (quote (any . any))))) y987)))) (f986 y985 (lambda (maps989) (call-with-values (lambda () (gen-syntax926 src961 x983 r963 (cons (quote ()) maps989) ellipsis?965 mod966)) (lambda (x990 maps991) (if (null? (car maps991)) (syntax-violation (quote syntax) "extra ellipsis" src961) (values (gen-map929 x990 (car maps991)) (cdr maps991))))))))) tmp979) ((lambda (tmp1006) (if tmp1006 (apply (lambda (x1007 y1008) (call-with-values (lambda () (gen-syntax926 src961 x1007 r963 maps964 ellipsis?965 mod966)) (lambda (x1009 maps1010) (call-with-values (lambda () (gen-syntax926 src961 y1008 r963 maps1010 ellipsis?965 mod966)) (lambda (y1011 maps1012) (values (gen-cons930 x1009 y1011) maps1012)))))) tmp1006) ((lambda (tmp1013) (if tmp1013 (apply (lambda (e11014 e21015) (call-with-values (lambda () (gen-syntax926 src961 (cons e11014 e21015) r963 maps964 ellipsis?965 mod966)) (lambda (e1017 maps1018) (values (gen-vector932 e1017) maps1018)))) tmp1013) ((lambda (_1019) (values (list (quote quote) e962) maps964)) tmp972))) ($sc-dispatch tmp972 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp972 (quote (any . any)))))) ($sc-dispatch tmp972 (quote (any any . any)))))) ($sc-dispatch tmp972 (quote (any any))))) e962))))) (lambda (e1020 r1021 w1022 s1023 mod1024) (let ((e1025 (source-wrap140 e1020 w1022 s1023 mod1024))) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda (_1028 x1029) (call-with-values (lambda () (gen-syntax926 e1025 x1029 r1021 (quote ()) ellipsis?156 mod1024)) (lambda (e1030 maps1031) (regen933 e1030)))) tmp1027) ((lambda (_1032) (syntax-violation (quote syntax) "bad `syntax' form" e1025)) tmp1026))) ($sc-dispatch tmp1026 (quote (any any))))) e1025))))) (global-extend109 (quote core) (quote lambda) (lambda (e1033 r1034 w1035 s1036 mod1037) ((lambda (tmp1038) ((lambda (tmp1039) (if tmp1039 (apply (lambda (_1040 c1041) (chi-lambda-clause152 (source-wrap140 e1033 w1035 s1036 mod1037) #f c1041 r1034 w1035 mod1037 (lambda (names1042 vars1043 docstring1044 body1045) (build-lambda87 s1036 names1042 vars1043 docstring1044 body1045)))) tmp1039) (syntax-violation #f "source expression failed to match any pattern" tmp1038))) ($sc-dispatch tmp1038 (quote (any . any))))) e1033))) (global-extend109 (quote core) (quote let) (letrec ((chi-let1046 (lambda (e1047 r1048 w1049 s1050 mod1051 constructor1052 ids1053 vals1054 exps1055) (if (not (valid-bound-ids?136 ids1053)) (syntax-violation (quote let) "duplicate bound variable" e1047) (let ((labels1056 (gen-labels117 ids1053)) (new-vars1057 (map gen-var159 ids1053))) (let ((nw1058 (make-binding-wrap128 ids1053 labels1056 w1049)) (nr1059 (extend-var-env106 labels1056 new-vars1057 r1048))) (constructor1052 s1050 (map syntax->datum ids1053) new-vars1057 (map (lambda (x1060) (chi147 x1060 r1048 w1049 mod1051)) vals1054) (chi-body151 exps1055 (source-wrap140 e1047 nw1058 s1050 mod1051) nr1059 nw1058 mod1051)))))))) (lambda (e1061 r1062 w1063 s1064 mod1065) ((lambda (tmp1066) ((lambda (tmp1067) (if tmp1067 (apply (lambda (_1068 id1069 val1070 e11071 e21072) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-let91 id1069 val1070 (cons e11071 e21072))) tmp1067) ((lambda (tmp1076) (if (if tmp1076 (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (id?111 f1078)) tmp1076) #f) (apply (lambda (_1083 f1084 id1085 val1086 e11087 e21088) (chi-let1046 e1061 r1062 w1063 s1064 mod1065 build-named-let92 (cons f1084 id1085) val1086 (cons e11087 e21088))) tmp1076) ((lambda (_1092) (syntax-violation (quote let) "bad let" (source-wrap140 e1061 w1063 s1064 mod1065))) tmp1066))) ($sc-dispatch tmp1066 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1066 (quote (any #(each (any any)) any . each-any))))) e1061)))) (global-extend109 (quote core) (quote letrec) (lambda (e1093 r1094 w1095 s1096 mod1097) ((lambda (tmp1098) ((lambda (tmp1099) (if tmp1099 (apply (lambda (_1100 id1101 val1102 e11103 e21104) (let ((ids1105 id1101)) (if (not (valid-bound-ids?136 ids1105)) (syntax-violation (quote letrec) "duplicate bound variable" e1093) (let ((labels1107 (gen-labels117 ids1105)) (new-vars1108 (map gen-var159 ids1105))) (let ((w1109 (make-binding-wrap128 ids1105 labels1107 w1095)) (r1110 (extend-var-env106 labels1107 new-vars1108 r1094))) (build-letrec93 s1096 (map syntax->datum ids1105) new-vars1108 (map (lambda (x1111) (chi147 x1111 r1110 w1109 mod1097)) val1102) (chi-body151 (cons e11103 e21104) (source-wrap140 e1093 w1109 s1096 mod1097) r1110 w1109 mod1097))))))) tmp1099) ((lambda (_1114) (syntax-violation (quote letrec) "bad letrec" (source-wrap140 e1093 w1095 s1096 mod1097))) tmp1098))) ($sc-dispatch tmp1098 (quote (any #(each (any any)) any . each-any))))) e1093))) (global-extend109 (quote core) (quote set!) (lambda (e1115 r1116 w1117 s1118 mod1119) ((lambda (tmp1120) ((lambda (tmp1121) (if (if tmp1121 (apply (lambda (_1122 id1123 val1124) (id?111 id1123)) tmp1121) #f) (apply (lambda (_1125 id1126 val1127) (let ((val1128 (chi147 val1127 r1116 w1117 mod1119)) (n1129 (id-var-name133 id1126 w1117))) (let ((b1130 (lookup108 n1129 r1116 mod1119))) (let ((t1131 (binding-type103 b1130))) (if (memv t1131 (quote (lexical))) (build-lexical-assignment82 s1118 (syntax->datum id1126) (binding-value104 b1130) val1128) (if (memv t1131 (quote (global))) (build-global-assignment85 s1118 n1129 val1128 mod1119) (if (memv t1131 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap139 id1126 w1117 mod1119)) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))))))))) tmp1121) ((lambda (tmp1132) (if tmp1132 (apply (lambda (_1133 head1134 tail1135 val1136) (call-with-values (lambda () (syntax-type145 head1134 r1116 (quote (())) #f #f mod1119)) (lambda (type1137 value1138 ee1139 ww1140 ss1141 modmod1142) (let ((t1143 type1137)) (if (memv t1143 (quote (module-ref))) (let ((val1144 (chi147 val1136 r1116 w1117 mod1119))) (call-with-values (lambda () (value1138 (cons head1134 tail1135))) (lambda (id1146 mod1147) (build-global-assignment85 s1118 id1146 val1144 mod1147)))) (build-application79 s1118 (chi147 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail 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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1134) r1116 w1117 mod1119) (map (lambda (e1148) (chi147 e1148 r1116 w1117 mod1119)) (append tail1135 (list val1136))))))))) tmp1132) ((lambda (_1150) (syntax-violation (quote set!) "bad set!" (source-wrap140 e1115 w1117 s1118 mod1119))) tmp1120))) ($sc-dispatch tmp1120 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1120 (quote (any any any))))) e1115))) (global-extend109 (quote module-ref) (quote @) (lambda (e1151) ((lambda (tmp1152) ((lambda (tmp1153) (if (if tmp1153 (apply (lambda (_1154 mod1155 id1156) (and (and-map id?111 mod1155) (id?111 id1156))) tmp1153) #f) (apply (lambda (_1158 mod1159 id1160) (values (syntax->datum id1160) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1159)))) tmp1153) (syntax-violation #f "source expression failed to match any pattern" tmp1152))) ($sc-dispatch tmp1152 (quote (any each-any any))))) e1151))) (global-extend109 (quote module-ref) (quote @@) (lambda (e1162) ((lambda (tmp1163) ((lambda (tmp1164) (if (if tmp1164 (apply (lambda (_1165 mod1166 id1167) (and (and-map id?111 mod1166) (id?111 id1167))) tmp1164) #f) (apply (lambda (_1169 mod1170 id1171) (values (syntax->datum id1171) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1170)))) tmp1164) (syntax-violation #f "source expression failed to match any pattern" tmp1163))) ($sc-dispatch tmp1163 (quote (any each-any any))))) e1162))) (global-extend109 (quote begin) (quote begin) (quote ())) (global-extend109 (quote define) (quote define) (quote ())) (global-extend109 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend109 (quote eval-when) (quote eval-when) (quote ())) (global-extend109 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1176 (lambda (x1177 keys1178 clauses1179 r1180 mod1181) (if (null? clauses1179) (build-application79 #f (build-primref88 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x1177)) ((lambda (tmp1182) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 exp1185) (if (and (id?111 pat1184) (and-map (lambda (x1186) (not (free-id=?134 pat1184 x1186))) (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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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 and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1178))) (let ((labels1187 (list (gen-label116))) (var1188 (gen-var159 pat1184))) (build-application79 #f (build-lambda87 #f (list (syntax->datum pat1184)) (list var1188) #f (chi147 exp1185 (extend-env105 labels1187 (list (cons (quote syntax) (cons var1188 0))) r1180) (make-binding-wrap128 (list pat1184) labels1187 (quote (()))) mod1181)) (list x1177))) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1184 #t exp1185 mod1181))) tmp1183) ((lambda (tmp1189) (if tmp1189 (apply (lambda (pat1190 fender1191 exp1192) (gen-clause1175 x1177 keys1178 (cdr clauses1179) r1180 pat1190 fender1191 exp1192 mod1181)) tmp1189) ((lambda (_1193) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1179))) tmp1182))) ($sc-dispatch tmp1182 (quote (any any any)))))) ($sc-dispatch tmp1182 (quote (any any))))) (car clauses1179))))) (gen-clause1175 (lambda (x1194 keys1195 clauses1196 r1197 pat1198 fender1199 exp1200 mod1201) (call-with-values (lambda () (convert-pattern1173 pat1198 keys1195)) (lambda (p1202 pvars1203) (cond ((not (distinct-bound-ids?137 (map car pvars1203))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1198)) ((not (and-map (lambda (x1204) (not (ellipsis?156 (car x1204)))) pvars1203)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1198)) (else (let ((y1205 (gen-var159 (quote tmp)))) (build-application79 #f (build-lambda87 #f (list (quote tmp)) (list y1205) #f (let ((y1206 (build-lexical-reference81 (quote value) #f (quote tmp) y1205))) (build-conditional80 #f ((lambda (tmp1207) ((lambda (tmp1208) (if tmp1208 (apply (lambda () y1206) tmp1208) ((lambda (_1209) (build-conditional80 #f y1206 (build-dispatch-call1174 pvars1203 fender1199 y1206 r1197 mod1201) (build-data89 #f #f))) tmp1207))) ($sc-dispatch tmp1207 (quote #(atom #t))))) fender1199) (build-dispatch-call1174 pvars1203 exp1200 y1206 r1197 mod1201) (gen-syntax-case1176 x1194 keys1195 clauses1196 r1197 mod1201)))) (list (if (eq? p1202 (quote any)) (build-application79 #f (build-primref88 #f (quote list)) (list x1194)) (build-application79 #f (build-primref88 #f (quote $sc-dispatch)) (list x1194 (build-data89 #f p1202))))))))))))) (build-dispatch-call1174 (lambda (pvars1210 exp1211 y1212 r1213 mod1214) (let ((ids1215 (map car pvars1210)) (levels1216 (map cdr pvars1210))) (let ((labels1217 (gen-labels117 ids1215)) (new-vars1218 (map gen-var159 ids1215))) (build-application79 #f (build-primref88 #f (quote apply)) (list (build-lambda87 #f (map syntax->datum ids1215) new-vars1218 #f (chi147 exp1211 (extend-env105 labels1217 (map (lambda (var1219 level1220) (cons (quote syntax) (cons var1219 level1220))) new-vars1218 (map cdr pvars1210)) r1213) (make-binding-wrap128 ids1215 labels1217 (quote (()))) mod1214)) y1212)))))) (convert-pattern1173 (lambda (pattern1221 keys1222) (letrec ((cvt1223 (lambda (p1224 n1225 ids1226) (if (id?111 p1224) (if (bound-id-member?138 p1224 keys1222) (values (vector (quote free-id) p1224) ids1226) (values (quote any) (cons (cons p1224 n1225) ids1226))) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (x1229 dots1230) (ellipsis?156 dots1230)) tmp1228) #f) (apply (lambda (x1231 dots1232) (call-with-values (lambda () (cvt1223 x1231 (fx+71 n1225 1) ids1226)) (lambda (p1233 ids1234) (values (if (eq? p1233 (quote any)) (quote each-any) (vector (quote each) p1233)) ids1234)))) tmp1228) ((lambda (tmp1235) (if tmp1235 (apply (lambda (x1236 y1237) (call-with-values (lambda () (cvt1223 y1237 n1225 ids1226)) (lambda (y1238 ids1239) (call-with-values (lambda () (cvt1223 x1236 n1225 ids1239)) (lambda (x1240 ids1241) (values (cons x1240 y1238) ids1241)))))) tmp1235) ((lambda (tmp1242) (if tmp1242 (apply (lambda () (values (quote ()) ids1226)) tmp1242) ((lambda (tmp1243) (if tmp1243 (apply (lambda (x1244) (call-with-values (lambda () (cvt1223 x1244 n1225 ids1226)) (lambda (p1246 ids1247) (values (vector (quote vector) p1246) ids1247)))) tmp1243) ((lambda (x1248) (values (vector (quote atom) (strip158 p1224 (quote (())))) ids1226)) tmp1227))) ($sc-dispatch tmp1227 (quote #(vector each-any)))))) ($sc-dispatch tmp1227 (quote ()))))) ($sc-dispatch tmp1227 (quote (any . any)))))) ($sc-dispatch tmp1227 (quote (any any))))) p1224))))) (cvt1223 pattern1221 0 (quote ())))))) (lambda (e1249 r1250 w1251 s1252 mod1253) (let ((e1254 (source-wrap140 e1249 w1251 s1252 mod1253))) ((lambda (tmp1255) ((lambda (tmp1256) (if tmp1256 (apply (lambda (_1257 val1258 key1259 m1260) (if (and-map (lambda (x1261) (and (id?111 x1261) (not (ellipsis?156 x1261)))) key1259) (let ((x1263 (gen-var159 (quote tmp)))) (build-application79 s1252 (build-lambda87 #f (list (quote tmp)) (list x1263) #f (gen-syntax-case1176 (build-lexical-reference81 (quote value) #f (quote tmp) x1263) key1259 m1260 r1250 mod1253)) (list (chi147 val1258 r1250 (quote (())) mod1253)))) (syntax-violation (quote syntax-case) "invalid literals list" e1254))) tmp1256) (syntax-violation #f "source expression failed to match any pattern" tmp1255))) ($sc-dispatch tmp1255 (quote (any any each-any . each-any))))) e1254))))) (set! sc-expand (lambda (x1267 . rest1266) (if (and (pair? x1267) (equal? (car x1267) noexpand69)) (cadr x1267) (let ((m1268 (if (null? rest1266) (quote e) (car rest1266))) (esew1269 (if (or (null? rest1266) (null? (cdr rest1266))) (quote (eval)) (cadr rest1266)))) (with-fluid* *mode*70 m1268 (lambda () (chi-top146 x1267 (quote ()) (quote ((top))) m1268 esew1269 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1270) (nonsymbol-id?110 x1270))) (set! datum->syntax (lambda (id1271 datum1272) (make-syntax-object94 datum1272 (syntax-object-wrap97 id1271) #f))) (set! syntax->datum (lambda (x1273) (strip158 x1273 (quote (()))))) (set! generate-temporaries (lambda (ls1274) (begin (let ((x1275 ls1274)) (if (not (list? x1275)) (syntax-violation (quote generate-temporaries) "invalid argument" x1275))) (map (lambda (x1276) (wrap139 (gensym) (quote ((top))) #f)) ls1274)))) (set! free-identifier=? (lambda (x1277 y1278) (begin (let ((x1279 x1277)) (if (not (nonsymbol-id?110 x1279)) (syntax-violation (quote free-identifier=?) "invalid argument" x1279))) (let ((x1280 y1278)) (if (not (nonsymbol-id?110 x1280)) (syntax-violation (quote free-identifier=?) "invalid argument" x1280))) (free-id=?134 x1277 y1278)))) (set! bound-identifier=? (lambda (x1281 y1282) (begin (let ((x1283 x1281)) (if (not (nonsymbol-id?110 x1283)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1283))) (let ((x1284 y1282)) (if (not (nonsymbol-id?110 x1284)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1284))) (bound-id=?135 x1281 y1282)))) (set! syntax-violation (lambda (who1288 message1287 form1286 . subform1285) (begin (let ((x1289 who1288)) (if (not ((lambda (x1290) (or (not x1290) (string? x1290) (symbol? x1290))) x1289)) (syntax-violation (quote syntax-violation) "invalid argument" x1289))) (let ((x1291 message1287)) (if (not (string? x1291)) (syntax-violation (quote syntax-violation) "invalid argument" x1291))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1288 "~a: " "") "~a " (if (null? subform1285) "in ~a" "in subform `~s' of `~s'")) (let ((tail1292 (cons message1287 (map (lambda (x1293) (strip158 x1293 (quote (())))) (append subform1285 (list form1286)))))) (if who1288 (cons who1288 tail1292) tail1292)) #f)))) (letrec ((match1298 (lambda (e1299 p1300 w1301 r1302 mod1303) (cond ((not r1302) #f) ((eq? p1300 (quote any)) (cons (wrap139 e1299 w1301 mod1303) r1302)) ((syntax-object?95 e1299) (match*1297 (let ((e1304 (syntax-object-expression96 e1299))) (if (annotation? e1304) (annotation-expression e1304) e1304)) p1300 (join-wraps130 w1301 (syntax-object-wrap97 e1299)) r1302 (syntax-object-module98 e1299))) (else (match*1297 (let ((e1305 e1299)) (if (annotation? e1305) (annotation-expression e1305) e1305)) p1300 w1301 r1302 mod1303))))) (match*1297 (lambda (e1306 p1307 w1308 r1309 mod1310) (cond ((null? p1307) (and (null? e1306) r1309)) ((pair? p1307) (and (pair? e1306) (match1298 (car e1306) (car p1307) w1308 (match1298 (cdr e1306) (cdr p1307) w1308 r1309 mod1310) mod1310))) ((eq? p1307 (quote each-any)) (let ((l1311 (match-each-any1295 e1306 w1308 mod1310))) (and l1311 (cons l1311 r1309)))) (else (let ((t1312 (vector-ref p1307 0))) (if (memv t1312 (quote (each))) (if (null? e1306) (match-empty1296 (vector-ref p1307 1) r1309) (let ((l1313 (match-each1294 e1306 (vector-ref p1307 1) w1308 mod1310))) (and l1313 (letrec ((collect1314 (lambda (l1315) (if (null? (car l1315)) r1309 (cons (map car l1315) (collect1314 (map cdr l1315))))))) (collect1314 l1313))))) (if (memv t1312 (quote (free-id))) (and (id?111 e1306) (free-id=?134 (wrap139 e1306 w1308 mod1310) (vector-ref p1307 1)) r1309) (if (memv t1312 (quote (atom))) (and (equal? (vector-ref p1307 1) (strip158 e1306 w1308)) r1309) (if (memv t1312 (quote (vector))) (and (vector? e1306) (match1298 (vector->list e1306) (vector-ref p1307 1) w1308 r1309 mod1310))))))))))) (match-empty1296 (lambda (p1316 r1317) (cond ((null? p1316) r1317) ((eq? p1316 (quote any)) (cons (quote ()) r1317)) ((pair? p1316) (match-empty1296 (car p1316) (match-empty1296 (cdr p1316) r1317))) ((eq? p1316 (quote each-any)) (cons (quote ()) r1317)) (else (let ((t1318 (vector-ref p1316 0))) (if (memv t1318 (quote (each))) (match-empty1296 (vector-ref p1316 1) r1317) (if (memv t1318 (quote (free-id atom))) r1317 (if (memv t1318 (quote (vector))) (match-empty1296 (vector-ref p1316 1) r1317))))))))) (match-each-any1295 (lambda (e1319 w1320 mod1321) (cond ((annotation? e1319) (match-each-any1295 (annotation-expression e1319) w1320 mod1321)) ((pair? e1319) (let ((l1322 (match-each-any1295 (cdr e1319) w1320 mod1321))) (and l1322 (cons (wrap139 (car e1319) w1320 mod1321) l1322)))) ((null? e1319) (quote ())) ((syntax-object?95 e1319) (match-each-any1295 (syntax-object-expression96 e1319) (join-wraps130 w1320 (syntax-object-wrap97 e1319)) mod1321)) (else #f)))) (match-each1294 (lambda (e1323 p1324 w1325 mod1326) (cond ((annotation? e1323) (match-each1294 (annotation-expression e1323) p1324 w1325 mod1326)) ((pair? e1323) (let ((first1327 (match1298 (car e1323) p1324 w1325 (quote ()) mod1326))) (and first1327 (let ((rest1328 (match-each1294 (cdr e1323) p1324 w1325 mod1326))) (and rest1328 (cons first1327 rest1328)))))) ((null? e1323) (quote ())) ((syntax-object?95 e1323) (match-each1294 (syntax-object-expression96 e1323) p1324 (join-wraps130 w1325 (syntax-object-wrap97 e1323)) (syntax-object-module98 e1323))) (else #f))))) (set! $sc-dispatch (lambda (e1329 p1330) (cond ((eq? p1330 (quote any)) (list e1329)) ((syntax-object?95 e1329) (match*1297 (let ((e1331 (syntax-object-expression96 e1329))) (if (annotation? e1331) (annotation-expression e1331) e1331)) p1330 (syntax-object-wrap97 e1329) (quote ()) (syntax-object-module98 e1329))) (else (match*1297 (let ((e1332 e1329)) (if (annotation? e1332) (annotation-expression e1332) e1332)) p1330 (quote (())) (quote ()) #f))))))))) -(define with-syntax (make-syncase-macro (quote macro) (lambda (x1333) ((lambda (tmp1334) ((lambda (tmp1335) (if tmp1335 (apply (lambda (_1336 e11337 e21338) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11337 e21338))) tmp1335) ((lambda (tmp1340) (if tmp1340 (apply (lambda (_1341 out1342 in1343 e11344 e21345) (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"))) (hygiene guile))) in1343 (quote ()) (list out1342 (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"))) (hygiene guile))) (cons e11344 e21345))))) tmp1340) ((lambda (tmp1347) (if tmp1347 (apply (lambda (_1348 out1349 in1350 e11351 e21352) (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"))) (hygiene guile))) (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"))) (hygiene guile))) in1350) (quote ()) (list out1349 (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"))) (hygiene guile))) (cons e11351 e21352))))) tmp1347) (syntax-violation #f "source expression failed to match any pattern" tmp1334))) ($sc-dispatch tmp1334 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1334 (quote (any () any . each-any))))) x1333)))) -(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1356) ((lambda (tmp1357) ((lambda (tmp1358) (if tmp1358 (apply (lambda (_1359 k1360 keyword1361 pattern1362 template1363) (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"))) (hygiene guile))) (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"))) (hygiene guile)))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (cons k1360 (map (lambda (tmp1366 tmp1365) (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"))) (hygiene guile))) tmp1365) (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"))) (hygiene guile))) tmp1366))) template1363 pattern1362)))))) tmp1358) (syntax-violation #f "source expression failed to match any pattern" tmp1357))) ($sc-dispatch tmp1357 (quote (any each-any . #(each ((any . any) any))))))) x1356)))) -(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1367) ((lambda (tmp1368) ((lambda (tmp1369) (if (if tmp1369 (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (and-map identifier? x1371)) tmp1369) #f) (apply (lambda (let*1376 x1377 v1378 e11379 e21380) (letrec ((f1381 (lambda (bindings1382) (if (null? bindings1382) (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"))) (hygiene guile))) (cons (quote ()) (cons e11379 e21380))) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (body1388 binding1389) (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"))) (hygiene guile))) (list binding1389) body1388)) tmp1387) (syntax-violation #f "source expression failed to match any pattern" tmp1386))) ($sc-dispatch tmp1386 (quote (any any))))) (list (f1381 (cdr bindings1382)) (car bindings1382))))))) (f1381 (map list x1377 v1378)))) tmp1369) (syntax-violation #f "source expression failed to match any pattern" tmp1368))) ($sc-dispatch tmp1368 (quote (any #(each (any any)) any . each-any))))) x1367)))) -(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1390) ((lambda (tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (_1393 var1394 init1395 step1396 e01397 e11398 c1399) ((lambda (tmp1400) ((lambda (tmp1401) (if tmp1401 (apply (lambda (step1402) ((lambda (tmp1403) ((lambda (tmp1404) (if tmp1404 (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var1394 init1395) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e01397) (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"))) (hygiene guile))) (append c1399 (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"))) (hygiene guile))) step1402))))))) tmp1404) ((lambda (tmp1409) (if tmp1409 (apply (lambda (e11410 e21411) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var1394 init1395) (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"))) (hygiene guile))) e01397 (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"))) (hygiene guile))) (cons e11410 e21411)) (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"))) (hygiene guile))) (append c1399 (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"))) (hygiene guile))) step1402))))))) tmp1409) (syntax-violation #f "source expression failed to match any pattern" tmp1403))) ($sc-dispatch tmp1403 (quote (any . each-any)))))) ($sc-dispatch tmp1403 (quote ())))) e11398)) tmp1401) (syntax-violation #f "source expression failed to match any pattern" tmp1400))) ($sc-dispatch tmp1400 (quote each-any)))) (map (lambda (v1418 s1419) ((lambda (tmp1420) ((lambda (tmp1421) (if tmp1421 (apply (lambda () v1418) tmp1421) ((lambda (tmp1422) (if tmp1422 (apply (lambda (e1423) e1423) tmp1422) ((lambda (_1424) (syntax-violation (quote do) "bad step expression" orig-x1390 s1419)) tmp1420))) ($sc-dispatch tmp1420 (quote (any)))))) ($sc-dispatch tmp1420 (quote ())))) s1419)) var1394 step1396))) tmp1392) (syntax-violation #f "source expression failed to match any pattern" tmp1391))) ($sc-dispatch tmp1391 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1390)))) -(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1427 (lambda (x1431 y1432) ((lambda (tmp1433) ((lambda (tmp1434) (if tmp1434 (apply (lambda (x1435 y1436) ((lambda (tmp1437) ((lambda (tmp1438) (if tmp1438 (apply (lambda (dy1439) ((lambda (tmp1440) ((lambda (tmp1441) (if tmp1441 (apply (lambda (dx1442) (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"))) (hygiene guile))) (cons dx1442 dy1439))) tmp1441) ((lambda (_1443) (if (null? dy1439) (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"))) (hygiene guile))) x1435) (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"))) (hygiene guile))) x1435 y1436))) tmp1440))) ($sc-dispatch tmp1440 (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"))) (hygiene guile))) any))))) x1435)) tmp1438) ((lambda (tmp1444) (if tmp1444 (apply (lambda (stuff1445) (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"))) (hygiene guile))) (cons x1435 stuff1445))) tmp1444) ((lambda (else1446) (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"))) (hygiene guile))) x1435 y1436)) tmp1437))) ($sc-dispatch tmp1437 (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"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1437 (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"))) (hygiene guile))) any))))) y1436)) tmp1434) (syntax-violation #f "source expression failed to match any pattern" tmp1433))) ($sc-dispatch tmp1433 (quote (any any))))) (list x1431 y1432)))) (quasiappend1428 (lambda (x1447 y1448) ((lambda (tmp1449) ((lambda (tmp1450) (if tmp1450 (apply (lambda (x1451 y1452) ((lambda (tmp1453) ((lambda (tmp1454) (if tmp1454 (apply (lambda () x1451) tmp1454) ((lambda (_1455) (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"))) (hygiene guile))) x1451 y1452)) tmp1453))) ($sc-dispatch tmp1453 (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"))) (hygiene guile))) ()))))) y1452)) tmp1450) (syntax-violation #f "source expression failed to match any pattern" tmp1449))) ($sc-dispatch tmp1449 (quote (any any))))) (list x1447 y1448)))) (quasivector1429 (lambda (x1456) ((lambda (tmp1457) ((lambda (x1458) ((lambda (tmp1459) ((lambda (tmp1460) (if tmp1460 (apply (lambda (x1461) (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"))) (hygiene guile))) (list->vector x1461))) tmp1460) ((lambda (tmp1463) (if tmp1463 (apply (lambda (x1464) (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"))) (hygiene guile))) x1464)) tmp1463) ((lambda (_1466) (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"))) (hygiene guile))) x1458)) tmp1459))) ($sc-dispatch tmp1459 (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"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1459 (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"))) (hygiene guile))) each-any))))) x1458)) tmp1457)) x1456))) (quasi1430 (lambda (p1467 lev1468) ((lambda (tmp1469) ((lambda (tmp1470) (if tmp1470 (apply (lambda (p1471) (if (= lev1468 0) p1471 (quasicons1427 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi1430 (list p1471) (- lev1468 1))))) tmp1470) ((lambda (tmp1472) (if tmp1472 (apply (lambda (p1473 q1474) (if (= lev1468 0) (quasiappend1428 p1473 (quasi1430 q1474 lev1468)) (quasicons1427 (quasicons1427 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi1430 (list p1473) (- lev1468 1))) (quasi1430 q1474 lev1468)))) tmp1472) ((lambda (tmp1475) (if tmp1475 (apply (lambda (p1476) (quasicons1427 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi1430 (list p1476) (+ lev1468 1)))) tmp1475) ((lambda (tmp1477) (if tmp1477 (apply (lambda (p1478 q1479) (quasicons1427 (quasi1430 p1478 lev1468) (quasi1430 q1479 lev1468))) tmp1477) ((lambda (tmp1480) (if tmp1480 (apply (lambda (x1481) (quasivector1429 (quasi1430 x1481 lev1468))) tmp1480) ((lambda (p1483) (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"))) (hygiene guile))) p1483)) tmp1469))) ($sc-dispatch tmp1469 (quote #(vector each-any)))))) ($sc-dispatch tmp1469 (quote (any . any)))))) ($sc-dispatch tmp1469 (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"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1469 (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"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1469 (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"))) (hygiene guile))) any))))) p1467)))) (lambda (x1484) ((lambda (tmp1485) ((lambda (tmp1486) (if tmp1486 (apply (lambda (_1487 e1488) (quasi1430 e1488 0)) tmp1486) (syntax-violation #f "source expression failed to match any pattern" tmp1485))) ($sc-dispatch tmp1485 (quote (any any))))) x1484))))) -(define include (make-syncase-macro (quote macro) (lambda (x1489) (letrec ((read-file1490 (lambda (fn1491 k1492) (let ((p1493 (open-input-file fn1491))) (letrec ((f1494 (lambda (x1495) (if (eof-object? x1495) (begin (close-input-port p1493) (quote ())) (cons (datum->syntax k1492 x1495) (f1494 (read p1493))))))) (f1494 (read p1493))))))) ((lambda (tmp1496) ((lambda (tmp1497) (if tmp1497 (apply (lambda (k1498 filename1499) (let ((fn1500 (syntax->datum filename1499))) ((lambda (tmp1501) ((lambda (tmp1502) (if tmp1502 (apply (lambda (exp1503) (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"))) (hygiene guile))) exp1503)) tmp1502) (syntax-violation #f "source expression failed to match any pattern" tmp1501))) ($sc-dispatch tmp1501 (quote each-any)))) (read-file1490 fn1500 k1498)))) tmp1497) (syntax-violation #f "source expression failed to match any pattern" tmp1496))) ($sc-dispatch tmp1496 (quote (any any))))) x1489))))) -(define unquote (make-syncase-macro (quote macro) (lambda (x1505) ((lambda (tmp1506) ((lambda (tmp1507) (if tmp1507 (apply (lambda (_1508 e1509) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1505)) tmp1507) (syntax-violation #f "source expression failed to match any pattern" tmp1506))) ($sc-dispatch tmp1506 (quote (any any))))) x1505)))) -(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1510) ((lambda (tmp1511) ((lambda (tmp1512) (if tmp1512 (apply (lambda (_1513 e1514) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1510)) tmp1512) (syntax-violation #f "source expression failed to match any pattern" tmp1511))) ($sc-dispatch tmp1511 (quote (any any))))) x1510)))) -(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if tmp1517 (apply (lambda (_1518 e1519 m11520 m21521) ((lambda (tmp1522) ((lambda (body1523) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e1519)) body1523)) tmp1522)) (letrec ((f1524 (lambda (clause1525 clauses1526) (if (null? clauses1526) ((lambda (tmp1528) ((lambda (tmp1529) (if tmp1529 (apply (lambda (e11530 e21531) (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"))) (hygiene guile))) (cons e11530 e21531))) tmp1529) ((lambda (tmp1533) (if tmp1533 (apply (lambda (k1534 e11535 e21536) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k1534)) (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"))) (hygiene guile))) (cons e11535 e21536)))) tmp1533) ((lambda (_1539) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1528))) ($sc-dispatch tmp1528 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1528 (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"))) (hygiene guile))) any . each-any))))) clause1525) ((lambda (tmp1540) ((lambda (rest1541) ((lambda (tmp1542) ((lambda (tmp1543) (if tmp1543 (apply (lambda (k1544 e11545 e21546) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k1544)) (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"))) (hygiene guile))) (cons e11545 e21546)) rest1541)) tmp1543) ((lambda (_1549) (syntax-violation (quote case) "bad clause" x1515 clause1525)) tmp1542))) ($sc-dispatch tmp1542 (quote (each-any any . each-any))))) clause1525)) tmp1540)) (f1524 (car clauses1526) (cdr clauses1526))))))) (f1524 m11520 m21521)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any any any . each-any))))) x1515)))) -(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda (_1553 e1554) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1554)) (list (cons _1553 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1554 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1552) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any any))))) x1550)))) +(letrec ((and-map*2008 (lambda (f2048 first2047 . rest2046) (let ((t2049 (null? first2047))) (if t2049 t2049 (if (null? rest2046) (letrec ((andmap2050 (lambda (first2051) (let ((x2052 (car first2051)) (first2053 (cdr first2051))) (if (null? first2053) (f2048 x2052) (if (f2048 x2052) (andmap2050 first2053) #f)))))) (andmap2050 first2047)) (letrec ((andmap2054 (lambda (first2055 rest2056) (let ((x2057 (car first2055)) (xr2058 (map car rest2056)) (first2059 (cdr first2055)) (rest2060 (map cdr rest2056))) (if (null? first2059) (apply f2048 (cons x2057 xr2058)) (if (apply f2048 (cons x2057 xr2058)) (andmap2054 first2059 rest2060) #f)))))) (andmap2054 first2047 rest2046)))))))) (letrec ((lambda-var-list2153 (lambda (vars2282) (letrec ((lvl2283 (lambda (vars2284 ls2285 w2286) (if (pair? vars2284) (lvl2283 (cdr vars2284) (cons (wrap2132 (car vars2284) w2286 #f) ls2285) w2286) (if (id?2104 vars2284) (cons (wrap2132 vars2284 w2286 #f) ls2285) (if (null? vars2284) ls2285 (if (syntax-object?2088 vars2284) (lvl2283 (syntax-object-expression2089 vars2284) ls2285 (join-wraps2123 w2286 (syntax-object-wrap2090 vars2284))) (if (annotation? vars2284) (lvl2283 (annotation-expression vars2284) ls2285 w2286) (cons vars2284 ls2285))))))))) (lvl2283 vars2282 (quote ()) (quote (())))))) (gen-var2152 (lambda (id2287) (let ((id2288 (if (syntax-object?2088 id2287) (syntax-object-expression2089 id2287) id2287))) (if (annotation? id2288) (gensym (symbol->string (annotation-expression id2288))) (gensym (symbol->string id2288)))))) (strip2151 (lambda (x2289 w2290) (if (memq (quote top) (wrap-marks2107 w2290)) (if (let ((t2291 (annotation? x2289))) (if t2291 t2291 (if (pair? x2289) (annotation? (car x2289)) #f))) (strip-annotation2150 x2289 #f) x2289) (letrec ((f2292 (lambda (x2293) (if (syntax-object?2088 x2293) (strip2151 (syntax-object-expression2089 x2293) (syntax-object-wrap2090 x2293)) (if (pair? x2293) (let ((a2294 (f2292 (car x2293))) (d2295 (f2292 (cdr x2293)))) (if (if (eq? a2294 (car x2293)) (eq? d2295 (cdr x2293)) #f) x2293 (cons a2294 d2295))) (if (vector? x2293) (let ((old2296 (vector->list x2293))) (let ((new2297 (map f2292 old2296))) (if (and-map*2008 eq? old2296 new2297) x2293 (list->vector new2297)))) x2293)))))) (f2292 x2289))))) (strip-annotation2150 (lambda (x2298 parent2299) (if (pair? x2298) (let ((new2300 (cons #f #f))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2300) (if #f #f)) (set-car! new2300 (strip-annotation2150 (car x2298) #f)) (set-cdr! new2300 (strip-annotation2150 (cdr x2298) #f)) new2300)) (if (annotation? x2298) (let ((t2301 (annotation-stripped x2298))) (if t2301 t2301 (strip-annotation2150 (annotation-expression x2298) x2298))) (if (vector? x2298) (let ((new2302 (make-vector (vector-length x2298)))) (begin (if parent2299 (set-annotation-stripped! parent2299 new2302) (if #f #f)) (letrec ((loop2303 (lambda (i2304) (unless (fx<2066 i2304 0) (vector-set! new2302 i2304 (strip-annotation2150 (vector-ref x2298 i2304) #f)) (loop2303 (fx-2064 i2304 1)))))) (loop2303 (- (vector-length x2298) 1))) new2302)) x2298))))) (ellipsis?2149 (lambda (x2305) (if (nonsymbol-id?2103 x2305) (free-id=?2127 x2305 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void2148 (lambda () (build-void2071 #f))) (eval-local-transformer2147 (lambda (expanded2306 mod2307) (let ((p2308 (local-eval-hook2068 expanded2306 mod2307))) (if (procedure? p2308) p2308 (syntax-violation #f "nonprocedure transformer" p2308))))) (chi-local-syntax2146 (lambda (rec?2309 e2310 r2311 w2312 s2313 mod2314 k2315) ((lambda (tmp2316) ((lambda (tmp2317) (if tmp2317 (apply (lambda (_2318 id2319 val2320 e12321 e22322) (let ((ids2323 id2319)) (if (not (valid-bound-ids?2129 ids2323)) (syntax-violation #f "duplicate bound keyword" e2310) (let ((labels2325 (gen-labels2110 ids2323))) (let ((new-w2326 (make-binding-wrap2121 ids2323 labels2325 w2312))) (k2315 (cons e12321 e22322) (extend-env2098 labels2325 (let ((w2328 (if rec?2309 new-w2326 w2312)) (trans-r2329 (macros-only-env2100 r2311))) (map (lambda (x2330) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2330 trans-r2329 w2328 mod2314) mod2314))) val2320)) r2311) new-w2326 s2313 mod2314)))))) tmp2317) ((lambda (_2332) (syntax-violation #f "bad local syntax definition" (source-wrap2133 e2310 w2312 s2313 mod2314))) tmp2316))) ($sc-dispatch tmp2316 (quote (any #(each (any any)) any . each-any))))) e2310))) (chi-lambda-clause2145 (lambda (e2333 docstring2334 c2335 r2336 w2337 mod2338 k2339) ((lambda (tmp2340) ((lambda (tmp2341) (if (if tmp2341 (apply (lambda (args2342 doc2343 e12344 e22345) (if (string? (syntax->datum doc2343)) (not docstring2334) #f)) tmp2341) #f) (apply (lambda (args2346 doc2347 e12348 e22349) (chi-lambda-clause2145 e2333 doc2347 (cons args2346 (cons e12348 e22349)) r2336 w2337 mod2338 k2339)) tmp2341) ((lambda (tmp2351) (if tmp2351 (apply (lambda (id2352 e12353 e22354) (let ((ids2355 id2352)) (if (not (valid-bound-ids?2129 ids2355)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2357 (gen-labels2110 ids2355)) (new-vars2358 (map gen-var2152 ids2355))) (k2339 (map syntax->datum ids2355) new-vars2358 docstring2334 (chi-body2144 (cons e12353 e22354) e2333 (extend-var-env2099 labels2357 new-vars2358 r2336) (make-binding-wrap2121 ids2355 labels2357 w2337) mod2338)))))) tmp2351) ((lambda (tmp2360) (if tmp2360 (apply (lambda (ids2361 e12362 e22363) (let ((old-ids2364 (lambda-var-list2153 ids2361))) (if (not (valid-bound-ids?2129 old-ids2364)) (syntax-violation (quote lambda) "invalid parameter list" e2333) (let ((labels2365 (gen-labels2110 old-ids2364)) (new-vars2366 (map gen-var2152 old-ids2364))) (k2339 (letrec ((f2367 (lambda (ls12368 ls22369) (if (null? ls12368) (syntax->datum ls22369) (f2367 (cdr ls12368) (cons (syntax->datum (car ls12368)) ls22369)))))) (f2367 (cdr old-ids2364) (car old-ids2364))) (letrec ((f2370 (lambda (ls12371 ls22372) (if (null? ls12371) ls22372 (f2370 (cdr ls12371) (cons (car ls12371) ls22372)))))) (f2370 (cdr new-vars2366) (car new-vars2366))) docstring2334 (chi-body2144 (cons e12362 e22363) e2333 (extend-var-env2099 labels2365 new-vars2366 r2336) (make-binding-wrap2121 old-ids2364 labels2365 w2337) mod2338)))))) tmp2360) ((lambda (_2374) (syntax-violation (quote lambda) "bad lambda" e2333)) tmp2340))) ($sc-dispatch tmp2340 (quote (any any . each-any)))))) ($sc-dispatch tmp2340 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2340 (quote (any any any . each-any))))) c2335))) (chi-body2144 (lambda (body2375 outer-form2376 r2377 w2378 mod2379) (let ((r2380 (cons (quote ("placeholder" placeholder)) r2377))) (let ((ribcage2381 (make-ribcage2111 (quote ()) (quote ()) (quote ())))) (let ((w2382 (make-wrap2106 (wrap-marks2107 w2378) (cons ribcage2381 (wrap-subst2108 w2378))))) (letrec ((parse2383 (lambda (body2384 ids2385 labels2386 vars2387 vals2388 bindings2389) (if (null? body2384) (syntax-violation #f "no expressions in body" outer-form2376) (let ((e2391 (cdar body2384)) (er2392 (caar body2384))) (call-with-values (lambda () (syntax-type2138 e2391 er2392 (quote (())) #f ribcage2381 mod2379)) (lambda (type2393 value2394 e2395 w2396 s2397 mod2398) (if (memv type2393 (quote (define-form))) (let ((id2399 (wrap2132 value2394 w2396 mod2398)) (label2400 (gen-label2109))) (let ((var2401 (gen-var2152 id2399))) (begin (extend-ribcage!2120 ribcage2381 id2399 label2400) (parse2383 (cdr body2384) (cons id2399 ids2385) (cons label2400 labels2386) (cons var2401 vars2387) (cons (cons er2392 (wrap2132 e2395 w2396 mod2398)) vals2388) (cons (cons (quote lexical) var2401) bindings2389))))) (if (memv type2393 (quote (define-syntax-form))) (let ((id2402 (wrap2132 value2394 w2396 mod2398)) (label2403 (gen-label2109))) (begin (extend-ribcage!2120 ribcage2381 id2402 label2403) (parse2383 (cdr body2384) (cons id2402 ids2385) (cons label2403 labels2386) vars2387 vals2388 (cons (cons (quote macro) (cons er2392 (wrap2132 e2395 w2396 mod2398))) bindings2389)))) (if (memv type2393 (quote (begin-form))) ((lambda (tmp2404) ((lambda (tmp2405) (if tmp2405 (apply (lambda (_2406 e12407) (parse2383 (letrec ((f2408 (lambda (forms2409) (if (null? forms2409) (cdr body2384) (cons (cons er2392 (wrap2132 (car forms2409) w2396 mod2398)) (f2408 (cdr forms2409))))))) (f2408 e12407)) ids2385 labels2386 vars2387 vals2388 bindings2389)) tmp2405) (syntax-violation #f "source expression failed to match any pattern" tmp2404))) ($sc-dispatch tmp2404 (quote (any . each-any))))) e2395) (if (memv type2393 (quote (local-syntax-form))) (chi-local-syntax2146 value2394 e2395 er2392 w2396 s2397 mod2398 (lambda (forms2411 er2412 w2413 s2414 mod2415) (parse2383 (letrec ((f2416 (lambda (forms2417) (if (null? forms2417) (cdr body2384) (cons (cons er2412 (wrap2132 (car forms2417) w2413 mod2415)) (f2416 (cdr forms2417))))))) (f2416 forms2411)) ids2385 labels2386 vars2387 vals2388 bindings2389))) (if (null? ids2385) (build-sequence2083 #f (map (lambda (x2418) (chi2140 (cdr x2418) (car x2418) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))) (begin (if (not (valid-bound-ids?2129 ids2385)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form2376) (if #f #f)) (letrec ((loop2419 (lambda (bs2420 er-cache2421 r-cache2422) (if (not (null? bs2420)) (let ((b2423 (car bs2420))) (if (eq? (car b2423) (quote macro)) (let ((er2424 (cadr b2423))) (let ((r-cache2425 (if (eq? er2424 er-cache2421) r-cache2422 (macros-only-env2100 er2424)))) (begin (set-cdr! b2423 (eval-local-transformer2147 (chi2140 (cddr b2423) r-cache2425 (quote (())) mod2398) mod2398)) (loop2419 (cdr bs2420) er2424 r-cache2425)))) (loop2419 (cdr bs2420) er-cache2421 r-cache2422))) (if #f #f))))) (loop2419 bindings2389 #f #f)) (set-cdr! r2380 (extend-env2098 labels2386 bindings2389 (cdr r2380))) (build-letrec2086 #f (map syntax->datum ids2385) vars2387 (map (lambda (x2426) (chi2140 (cdr x2426) (car x2426) (quote (())) mod2398)) vals2388) (build-sequence2083 #f (map (lambda (x2427) (chi2140 (cdr x2427) (car x2427) (quote (())) mod2398)) (cons (cons er2392 (source-wrap2133 e2395 w2396 s2397 mod2398)) (cdr body2384)))))))))))))))))) (parse2383 (map (lambda (x2390) (cons r2380 (wrap2132 x2390 w2382 mod2379))) body2375) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro2143 (lambda (p2428 e2429 r2430 w2431 rib2432 mod2433) (letrec ((rebuild-macro-output2434 (lambda (x2435 m2436) (if (pair? x2435) (cons (rebuild-macro-output2434 (car x2435) m2436) (rebuild-macro-output2434 (cdr x2435) m2436)) (if (syntax-object?2088 x2435) (let ((w2437 (syntax-object-wrap2090 x2435))) (let ((ms2438 (wrap-marks2107 w2437)) (s2439 (wrap-subst2108 w2437))) (if (if (pair? ms2438) (eq? (car ms2438) #f) #f) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cdr ms2438) (if rib2432 (cons rib2432 (cdr s2439)) (cdr s2439))) (syntax-object-module2091 x2435)) (make-syntax-object2087 (syntax-object-expression2089 x2435) (make-wrap2106 (cons m2436 ms2438) (if rib2432 (cons rib2432 (cons (quote shift) s2439)) (cons (quote shift) s2439))) (let ((pmod2440 (procedure-module p2428))) (if pmod2440 (cons (quote hygiene) (module-name pmod2440)) (quote (hygiene guile)))))))) (if (vector? x2435) (let ((n2441 (vector-length x2435))) (let ((v2442 (make-vector n2441))) (letrec ((loop2443 (lambda (i2444) (if (fx=2065 i2444 n2441) (begin (if #f #f (if #f #f)) v2442) (begin (vector-set! v2442 i2444 (rebuild-macro-output2434 (vector-ref x2435 i2444) m2436)) (loop2443 (fx+2063 i2444 1))))))) (loop2443 0)))) (if (symbol? x2435) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap2133 e2429 w2431 s mod2433) x2435) x2435))))))) (rebuild-macro-output2434 (p2428 (wrap2132 e2429 (anti-mark2119 w2431) mod2433)) (string #\m))))) (chi-application2142 (lambda (x2445 e2446 r2447 w2448 s2449 mod2450) ((lambda (tmp2451) ((lambda (tmp2452) (if tmp2452 (apply (lambda (e02453 e12454) (build-application2072 s2449 x2445 (map (lambda (e2455) (chi2140 e2455 r2447 w2448 mod2450)) e12454))) tmp2452) (syntax-violation #f "source expression failed to match any pattern" tmp2451))) ($sc-dispatch tmp2451 (quote (any . each-any))))) e2446))) (chi-expr2141 (lambda (type2457 value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (lexical))) (build-lexical-reference2074 (quote value) s2462 e2459 value2458) (if (memv type2457 (quote (core external-macro))) (value2458 e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (module-ref))) (call-with-values (lambda () (value2458 e2459)) (lambda (id2464 mod2465) (build-global-reference2077 s2462 id2464 mod2465))) (if (memv type2457 (quote (lexical-call))) (chi-application2142 (build-lexical-reference2074 (quote fun) (source-annotation2095 (car e2459)) (car e2459) value2458) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (global-call))) (chi-application2142 (build-global-reference2077 (source-annotation2095 (car e2459)) value2458 (if (syntax-object?2088 (car e2459)) (syntax-object-module2091 (car e2459)) mod2463)) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (constant))) (build-data2082 s2462 (strip2151 (source-wrap2133 e2459 w2461 s2462 mod2463) (quote (())))) (if (memv type2457 (quote (global))) (build-global-reference2077 s2462 value2458 mod2463) (if (memv type2457 (quote (call))) (chi-application2142 (chi2140 (car e2459) r2460 w2461 mod2463) e2459 r2460 w2461 s2462 mod2463) (if (memv type2457 (quote (begin-form))) ((lambda (tmp2466) ((lambda (tmp2467) (if tmp2467 (apply (lambda (_2468 e12469 e22470) (chi-sequence2134 (cons e12469 e22470) r2460 w2461 s2462 mod2463)) tmp2467) (syntax-violation #f "source expression failed to match any pattern" tmp2466))) ($sc-dispatch tmp2466 (quote (any any . each-any))))) e2459) (if (memv type2457 (quote (local-syntax-form))) (chi-local-syntax2146 value2458 e2459 r2460 w2461 s2462 mod2463 chi-sequence2134) (if (memv type2457 (quote (eval-when-form))) ((lambda (tmp2472) ((lambda (tmp2473) (if tmp2473 (apply (lambda (_2474 x2475 e12476 e22477) (let ((when-list2478 (chi-when-list2137 e2459 x2475 w2461))) (if (memq (quote eval) when-list2478) (chi-sequence2134 (cons e12476 e22477) r2460 w2461 s2462 mod2463) (chi-void2148)))) tmp2473) (syntax-violation #f "source expression failed to match any pattern" tmp2472))) ($sc-dispatch tmp2472 (quote (any each-any any . each-any))))) e2459) (if (memv type2457 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e2459 (wrap2132 value2458 w2461 mod2463)) (if (memv type2457 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap2133 e2459 w2461 s2462 mod2463)) (if (memv type2457 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap2133 e2459 w2461 s2462 mod2463)) (syntax-violation #f "unexpected syntax" (source-wrap2133 e2459 w2461 s2462 mod2463)))))))))))))))))) (chi2140 (lambda (e2481 r2482 w2483 mod2484) (call-with-values (lambda () (syntax-type2138 e2481 r2482 w2483 #f #f mod2484)) (lambda (type2485 value2486 e2487 w2488 s2489 mod2490) (chi-expr2141 type2485 value2486 e2487 r2482 w2488 s2489 mod2490))))) (chi-top2139 (lambda (e2491 r2492 w2493 m2494 esew2495 mod2496) (call-with-values (lambda () (syntax-type2138 e2491 r2492 w2493 #f #f mod2496)) (lambda (type2504 value2505 e2506 w2507 s2508 mod2509) (if (memv type2504 (quote (begin-form))) ((lambda (tmp2510) ((lambda (tmp2511) (if tmp2511 (apply (lambda (_2512) (chi-void2148)) tmp2511) ((lambda (tmp2513) (if tmp2513 (apply (lambda (_2514 e12515 e22516) (chi-top-sequence2135 (cons e12515 e22516) r2492 w2507 s2508 m2494 esew2495 mod2509)) tmp2513) (syntax-violation #f "source expression failed to match any pattern" tmp2510))) ($sc-dispatch tmp2510 (quote (any any . each-any)))))) ($sc-dispatch tmp2510 (quote (any))))) e2506) (if (memv type2504 (quote (local-syntax-form))) (chi-local-syntax2146 value2505 e2506 r2492 w2507 s2508 mod2509 (lambda (body2518 r2519 w2520 s2521 mod2522) (chi-top-sequence2135 body2518 r2519 w2520 s2521 m2494 esew2495 mod2522))) (if (memv type2504 (quote (eval-when-form))) ((lambda (tmp2523) ((lambda (tmp2524) (if tmp2524 (apply (lambda (_2525 x2526 e12527 e22528) (let ((when-list2529 (chi-when-list2137 e2506 x2526 w2507)) (body2530 (cons e12527 e22528))) (if (eq? m2494 (quote e)) (if (memq (quote eval) when-list2529) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) (chi-void2148)) (if (memq (quote load) when-list2529) (if (let ((t2533 (memq (quote compile) when-list2529))) (if t2533 t2533 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c&e) (quote (compile load)) mod2509) (if (memq m2494 (quote (c c&e))) (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote c) (quote (load)) mod2509) (chi-void2148))) (if (let ((t2534 (memq (quote compile) when-list2529))) (if t2534 t2534 (if (eq? m2494 (quote c&e)) (memq (quote eval) when-list2529) #f))) (begin (top-level-eval-hook2067 (chi-top-sequence2135 body2530 r2492 w2507 s2508 (quote e) (quote (eval)) mod2509) mod2509) (chi-void2148)) (chi-void2148)))))) tmp2524) (syntax-violation #f "source expression failed to match any pattern" tmp2523))) ($sc-dispatch tmp2523 (quote (any each-any any . each-any))))) e2506) (if (memv type2504 (quote (define-syntax-form))) (let ((n2535 (id-var-name2126 value2505 w2507)) (r2536 (macros-only-env2100 r2492))) (if (memv m2494 (quote (c))) (if (memq (quote compile) esew2495) (let ((e2537 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2537 mod2509) (if (memq (quote load) esew2495) e2537 (chi-void2148)))) (if (memq (quote load) esew2495) (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) (chi-void2148))) (if (memv m2494 (quote (c&e))) (let ((e2538 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)))) (begin (top-level-eval-hook2067 e2538 mod2509) e2538)) (begin (if (memq (quote eval) esew2495) (top-level-eval-hook2067 (chi-install-global2136 n2535 (chi2140 e2506 r2536 w2507 mod2509)) mod2509) (if #f #f)) (chi-void2148))))) (if (memv type2504 (quote (define-form))) (let ((n2539 (id-var-name2126 value2505 w2507))) (let ((type2540 (binding-type2096 (lookup2101 n2539 r2492 mod2509)))) (if (memv type2540 (quote (global core macro module-ref))) (let ((x2541 (build-global-definition2079 s2508 n2539 (chi2140 e2506 r2492 w2507 mod2509)))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2541 mod2509) (if #f #f)) x2541)) (if (memv type2540 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e2506 (wrap2132 value2505 w2507 mod2509)) (syntax-violation #f "cannot define keyword at top level" e2506 (wrap2132 value2505 w2507 mod2509)))))) (let ((x2542 (chi-expr2141 type2504 value2505 e2506 r2492 w2507 s2508 mod2509))) (begin (if (eq? m2494 (quote c&e)) (top-level-eval-hook2067 x2542 mod2509) (if #f #f)) x2542))))))))))) (syntax-type2138 (lambda (e2543 r2544 w2545 s2546 rib2547 mod2548) (if (symbol? e2543) (let ((n2549 (id-var-name2126 e2543 w2545))) (let ((b2550 (lookup2101 n2549 r2544 mod2548))) (let ((type2551 (binding-type2096 b2550))) (if (memv type2551 (quote (lexical))) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (global))) (values type2551 n2549 e2543 w2545 s2546 mod2548) (if (memv type2551 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2550) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (values type2551 (binding-value2097 b2550) e2543 w2545 s2546 mod2548))))))) (if (pair? e2543) (let ((first2552 (car e2543))) (if (id?2104 first2552) (let ((n2553 (id-var-name2126 first2552 w2545))) (let ((b2554 (lookup2101 n2553 r2544 (let ((t2555 (if (syntax-object?2088 first2552) (syntax-object-module2091 first2552) #f))) (if t2555 t2555 mod2548))))) (let ((type2556 (binding-type2096 b2554))) (if (memv type2556 (quote (lexical))) (values (quote lexical-call) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (global))) (values (quote global-call) n2553 e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (macro))) (syntax-type2138 (chi-macro2143 (binding-value2097 b2554) e2543 r2544 w2545 rib2547 mod2548) r2544 (quote (())) s2546 rib2547 mod2548) (if (memv type2556 (quote (core external-macro module-ref))) (values type2556 (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value2097 b2554) e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (begin))) (values (quote begin-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (eval-when))) (values (quote eval-when-form) #f e2543 w2545 s2546 mod2548) (if (memv type2556 (quote (define))) ((lambda (tmp2557) ((lambda (tmp2558) (if (if tmp2558 (apply (lambda (_2559 name2560 val2561) (id?2104 name2560)) tmp2558) #f) (apply (lambda (_2562 name2563 val2564) (values (quote define-form) name2563 val2564 w2545 s2546 mod2548)) tmp2558) ((lambda (tmp2565) (if (if tmp2565 (apply (lambda (_2566 name2567 args2568 e12569 e22570) (if (id?2104 name2567) (valid-bound-ids?2129 (lambda-var-list2153 args2568)) #f)) tmp2565) #f) (apply (lambda (_2571 name2572 args2573 e12574 e22575) (values (quote define-form) (wrap2132 name2572 w2545 mod2548) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "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 () () ()) #(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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap2132 (cons args2573 (cons e12574 e22575)) w2545 mod2548)) (quote (())) s2546 mod2548)) tmp2565) ((lambda (tmp2577) (if (if tmp2577 (apply (lambda (_2578 name2579) (id?2104 name2579)) tmp2577) #f) (apply (lambda (_2580 name2581) (values (quote define-form) (wrap2132 name2581 w2545 mod2548) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "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 () () ()) #(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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "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 () () ()) #(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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "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 () () ()) #(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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s2546 mod2548)) tmp2577) (syntax-violation #f "source expression failed to match any pattern" tmp2557))) ($sc-dispatch tmp2557 (quote (any any)))))) ($sc-dispatch tmp2557 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2557 (quote (any any any))))) e2543) (if (memv type2556 (quote (define-syntax))) ((lambda (tmp2582) ((lambda (tmp2583) (if (if tmp2583 (apply (lambda (_2584 name2585 val2586) (id?2104 name2585)) tmp2583) #f) (apply (lambda (_2587 name2588 val2589) (values (quote define-syntax-form) name2588 val2589 w2545 s2546 mod2548)) tmp2583) (syntax-violation #f "source expression failed to match any pattern" tmp2582))) ($sc-dispatch tmp2582 (quote (any any any))))) e2543) (values (quote call) #f e2543 w2545 s2546 mod2548))))))))))))) (values (quote call) #f e2543 w2545 s2546 mod2548))) (if (syntax-object?2088 e2543) (syntax-type2138 (syntax-object-expression2089 e2543) r2544 (join-wraps2123 w2545 (syntax-object-wrap2090 e2543)) #f rib2547 (let ((t2590 (syntax-object-module2091 e2543))) (if t2590 t2590 mod2548))) (if (annotation? e2543) (syntax-type2138 (annotation-expression e2543) r2544 w2545 (annotation-source e2543) rib2547 mod2548) (if (self-evaluating? e2543) (values (quote constant) #f e2543 w2545 s2546 mod2548) (values (quote other) #f e2543 w2545 s2546 mod2548)))))))) (chi-when-list2137 (lambda (e2591 when-list2592 w2593) (letrec ((f2594 (lambda (when-list2595 situations2596) (if (null? when-list2595) situations2596 (f2594 (cdr when-list2595) (cons (let ((x2597 (car when-list2595))) (if (free-id=?2127 x2597 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?2127 x2597 (quote #(syntax-object load ((top) #(ribcage () () ()) #(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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?2127 x2597 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e2591 (wrap2132 x2597 w2593 #f)))))) situations2596)))))) (f2594 when-list2592 (quote ()))))) (chi-install-global2136 (lambda (name2598 e2599) (build-global-definition2079 #f name2598 (if (let ((v2600 (module-variable (current-module) name2598))) (if v2600 (if (variable-bound? v2600) (if (macro? (variable-ref v2600)) (not (eq? (macro-type (variable-ref v2600)) (quote syncase-macro))) #f) #f) #f)) (build-application2072 #f (build-primref2081 #f (quote make-extended-syncase-macro)) (list (build-application2072 #f (build-primref2081 #f (quote module-ref)) (list (build-application2072 #f (quote current-module) (quote ())) (build-data2082 #f name2598))) (build-data2082 #f (quote macro)) e2599)) (build-application2072 #f (build-primref2081 #f (quote make-syncase-macro)) (list (build-data2082 #f (quote macro)) e2599)))))) (chi-top-sequence2135 (lambda (body2601 r2602 w2603 s2604 m2605 esew2606 mod2607) (build-sequence2083 s2604 (letrec ((dobody2608 (lambda (body2609 r2610 w2611 m2612 esew2613 mod2614) (if (null? body2609) (quote ()) (let ((first2615 (chi-top2139 (car body2609) r2610 w2611 m2612 esew2613 mod2614))) (cons first2615 (dobody2608 (cdr body2609) r2610 w2611 m2612 esew2613 mod2614))))))) (dobody2608 body2601 r2602 w2603 m2605 esew2606 mod2607))))) (chi-sequence2134 (lambda (body2616 r2617 w2618 s2619 mod2620) (build-sequence2083 s2619 (letrec ((dobody2621 (lambda (body2622 r2623 w2624 mod2625) (if (null? body2622) (quote ()) (let ((first2626 (chi2140 (car body2622) r2623 w2624 mod2625))) (cons first2626 (dobody2621 (cdr body2622) r2623 w2624 mod2625))))))) (dobody2621 body2616 r2617 w2618 mod2620))))) (source-wrap2133 (lambda (x2627 w2628 s2629 defmod2630) (wrap2132 (if s2629 (make-annotation x2627 s2629 #f) x2627) w2628 defmod2630))) (wrap2132 (lambda (x2631 w2632 defmod2633) (if (if (null? (wrap-marks2107 w2632)) (null? (wrap-subst2108 w2632)) #f) x2631 (if (syntax-object?2088 x2631) (make-syntax-object2087 (syntax-object-expression2089 x2631) (join-wraps2123 w2632 (syntax-object-wrap2090 x2631)) (syntax-object-module2091 x2631)) (if (null? x2631) x2631 (make-syntax-object2087 x2631 w2632 defmod2633)))))) (bound-id-member?2131 (lambda (x2634 list2635) (if (not (null? list2635)) (let ((t2636 (bound-id=?2128 x2634 (car list2635)))) (if t2636 t2636 (bound-id-member?2131 x2634 (cdr list2635)))) #f))) (distinct-bound-ids?2130 (lambda (ids2637) (letrec ((distinct?2638 (lambda (ids2639) (let ((t2640 (null? ids2639))) (if t2640 t2640 (if (not (bound-id-member?2131 (car ids2639) (cdr ids2639))) (distinct?2638 (cdr ids2639)) #f)))))) (distinct?2638 ids2637)))) (valid-bound-ids?2129 (lambda (ids2641) (if (letrec ((all-ids?2642 (lambda (ids2643) (let ((t2644 (null? ids2643))) (if t2644 t2644 (if (id?2104 (car ids2643)) (all-ids?2642 (cdr ids2643)) #f)))))) (all-ids?2642 ids2641)) (distinct-bound-ids?2130 ids2641) #f))) (bound-id=?2128 (lambda (i2645 j2646) (if (if (syntax-object?2088 i2645) (syntax-object?2088 j2646) #f) (if (eq? (let ((e2647 (syntax-object-expression2089 i2645))) (if (annotation? e2647) (annotation-expression e2647) e2647)) (let ((e2648 (syntax-object-expression2089 j2646))) (if (annotation? e2648) (annotation-expression e2648) e2648))) (same-marks?2125 (wrap-marks2107 (syntax-object-wrap2090 i2645)) (wrap-marks2107 (syntax-object-wrap2090 j2646))) #f) (eq? (let ((e2649 i2645)) (if (annotation? e2649) (annotation-expression e2649) e2649)) (let ((e2650 j2646)) (if (annotation? e2650) (annotation-expression e2650) e2650)))))) (free-id=?2127 (lambda (i2651 j2652) (if (eq? (let ((x2653 i2651)) (let ((e2654 (if (syntax-object?2088 x2653) (syntax-object-expression2089 x2653) x2653))) (if (annotation? e2654) (annotation-expression e2654) e2654))) (let ((x2655 j2652)) (let ((e2656 (if (syntax-object?2088 x2655) (syntax-object-expression2089 x2655) x2655))) (if (annotation? e2656) (annotation-expression e2656) e2656)))) (eq? (id-var-name2126 i2651 (quote (()))) (id-var-name2126 j2652 (quote (())))) #f))) (id-var-name2126 (lambda (id2657 w2658) (letrec ((search-vector-rib2661 (lambda (sym2667 subst2668 marks2669 symnames2670 ribcage2671) (let ((n2672 (vector-length symnames2670))) (letrec ((f2673 (lambda (i2674) (if (fx=2065 i2674 n2672) (search2659 sym2667 (cdr subst2668) marks2669) (if (if (eq? (vector-ref symnames2670 i2674) sym2667) (same-marks?2125 marks2669 (vector-ref (ribcage-marks2114 ribcage2671) i2674)) #f) (values (vector-ref (ribcage-labels2115 ribcage2671) i2674) marks2669) (f2673 (fx+2063 i2674 1))))))) (f2673 0))))) (search-list-rib2660 (lambda (sym2675 subst2676 marks2677 symnames2678 ribcage2679) (letrec ((f2680 (lambda (symnames2681 i2682) (if (null? symnames2681) (search2659 sym2675 (cdr subst2676) marks2677) (if (if (eq? (car symnames2681) sym2675) (same-marks?2125 marks2677 (list-ref (ribcage-marks2114 ribcage2679) i2682)) #f) (values (list-ref (ribcage-labels2115 ribcage2679) i2682) marks2677) (f2680 (cdr symnames2681) (fx+2063 i2682 1))))))) (f2680 symnames2678 0)))) (search2659 (lambda (sym2683 subst2684 marks2685) (if (null? subst2684) (values #f marks2685) (let ((fst2686 (car subst2684))) (if (eq? fst2686 (quote shift)) (search2659 sym2683 (cdr subst2684) (cdr marks2685)) (let ((symnames2687 (ribcage-symnames2113 fst2686))) (if (vector? symnames2687) (search-vector-rib2661 sym2683 subst2684 marks2685 symnames2687 fst2686) (search-list-rib2660 sym2683 subst2684 marks2685 symnames2687 fst2686))))))))) (if (symbol? id2657) (let ((t2688 (call-with-values (lambda () (search2659 id2657 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2690 . ignore2689) x2690)))) (if t2688 t2688 id2657)) (if (syntax-object?2088 id2657) (let ((id2691 (let ((e2693 (syntax-object-expression2089 id2657))) (if (annotation? e2693) (annotation-expression e2693) e2693))) (w12692 (syntax-object-wrap2090 id2657))) (let ((marks2694 (join-marks2124 (wrap-marks2107 w2658) (wrap-marks2107 w12692)))) (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w2658) marks2694)) (lambda (new-id2695 marks2696) (let ((t2697 new-id2695)) (if t2697 t2697 (let ((t2698 (call-with-values (lambda () (search2659 id2691 (wrap-subst2108 w12692) marks2696)) (lambda (x2700 . ignore2699) x2700)))) (if t2698 t2698 id2691)))))))) (if (annotation? id2657) (let ((id2701 (let ((e2702 id2657)) (if (annotation? e2702) (annotation-expression e2702) e2702)))) (let ((t2703 (call-with-values (lambda () (search2659 id2701 (wrap-subst2108 w2658) (wrap-marks2107 w2658))) (lambda (x2705 . ignore2704) x2705)))) (if t2703 t2703 id2701))) (syntax-violation (quote id-var-name) "invalid id" id2657))))))) (same-marks?2125 (lambda (x2706 y2707) (let ((t2708 (eq? x2706 y2707))) (if t2708 t2708 (if (not (null? x2706)) (if (not (null? y2707)) (if (eq? (car x2706) (car y2707)) (same-marks?2125 (cdr x2706) (cdr y2707)) #f) #f) #f))))) (join-marks2124 (lambda (m12709 m22710) (smart-append2122 m12709 m22710))) (join-wraps2123 (lambda (w12711 w22712) (let ((m12713 (wrap-marks2107 w12711)) (s12714 (wrap-subst2108 w12711))) (if (null? m12713) (if (null? s12714) w22712 (make-wrap2106 (wrap-marks2107 w22712) (smart-append2122 s12714 (wrap-subst2108 w22712)))) (make-wrap2106 (smart-append2122 m12713 (wrap-marks2107 w22712)) (smart-append2122 s12714 (wrap-subst2108 w22712))))))) (smart-append2122 (lambda (m12715 m22716) (if (null? m22716) m12715 (append m12715 m22716)))) (make-binding-wrap2121 (lambda (ids2717 labels2718 w2719) (if (null? ids2717) w2719 (make-wrap2106 (wrap-marks2107 w2719) (cons (let ((labelvec2720 (list->vector labels2718))) (let ((n2721 (vector-length labelvec2720))) (let ((symnamevec2722 (make-vector n2721)) (marksvec2723 (make-vector n2721))) (begin (letrec ((f2724 (lambda (ids2725 i2726) (if (not (null? ids2725)) (call-with-values (lambda () (id-sym-name&marks2105 (car ids2725) w2719)) (lambda (symname2727 marks2728) (begin (vector-set! symnamevec2722 i2726 symname2727) (vector-set! marksvec2723 i2726 marks2728) (f2724 (cdr ids2725) (fx+2063 i2726 1))))) (if #f #f))))) (f2724 ids2717 0)) (make-ribcage2111 symnamevec2722 marksvec2723 labelvec2720))))) (wrap-subst2108 w2719)))))) (extend-ribcage!2120 (lambda (ribcage2729 id2730 label2731) (begin (set-ribcage-symnames!2116 ribcage2729 (cons (let ((e2732 (syntax-object-expression2089 id2730))) (if (annotation? e2732) (annotation-expression e2732) e2732)) (ribcage-symnames2113 ribcage2729))) (set-ribcage-marks!2117 ribcage2729 (cons (wrap-marks2107 (syntax-object-wrap2090 id2730)) (ribcage-marks2114 ribcage2729))) (set-ribcage-labels!2118 ribcage2729 (cons label2731 (ribcage-labels2115 ribcage2729)))))) (anti-mark2119 (lambda (w2733) (make-wrap2106 (cons #f (wrap-marks2107 w2733)) (cons (quote shift) (wrap-subst2108 w2733))))) (set-ribcage-labels!2118 (lambda (x2734 update2735) (vector-set! x2734 3 update2735))) (set-ribcage-marks!2117 (lambda (x2736 update2737) (vector-set! x2736 2 update2737))) (set-ribcage-symnames!2116 (lambda (x2738 update2739) (vector-set! x2738 1 update2739))) (ribcage-labels2115 (lambda (x2740) (vector-ref x2740 3))) (ribcage-marks2114 (lambda (x2741) (vector-ref x2741 2))) (ribcage-symnames2113 (lambda (x2742) (vector-ref x2742 1))) (ribcage?2112 (lambda (x2743) (if (vector? x2743) (if (= (vector-length x2743) 4) (eq? (vector-ref x2743 0) (quote ribcage)) #f) #f))) (make-ribcage2111 (lambda (symnames2744 marks2745 labels2746) (vector (quote ribcage) symnames2744 marks2745 labels2746))) (gen-labels2110 (lambda (ls2747) (if (null? ls2747) (quote ()) (cons (gen-label2109) (gen-labels2110 (cdr ls2747)))))) (gen-label2109 (lambda () (string #\i))) (wrap-subst2108 cdr) (wrap-marks2107 car) (make-wrap2106 cons) (id-sym-name&marks2105 (lambda (x2748 w2749) (if (syntax-object?2088 x2748) (values (let ((e2750 (syntax-object-expression2089 x2748))) (if (annotation? e2750) (annotation-expression e2750) e2750)) (join-marks2124 (wrap-marks2107 w2749) (wrap-marks2107 (syntax-object-wrap2090 x2748)))) (values (let ((e2751 x2748)) (if (annotation? e2751) (annotation-expression e2751) e2751)) (wrap-marks2107 w2749))))) (id?2104 (lambda (x2752) (if (symbol? x2752) #t (if (syntax-object?2088 x2752) (symbol? (let ((e2753 (syntax-object-expression2089 x2752))) (if (annotation? e2753) (annotation-expression e2753) e2753))) (if (annotation? x2752) (symbol? (annotation-expression x2752)) #f))))) (nonsymbol-id?2103 (lambda (x2754) (if (syntax-object?2088 x2754) (symbol? (let ((e2755 (syntax-object-expression2089 x2754))) (if (annotation? e2755) (annotation-expression e2755) e2755))) #f))) (global-extend2102 (lambda (type2756 sym2757 val2758) (put-global-definition-hook2069 sym2757 type2756 val2758))) (lookup2101 (lambda (x2759 r2760 mod2761) (let ((temp2762 (assq x2759 r2760))) (if temp2762 (cdr temp2762) (if (symbol? x2759) (let ((t2763 (get-global-definition-hook2070 x2759 mod2761))) (if t2763 t2763 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env2100 (lambda (r2764) (if (null? r2764) (quote ()) (let ((a2765 (car r2764))) (if (eq? (cadr a2765) (quote macro)) (cons a2765 (macros-only-env2100 (cdr r2764))) (macros-only-env2100 (cdr r2764))))))) (extend-var-env2099 (lambda (labels2766 vars2767 r2768) (if (null? labels2766) r2768 (extend-var-env2099 (cdr labels2766) (cdr vars2767) (cons (cons (car labels2766) (cons (quote lexical) (car vars2767))) r2768))))) (extend-env2098 (lambda (labels2769 bindings2770 r2771) (if (null? labels2769) r2771 (extend-env2098 (cdr labels2769) (cdr bindings2770) (cons (cons (car labels2769) (car bindings2770)) r2771))))) (binding-value2097 cdr) (binding-type2096 car) (source-annotation2095 (lambda (x2772) (if (annotation? x2772) (annotation-source x2772) (if (syntax-object?2088 x2772) (source-annotation2095 (syntax-object-expression2089 x2772)) #f)))) (set-syntax-object-module!2094 (lambda (x2773 update2774) (vector-set! x2773 3 update2774))) (set-syntax-object-wrap!2093 (lambda (x2775 update2776) (vector-set! x2775 2 update2776))) (set-syntax-object-expression!2092 (lambda (x2777 update2778) (vector-set! x2777 1 update2778))) (syntax-object-module2091 (lambda (x2779) (vector-ref x2779 3))) (syntax-object-wrap2090 (lambda (x2780) (vector-ref x2780 2))) (syntax-object-expression2089 (lambda (x2781) (vector-ref x2781 1))) (syntax-object?2088 (lambda (x2782) (if (vector? x2782) (if (= (vector-length x2782) 4) (eq? (vector-ref x2782 0) (quote syntax-object)) #f) #f))) (make-syntax-object2087 (lambda (expression2783 wrap2784 module2785) (vector (quote syntax-object) expression2783 wrap2784 module2785))) (build-letrec2086 (lambda (src2786 ids2787 vars2788 val-exps2789 body-exp2790) (if (null? vars2788) body-exp2790 (let ((atom-key2791 (fluid-ref *mode*2062))) (if (memv atom-key2791 (quote (c))) ((@ (language tree-il) make-letrec) src2786 ids2787 vars2788 val-exps2789 body-exp2790) (list (quote letrec) (map list vars2788 val-exps2789) body-exp2790)))))) (build-named-let2085 (lambda (src2792 ids2793 vars2794 val-exps2795 body-exp2796) (let ((f2797 (car vars2794)) (f-name2798 (car ids2793)) (vars2799 (cdr vars2794)) (ids2800 (cdr ids2793))) (let ((atom-key2801 (fluid-ref *mode*2062))) (if (memv atom-key2801 (quote (c))) ((@ (language tree-il) make-letrec) src2792 (list f-name2798) (list f2797) (list (build-lambda2080 src2792 ids2800 vars2799 #f body-exp2796)) (build-application2072 src2792 (build-lexical-reference2074 (quote fun) src2792 f-name2798 f2797) val-exps2795)) (list (quote let) f2797 (map list vars2799 val-exps2795) body-exp2796)))))) (build-let2084 (lambda (src2802 ids2803 vars2804 val-exps2805 body-exp2806) (if (null? vars2804) body-exp2806 (let ((atom-key2807 (fluid-ref *mode*2062))) (if (memv atom-key2807 (quote (c))) ((@ (language tree-il) make-let) src2802 ids2803 vars2804 val-exps2805 body-exp2806) (list (quote let) (map list vars2804 val-exps2805) body-exp2806)))))) (build-sequence2083 (lambda (src2808 exps2809) (if (null? (cdr exps2809)) (car exps2809) (let ((atom-key2810 (fluid-ref *mode*2062))) (if (memv atom-key2810 (quote (c))) ((@ (language tree-il) make-sequence) src2808 exps2809) (cons (quote begin) exps2809)))))) (build-data2082 (lambda (src2811 exp2812) (let ((atom-key2813 (fluid-ref *mode*2062))) (if (memv atom-key2813 (quote (c))) ((@ (language tree-il) make-const) src2811 exp2812) (if (if (self-evaluating? exp2812) (not (vector? exp2812)) #f) exp2812 (list (quote quote) exp2812)))))) (build-primref2081 (lambda (src2814 name2815) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key2816 (fluid-ref *mode*2062))) (if (memv atom-key2816 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src2814 name2815) name2815)) (let ((atom-key2817 (fluid-ref *mode*2062))) (if (memv atom-key2817 (quote (c))) ((@ (language tree-il) make-module-ref) src2814 (quote (guile)) name2815 #f) (list (quote @@) (quote (guile)) name2815)))))) (build-lambda2080 (lambda (src2818 ids2819 vars2820 docstring2821 exp2822) (let ((atom-key2823 (fluid-ref *mode*2062))) (if (memv atom-key2823 (quote (c))) ((@ (language tree-il) make-lambda) src2818 ids2819 vars2820 (if docstring2821 (list (cons (quote documentation) docstring2821)) (quote ())) exp2822) (cons (quote lambda) (cons vars2820 (append (if docstring2821 (list docstring2821) (quote ())) (list exp2822)))))))) (build-global-definition2079 (lambda (source2824 var2825 exp2826) (let ((atom-key2827 (fluid-ref *mode*2062))) (if (memv atom-key2827 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2824 var2825 exp2826) (list (quote define) var2825 exp2826))))) (build-global-assignment2078 (lambda (source2828 var2829 exp2830 mod2831) (analyze-variable2076 mod2831 var2829 (lambda (mod2832 var2833 public?2834) (let ((atom-key2835 (fluid-ref *mode*2062))) (if (memv atom-key2835 (quote (c))) ((@ (language tree-il) make-module-set) source2828 mod2832 var2833 public?2834 exp2830) (list (quote set!) (list (if public?2834 (quote @) (quote @@)) mod2832 var2833) exp2830)))) (lambda (var2836) (let ((atom-key2837 (fluid-ref *mode*2062))) (if (memv atom-key2837 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2828 var2836 exp2830) (list (quote set!) var2836 exp2830))))))) (build-global-reference2077 (lambda (source2838 var2839 mod2840) (analyze-variable2076 mod2840 var2839 (lambda (mod2841 var2842 public?2843) (let ((atom-key2844 (fluid-ref *mode*2062))) (if (memv atom-key2844 (quote (c))) ((@ (language tree-il) make-module-ref) source2838 mod2841 var2842 public?2843) (list (if public?2843 (quote @) (quote @@)) mod2841 var2842)))) (lambda (var2845) (let ((atom-key2846 (fluid-ref *mode*2062))) (if (memv atom-key2846 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2838 var2845) var2845)))))) (analyze-variable2076 (lambda (mod2847 var2848 modref-cont2849 bare-cont2850) (if (not mod2847) (bare-cont2850 var2848) (let ((kind2851 (car mod2847)) (mod2852 (cdr mod2847))) (if (memv kind2851 (quote (public))) (modref-cont2849 mod2852 var2848 #t) (if (memv kind2851 (quote (private))) (if (not (equal? mod2852 (module-name (current-module)))) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (if (memv kind2851 (quote (bare))) (bare-cont2850 var2848) (if (memv kind2851 (quote (hygiene))) (if (if (not (equal? mod2852 (module-name (current-module)))) (module-variable (resolve-module mod2852) var2848) #f) (modref-cont2849 mod2852 var2848 #f) (bare-cont2850 var2848)) (syntax-violation #f "bad module kind" var2848 mod2852))))))))) (build-lexical-assignment2075 (lambda (source2853 name2854 var2855 exp2856) (let ((atom-key2857 (fluid-ref *mode*2062))) (if (memv atom-key2857 (quote (c))) ((@ (language tree-il) make-lexical-set) source2853 name2854 var2855 exp2856) (list (quote set!) var2855 exp2856))))) (build-lexical-reference2074 (lambda (type2858 source2859 name2860 var2861) (let ((atom-key2862 (fluid-ref *mode*2062))) (if (memv atom-key2862 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2859 name2860 var2861) var2861)))) (build-conditional2073 (lambda (source2863 test-exp2864 then-exp2865 else-exp2866) (let ((atom-key2867 (fluid-ref *mode*2062))) (if (memv atom-key2867 (quote (c))) ((@ (language tree-il) make-conditional) source2863 test-exp2864 then-exp2865 else-exp2866) (list (quote if) test-exp2864 then-exp2865 else-exp2866))))) (build-application2072 (lambda (source2868 fun-exp2869 arg-exps2870) (let ((atom-key2871 (fluid-ref *mode*2062))) (if (memv atom-key2871 (quote (c))) ((@ (language tree-il) make-application) source2868 fun-exp2869 arg-exps2870) (cons fun-exp2869 arg-exps2870))))) (build-void2071 (lambda (source2872) (let ((atom-key2873 (fluid-ref *mode*2062))) (if (memv atom-key2873 (quote (c))) ((@ (language tree-il) make-void) source2872) (quote (if #f #f)))))) (get-global-definition-hook2070 (lambda (symbol2874 module2875) (begin (if (if (not module2875) (current-module) #f) (warn "module system is booted, we should have a module" symbol2874) (if #f #f)) (let ((v2876 (module-variable (if module2875 (resolve-module (cdr module2875)) (current-module)) symbol2874))) (if v2876 (if (variable-bound? v2876) (let ((val2877 (variable-ref v2876))) (if (macro? val2877) (if (syncase-macro-type val2877) (cons (syncase-macro-type val2877) (syncase-macro-binding val2877)) #f) #f)) #f) #f))))) (put-global-definition-hook2069 (lambda (symbol2878 type2879 val2880) (let ((existing2881 (let ((v2882 (module-variable (current-module) symbol2878))) (if v2882 (if (variable-bound? v2882) (let ((val2883 (variable-ref v2882))) (if (macro? val2883) (if (not (syncase-macro-type val2883)) val2883 #f) #f)) #f) #f)))) (module-define! (current-module) symbol2878 (if existing2881 (make-extended-syncase-macro existing2881 type2879 val2880) (make-syncase-macro type2879 val2880)))))) (local-eval-hook2068 (lambda (x2884 mod2885) (primitive-eval (list noexpand2061 (let ((atom-key2886 (fluid-ref *mode*2062))) (if (memv atom-key2886 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2884) x2884)))))) (top-level-eval-hook2067 (lambda (x2887 mod2888) (primitive-eval (list noexpand2061 (let ((atom-key2889 (fluid-ref *mode*2062))) (if (memv atom-key2889 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2887) x2887)))))) (fx<2066 <) (fx=2065 =) (fx-2064 -) (fx+2063 +) (*mode*2062 (make-fluid)) (noexpand2061 "noexpand")) (begin (global-extend2102 (quote local-syntax) (quote letrec-syntax) #t) (global-extend2102 (quote local-syntax) (quote let-syntax) #f) (global-extend2102 (quote core) (quote fluid-let-syntax) (lambda (e2890 r2891 w2892 s2893 mod2894) ((lambda (tmp2895) ((lambda (tmp2896) (if (if tmp2896 (apply (lambda (_2897 var2898 val2899 e12900 e22901) (valid-bound-ids?2129 var2898)) tmp2896) #f) (apply (lambda (_2903 var2904 val2905 e12906 e22907) (let ((names2908 (map (lambda (x2909) (id-var-name2126 x2909 w2892)) var2904))) (begin (for-each (lambda (id2911 n2912) (let ((atom-key2913 (binding-type2096 (lookup2101 n2912 r2891 mod2894)))) (if (memv atom-key2913 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e2890 (source-wrap2133 id2911 w2892 s2893 mod2894)) (if #f #f)))) var2904 names2908) (chi-body2144 (cons e12906 e22907) (source-wrap2133 e2890 w2892 s2893 mod2894) (extend-env2098 names2908 (let ((trans-r2916 (macros-only-env2100 r2891))) (map (lambda (x2917) (cons (quote macro) (eval-local-transformer2147 (chi2140 x2917 trans-r2916 w2892 mod2894) mod2894))) val2905)) r2891) w2892 mod2894)))) tmp2896) ((lambda (_2919) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap2133 e2890 w2892 s2893 mod2894))) tmp2895))) ($sc-dispatch tmp2895 (quote (any #(each (any any)) any . each-any))))) e2890))) (global-extend2102 (quote core) (quote quote) (lambda (e2920 r2921 w2922 s2923 mod2924) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 e2928) (build-data2082 s2923 (strip2151 e2928 w2922))) tmp2926) ((lambda (_2929) (syntax-violation (quote quote) "bad syntax" (source-wrap2133 e2920 w2922 s2923 mod2924))) tmp2925))) ($sc-dispatch tmp2925 (quote (any any))))) e2920))) (global-extend2102 (quote core) (quote syntax) (letrec ((regen2937 (lambda (x2938) (let ((atom-key2939 (car x2938))) (if (memv atom-key2939 (quote (ref))) (build-lexical-reference2074 (quote value) #f (cadr x2938) (cadr x2938)) (if (memv atom-key2939 (quote (primitive))) (build-primref2081 #f (cadr x2938)) (if (memv atom-key2939 (quote (quote))) (build-data2082 #f (cadr x2938)) (if (memv atom-key2939 (quote (lambda))) (build-lambda2080 #f (cadr x2938) (cadr x2938) #f (regen2937 (caddr x2938))) (if (memv atom-key2939 (quote (map))) (let ((ls2940 (map regen2937 (cdr x2938)))) (build-application2072 #f (build-primref2081 #f (quote map)) ls2940)) (build-application2072 #f (build-primref2081 #f (car x2938)) (map regen2937 (cdr x2938))))))))))) (gen-vector2936 (lambda (x2941) (if (eq? (car x2941) (quote list)) (cons (quote vector) (cdr x2941)) (if (eq? (car x2941) (quote quote)) (list (quote quote) (list->vector (cadr x2941))) (list (quote list->vector) x2941))))) (gen-append2935 (lambda (x2942 y2943) (if (equal? y2943 (quote (quote ()))) x2942 (list (quote append) x2942 y2943)))) (gen-cons2934 (lambda (x2944 y2945) (let ((atom-key2946 (car y2945))) (if (memv atom-key2946 (quote (quote))) (if (eq? (car x2944) (quote quote)) (list (quote quote) (cons (cadr x2944) (cadr y2945))) (if (eq? (cadr y2945) (quote ())) (list (quote list) x2944) (list (quote cons) x2944 y2945))) (if (memv atom-key2946 (quote (list))) (cons (quote list) (cons x2944 (cdr y2945))) (list (quote cons) x2944 y2945)))))) (gen-map2933 (lambda (e2947 map-env2948) (let ((formals2949 (map cdr map-env2948)) (actuals2950 (map (lambda (x2951) (list (quote ref) (car x2951))) map-env2948))) (if (eq? (car e2947) (quote ref)) (car actuals2950) (if (and-map (lambda (x2952) (if (eq? (car x2952) (quote ref)) (memq (cadr x2952) formals2949) #f)) (cdr e2947)) (cons (quote map) (cons (list (quote primitive) (car e2947)) (map (let ((r2953 (map cons formals2949 actuals2950))) (lambda (x2954) (cdr (assq (cadr x2954) r2953)))) (cdr e2947)))) (cons (quote map) (cons (list (quote lambda) formals2949 e2947) actuals2950))))))) (gen-mappend2932 (lambda (e2955 map-env2956) (list (quote apply) (quote (primitive append)) (gen-map2933 e2955 map-env2956)))) (gen-ref2931 (lambda (src2957 var2958 level2959 maps2960) (if (fx=2065 level2959 0) (values var2958 maps2960) (if (null? maps2960) (syntax-violation (quote syntax) "missing ellipsis" src2957) (call-with-values (lambda () (gen-ref2931 src2957 var2958 (fx-2064 level2959 1) (cdr maps2960))) (lambda (outer-var2961 outer-maps2962) (let ((b2963 (assq outer-var2961 (car maps2960)))) (if b2963 (values (cdr b2963) maps2960) (let ((inner-var2964 (gen-var2152 (quote tmp)))) (values inner-var2964 (cons (cons (cons outer-var2961 inner-var2964) (car maps2960)) outer-maps2962))))))))))) (gen-syntax2930 (lambda (src2965 e2966 r2967 maps2968 ellipsis?2969 mod2970) (if (id?2104 e2966) (let ((label2971 (id-var-name2126 e2966 (quote (()))))) (let ((b2972 (lookup2101 label2971 r2967 mod2970))) (if (eq? (binding-type2096 b2972) (quote syntax)) (call-with-values (lambda () (let ((var.lev2973 (binding-value2097 b2972))) (gen-ref2931 src2965 (car var.lev2973) (cdr var.lev2973) maps2968))) (lambda (var2974 maps2975) (values (list (quote ref) var2974) maps2975))) (if (ellipsis?2969 e2966) (syntax-violation (quote syntax) "misplaced ellipsis" src2965) (values (list (quote quote) e2966) maps2968))))) ((lambda (tmp2976) ((lambda (tmp2977) (if (if tmp2977 (apply (lambda (dots2978 e2979) (ellipsis?2969 dots2978)) tmp2977) #f) (apply (lambda (dots2980 e2981) (gen-syntax2930 src2965 e2981 r2967 maps2968 (lambda (x2982) #f) mod2970)) tmp2977) ((lambda (tmp2983) (if (if tmp2983 (apply (lambda (x2984 dots2985 y2986) (ellipsis?2969 dots2985)) tmp2983) #f) (apply (lambda (x2987 dots2988 y2989) (letrec ((f2990 (lambda (y2991 k2992) ((lambda (tmp2996) ((lambda (tmp2997) (if (if tmp2997 (apply (lambda (dots2998 y2999) (ellipsis?2969 dots2998)) tmp2997) #f) (apply (lambda (dots3000 y3001) (f2990 y3001 (lambda (maps3002) (call-with-values (lambda () (k2992 (cons (quote ()) maps3002))) (lambda (x3003 maps3004) (if (null? (car maps3004)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-mappend2932 x3003 (car maps3004)) (cdr maps3004)))))))) tmp2997) ((lambda (_3005) (call-with-values (lambda () (gen-syntax2930 src2965 y2991 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (y3006 maps3007) (call-with-values (lambda () (k2992 maps3007)) (lambda (x3008 maps3009) (values (gen-append2935 x3008 y3006) maps3009)))))) tmp2996))) ($sc-dispatch tmp2996 (quote (any . any))))) y2991)))) (f2990 y2989 (lambda (maps2993) (call-with-values (lambda () (gen-syntax2930 src2965 x2987 r2967 (cons (quote ()) maps2993) ellipsis?2969 mod2970)) (lambda (x2994 maps2995) (if (null? (car maps2995)) (syntax-violation (quote syntax) "extra ellipsis" src2965) (values (gen-map2933 x2994 (car maps2995)) (cdr maps2995))))))))) tmp2983) ((lambda (tmp3010) (if tmp3010 (apply (lambda (x3011 y3012) (call-with-values (lambda () (gen-syntax2930 src2965 x3011 r2967 maps2968 ellipsis?2969 mod2970)) (lambda (x3013 maps3014) (call-with-values (lambda () (gen-syntax2930 src2965 y3012 r2967 maps3014 ellipsis?2969 mod2970)) (lambda (y3015 maps3016) (values (gen-cons2934 x3013 y3015) maps3016)))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (e13018 e23019) (call-with-values (lambda () (gen-syntax2930 src2965 (cons e13018 e23019) r2967 maps2968 ellipsis?2969 mod2970)) (lambda (e3021 maps3022) (values (gen-vector2936 e3021) maps3022)))) tmp3017) ((lambda (_3023) (values (list (quote quote) e2966) maps2968)) tmp2976))) ($sc-dispatch tmp2976 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2976 (quote (any . any)))))) ($sc-dispatch tmp2976 (quote (any any . any)))))) ($sc-dispatch tmp2976 (quote (any any))))) e2966))))) (lambda (e3024 r3025 w3026 s3027 mod3028) (let ((e3029 (source-wrap2133 e3024 w3026 s3027 mod3028))) ((lambda (tmp3030) ((lambda (tmp3031) (if tmp3031 (apply (lambda (_3032 x3033) (call-with-values (lambda () (gen-syntax2930 e3029 x3033 r3025 (quote ()) ellipsis?2149 mod3028)) (lambda (e3034 maps3035) (regen2937 e3034)))) tmp3031) ((lambda (_3036) (syntax-violation (quote syntax) "bad `syntax' form" e3029)) tmp3030))) ($sc-dispatch tmp3030 (quote (any any))))) e3029))))) (global-extend2102 (quote core) (quote lambda) (lambda (e3037 r3038 w3039 s3040 mod3041) ((lambda (tmp3042) ((lambda (tmp3043) (if tmp3043 (apply (lambda (_3044 c3045) (chi-lambda-clause2145 (source-wrap2133 e3037 w3039 s3040 mod3041) #f c3045 r3038 w3039 mod3041 (lambda (names3046 vars3047 docstring3048 body3049) (build-lambda2080 s3040 names3046 vars3047 docstring3048 body3049)))) tmp3043) (syntax-violation #f "source expression failed to match any pattern" tmp3042))) ($sc-dispatch tmp3042 (quote (any . any))))) e3037))) (global-extend2102 (quote core) (quote let) (letrec ((chi-let3050 (lambda (e3051 r3052 w3053 s3054 mod3055 constructor3056 ids3057 vals3058 exps3059) (if (not (valid-bound-ids?2129 ids3057)) (syntax-violation (quote let) "duplicate bound variable" e3051) (let ((labels3060 (gen-labels2110 ids3057)) (new-vars3061 (map gen-var2152 ids3057))) (let ((nw3062 (make-binding-wrap2121 ids3057 labels3060 w3053)) (nr3063 (extend-var-env2099 labels3060 new-vars3061 r3052))) (constructor3056 s3054 (map syntax->datum ids3057) new-vars3061 (map (lambda (x3064) (chi2140 x3064 r3052 w3053 mod3055)) vals3058) (chi-body2144 exps3059 (source-wrap2133 e3051 nw3062 s3054 mod3055) nr3063 nw3062 mod3055)))))))) (lambda (e3065 r3066 w3067 s3068 mod3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (_3072 id3073 val3074 e13075 e23076) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-let2084 id3073 val3074 (cons e13075 e23076))) tmp3071) ((lambda (tmp3080) (if (if tmp3080 (apply (lambda (_3081 f3082 id3083 val3084 e13085 e23086) (id?2104 f3082)) tmp3080) #f) (apply (lambda (_3087 f3088 id3089 val3090 e13091 e23092) (chi-let3050 e3065 r3066 w3067 s3068 mod3069 build-named-let2085 (cons f3088 id3089) val3090 (cons e13091 e23092))) tmp3080) ((lambda (_3096) (syntax-violation (quote let) "bad let" (source-wrap2133 e3065 w3067 s3068 mod3069))) tmp3070))) ($sc-dispatch tmp3070 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3070 (quote (any #(each (any any)) any . each-any))))) e3065)))) (global-extend2102 (quote core) (quote letrec) (lambda (e3097 r3098 w3099 s3100 mod3101) ((lambda (tmp3102) ((lambda (tmp3103) (if tmp3103 (apply (lambda (_3104 id3105 val3106 e13107 e23108) (let ((ids3109 id3105)) (if (not (valid-bound-ids?2129 ids3109)) (syntax-violation (quote letrec) "duplicate bound variable" e3097) (let ((labels3111 (gen-labels2110 ids3109)) (new-vars3112 (map gen-var2152 ids3109))) (let ((w3113 (make-binding-wrap2121 ids3109 labels3111 w3099)) (r3114 (extend-var-env2099 labels3111 new-vars3112 r3098))) (build-letrec2086 s3100 (map syntax->datum ids3109) new-vars3112 (map (lambda (x3115) (chi2140 x3115 r3114 w3113 mod3101)) val3106) (chi-body2144 (cons e13107 e23108) (source-wrap2133 e3097 w3113 s3100 mod3101) r3114 w3113 mod3101))))))) tmp3103) ((lambda (_3118) (syntax-violation (quote letrec) "bad letrec" (source-wrap2133 e3097 w3099 s3100 mod3101))) tmp3102))) ($sc-dispatch tmp3102 (quote (any #(each (any any)) any . each-any))))) e3097))) (global-extend2102 (quote core) (quote set!) (lambda (e3119 r3120 w3121 s3122 mod3123) ((lambda (tmp3124) ((lambda (tmp3125) (if (if tmp3125 (apply (lambda (_3126 id3127 val3128) (id?2104 id3127)) tmp3125) #f) (apply (lambda (_3129 id3130 val3131) (let ((val3132 (chi2140 val3131 r3120 w3121 mod3123)) (n3133 (id-var-name2126 id3130 w3121))) (let ((b3134 (lookup2101 n3133 r3120 mod3123))) (let ((atom-key3135 (binding-type2096 b3134))) (if (memv atom-key3135 (quote (lexical))) (build-lexical-assignment2075 s3122 (syntax->datum id3130) (binding-value2097 b3134) val3132) (if (memv atom-key3135 (quote (global))) (build-global-assignment2078 s3122 n3133 val3132 mod3123) (if (memv atom-key3135 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap2132 id3130 w3121 mod3123)) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))))))))) tmp3125) ((lambda (tmp3136) (if tmp3136 (apply (lambda (_3137 head3138 tail3139 val3140) (call-with-values (lambda () (syntax-type2138 head3138 r3120 (quote (())) #f #f mod3123)) (lambda (type3141 value3142 ee3143 ww3144 ss3145 modmod3146) (if (memv type3141 (quote (module-ref))) (let ((val3147 (chi2140 val3140 r3120 w3121 mod3123))) (call-with-values (lambda () (value3142 (cons head3138 tail3139))) (lambda (id3149 mod3150) (build-global-assignment2078 s3122 id3149 val3147 mod3150)))) (build-application2072 s3122 (chi2140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail 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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head3138) r3120 w3121 mod3123) (map (lambda (e3151) (chi2140 e3151 r3120 w3121 mod3123)) (append tail3139 (list val3140)))))))) tmp3136) ((lambda (_3153) (syntax-violation (quote set!) "bad set!" (source-wrap2133 e3119 w3121 s3122 mod3123))) tmp3124))) ($sc-dispatch tmp3124 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp3124 (quote (any any any))))) e3119))) (global-extend2102 (quote module-ref) (quote @) (lambda (e3154) ((lambda (tmp3155) ((lambda (tmp3156) (if (if tmp3156 (apply (lambda (_3157 mod3158 id3159) (if (and-map id?2104 mod3158) (id?2104 id3159) #f)) tmp3156) #f) (apply (lambda (_3161 mod3162 id3163) (values (syntax->datum id3163) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3162)))) tmp3156) (syntax-violation #f "source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any each-any any))))) e3154))) (global-extend2102 (quote module-ref) (quote @@) (lambda (e3165) ((lambda (tmp3166) ((lambda (tmp3167) (if (if tmp3167 (apply (lambda (_3168 mod3169 id3170) (if (and-map id?2104 mod3169) (id?2104 id3170) #f)) tmp3167) #f) (apply (lambda (_3172 mod3173 id3174) (values (syntax->datum id3174) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod3173)))) tmp3167) (syntax-violation #f "source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any each-any any))))) e3165))) (global-extend2102 (quote core) (quote if) (lambda (e3176 r3177 w3178 s3179 mod3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 test3184 then3185) (build-conditional2073 s3179 (chi2140 test3184 r3177 w3178 mod3180) (chi2140 then3185 r3177 w3178 mod3180) (build-void2071 #f))) tmp3182) ((lambda (tmp3186) (if tmp3186 (apply (lambda (_3187 test3188 then3189 else3190) (build-conditional2073 s3179 (chi2140 test3188 r3177 w3178 mod3180) (chi2140 then3189 r3177 w3178 mod3180) (chi2140 else3190 r3177 w3178 mod3180))) tmp3186) (syntax-violation #f "source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any any any)))))) ($sc-dispatch tmp3181 (quote (any any any))))) e3176))) (global-extend2102 (quote begin) (quote begin) (quote ())) (global-extend2102 (quote define) (quote define) (quote ())) (global-extend2102 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend2102 (quote eval-when) (quote eval-when) (quote ())) (global-extend2102 (quote core) (quote syntax-case) (letrec ((gen-syntax-case3194 (lambda (x3195 keys3196 clauses3197 r3198 mod3199) (if (null? clauses3197) (build-application2072 #f (build-primref2081 #f (quote syntax-violation)) (list #f "source expression failed to match any pattern" x3195)) ((lambda (tmp3200) ((lambda (tmp3201) (if tmp3201 (apply (lambda (pat3202 exp3203) (if (if (id?2104 pat3202) (and-map (lambda (x3204) (not (free-id=?2127 pat3202 x3204))) (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 analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* 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) (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" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys3196)) #f) (let ((labels3205 (list (gen-label2109))) (var3206 (gen-var2152 pat3202))) (build-application2072 #f (build-lambda2080 #f (list (syntax->datum pat3202)) (list var3206) #f (chi2140 exp3203 (extend-env2098 labels3205 (list (cons (quote syntax) (cons var3206 0))) r3198) (make-binding-wrap2121 (list pat3202) labels3205 (quote (()))) mod3199)) (list x3195))) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3202 #t exp3203 mod3199))) tmp3201) ((lambda (tmp3207) (if tmp3207 (apply (lambda (pat3208 fender3209 exp3210) (gen-clause3193 x3195 keys3196 (cdr clauses3197) r3198 pat3208 fender3209 exp3210 mod3199)) tmp3207) ((lambda (_3211) (syntax-violation (quote syntax-case) "invalid clause" (car clauses3197))) tmp3200))) ($sc-dispatch tmp3200 (quote (any any any)))))) ($sc-dispatch tmp3200 (quote (any any))))) (car clauses3197))))) (gen-clause3193 (lambda (x3212 keys3213 clauses3214 r3215 pat3216 fender3217 exp3218 mod3219) (call-with-values (lambda () (convert-pattern3191 pat3216 keys3213)) (lambda (p3220 pvars3221) (if (not (distinct-bound-ids?2130 (map car pvars3221))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat3216) (if (not (and-map (lambda (x3222) (not (ellipsis?2149 (car x3222)))) pvars3221)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat3216) (let ((y3223 (gen-var2152 (quote tmp)))) (build-application2072 #f (build-lambda2080 #f (list (quote tmp)) (list y3223) #f (let ((y3224 (build-lexical-reference2074 (quote value) #f (quote tmp) y3223))) (build-conditional2073 #f ((lambda (tmp3225) ((lambda (tmp3226) (if tmp3226 (apply (lambda () y3224) tmp3226) ((lambda (_3227) (build-conditional2073 #f y3224 (build-dispatch-call3192 pvars3221 fender3217 y3224 r3215 mod3219) (build-data2082 #f #f))) tmp3225))) ($sc-dispatch tmp3225 (quote #(atom #t))))) fender3217) (build-dispatch-call3192 pvars3221 exp3218 y3224 r3215 mod3219) (gen-syntax-case3194 x3212 keys3213 clauses3214 r3215 mod3219)))) (list (if (eq? p3220 (quote any)) (build-application2072 #f (build-primref2081 #f (quote list)) (list x3212)) (build-application2072 #f (build-primref2081 #f (quote $sc-dispatch)) (list x3212 (build-data2082 #f p3220))))))))))))) (build-dispatch-call3192 (lambda (pvars3228 exp3229 y3230 r3231 mod3232) (let ((ids3233 (map car pvars3228)) (levels3234 (map cdr pvars3228))) (let ((labels3235 (gen-labels2110 ids3233)) (new-vars3236 (map gen-var2152 ids3233))) (build-application2072 #f (build-primref2081 #f (quote apply)) (list (build-lambda2080 #f (map syntax->datum ids3233) new-vars3236 #f (chi2140 exp3229 (extend-env2098 labels3235 (map (lambda (var3237 level3238) (cons (quote syntax) (cons var3237 level3238))) new-vars3236 (map cdr pvars3228)) r3231) (make-binding-wrap2121 ids3233 labels3235 (quote (()))) mod3232)) y3230)))))) (convert-pattern3191 (lambda (pattern3239 keys3240) (letrec ((cvt3241 (lambda (p3242 n3243 ids3244) (if (id?2104 p3242) (if (bound-id-member?2131 p3242 keys3240) (values (vector (quote free-id) p3242) ids3244) (values (quote any) (cons (cons p3242 n3243) ids3244))) ((lambda (tmp3245) ((lambda (tmp3246) (if (if tmp3246 (apply (lambda (x3247 dots3248) (ellipsis?2149 dots3248)) tmp3246) #f) (apply (lambda (x3249 dots3250) (call-with-values (lambda () (cvt3241 x3249 (fx+2063 n3243 1) ids3244)) (lambda (p3251 ids3252) (values (if (eq? p3251 (quote any)) (quote each-any) (vector (quote each) p3251)) ids3252)))) tmp3246) ((lambda (tmp3253) (if tmp3253 (apply (lambda (x3254 y3255) (call-with-values (lambda () (cvt3241 y3255 n3243 ids3244)) (lambda (y3256 ids3257) (call-with-values (lambda () (cvt3241 x3254 n3243 ids3257)) (lambda (x3258 ids3259) (values (cons x3258 y3256) ids3259)))))) tmp3253) ((lambda (tmp3260) (if tmp3260 (apply (lambda () (values (quote ()) ids3244)) tmp3260) ((lambda (tmp3261) (if tmp3261 (apply (lambda (x3262) (call-with-values (lambda () (cvt3241 x3262 n3243 ids3244)) (lambda (p3264 ids3265) (values (vector (quote vector) p3264) ids3265)))) tmp3261) ((lambda (x3266) (values (vector (quote atom) (strip2151 p3242 (quote (())))) ids3244)) tmp3245))) ($sc-dispatch tmp3245 (quote #(vector each-any)))))) ($sc-dispatch tmp3245 (quote ()))))) ($sc-dispatch tmp3245 (quote (any . any)))))) ($sc-dispatch tmp3245 (quote (any any))))) p3242))))) (cvt3241 pattern3239 0 (quote ())))))) (lambda (e3267 r3268 w3269 s3270 mod3271) (let ((e3272 (source-wrap2133 e3267 w3269 s3270 mod3271))) ((lambda (tmp3273) ((lambda (tmp3274) (if tmp3274 (apply (lambda (_3275 val3276 key3277 m3278) (if (and-map (lambda (x3279) (if (id?2104 x3279) (not (ellipsis?2149 x3279)) #f)) key3277) (let ((x3281 (gen-var2152 (quote tmp)))) (build-application2072 s3270 (build-lambda2080 #f (list (quote tmp)) (list x3281) #f (gen-syntax-case3194 (build-lexical-reference2074 (quote value) #f (quote tmp) x3281) key3277 m3278 r3268 mod3271)) (list (chi2140 val3276 r3268 (quote (())) mod3271)))) (syntax-violation (quote syntax-case) "invalid literals list" e3272))) tmp3274) (syntax-violation #f "source expression failed to match any pattern" tmp3273))) ($sc-dispatch tmp3273 (quote (any any each-any . each-any))))) e3272))))) (set! sc-expand (lambda (x3285 . rest3284) (if (if (pair? x3285) (equal? (car x3285) noexpand2061) #f) (cadr x3285) (let ((m3286 (if (null? rest3284) (quote e) (car rest3284))) (esew3287 (if (let ((t3288 (null? rest3284))) (if t3288 t3288 (null? (cdr rest3284)))) (quote (eval)) (cadr rest3284)))) (with-fluid* *mode*2062 m3286 (lambda () (chi-top2139 x3285 (quote ()) (quote ((top))) m3286 esew3287 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x3289) (nonsymbol-id?2103 x3289))) (set! datum->syntax (lambda (id3290 datum3291) (make-syntax-object2087 datum3291 (syntax-object-wrap2090 id3290) #f))) (set! syntax->datum (lambda (x3292) (strip2151 x3292 (quote (()))))) (set! generate-temporaries (lambda (ls3293) (begin (let ((x3294 ls3293)) (if (not (list? x3294)) (syntax-violation (quote generate-temporaries) "invalid argument" x3294) (if #f #f))) (map (lambda (x3295) (wrap2132 (gensym) (quote ((top))) #f)) ls3293)))) (set! free-identifier=? (lambda (x3296 y3297) (begin (let ((x3298 x3296)) (if (not (nonsymbol-id?2103 x3298)) (syntax-violation (quote free-identifier=?) "invalid argument" x3298) (if #f #f))) (let ((x3299 y3297)) (if (not (nonsymbol-id?2103 x3299)) (syntax-violation (quote free-identifier=?) "invalid argument" x3299) (if #f #f))) (free-id=?2127 x3296 y3297)))) (set! bound-identifier=? (lambda (x3300 y3301) (begin (let ((x3302 x3300)) (if (not (nonsymbol-id?2103 x3302)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3302) (if #f #f))) (let ((x3303 y3301)) (if (not (nonsymbol-id?2103 x3303)) (syntax-violation (quote bound-identifier=?) "invalid argument" x3303) (if #f #f))) (bound-id=?2128 x3300 y3301)))) (set! syntax-violation (lambda (who3307 message3306 form3305 . subform3304) (begin (let ((x3308 who3307)) (if (not ((lambda (x3309) (let ((t3310 (not x3309))) (if t3310 t3310 (let ((t3311 (string? x3309))) (if t3311 t3311 (symbol? x3309)))))) x3308)) (syntax-violation (quote syntax-violation) "invalid argument" x3308) (if #f #f))) (let ((x3312 message3306)) (if (not (string? x3312)) (syntax-violation (quote syntax-violation) "invalid argument" x3312) (if #f #f))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who3307 "~a: " "") "~a " (if (null? subform3304) "in ~a" "in subform `~s' of `~s'")) (let ((tail3313 (cons message3306 (map (lambda (x3314) (strip2151 x3314 (quote (())))) (append subform3304 (list form3305)))))) (if who3307 (cons who3307 tail3313) tail3313)) #f)))) (letrec ((match3319 (lambda (e3320 p3321 w3322 r3323 mod3324) (if (not r3323) #f (if (eq? p3321 (quote any)) (cons (wrap2132 e3320 w3322 mod3324) r3323) (if (syntax-object?2088 e3320) (match*3318 (let ((e3325 (syntax-object-expression2089 e3320))) (if (annotation? e3325) (annotation-expression e3325) e3325)) p3321 (join-wraps2123 w3322 (syntax-object-wrap2090 e3320)) r3323 (syntax-object-module2091 e3320)) (match*3318 (let ((e3326 e3320)) (if (annotation? e3326) (annotation-expression e3326) e3326)) p3321 w3322 r3323 mod3324)))))) (match*3318 (lambda (e3327 p3328 w3329 r3330 mod3331) (if (null? p3328) (if (null? e3327) r3330 #f) (if (pair? p3328) (if (pair? e3327) (match3319 (car e3327) (car p3328) w3329 (match3319 (cdr e3327) (cdr p3328) w3329 r3330 mod3331) mod3331) #f) (if (eq? p3328 (quote each-any)) (let ((l3332 (match-each-any3316 e3327 w3329 mod3331))) (if l3332 (cons l3332 r3330) #f)) (let ((atom-key3333 (vector-ref p3328 0))) (if (memv atom-key3333 (quote (each))) (if (null? e3327) (match-empty3317 (vector-ref p3328 1) r3330) (let ((l3334 (match-each3315 e3327 (vector-ref p3328 1) w3329 mod3331))) (if l3334 (letrec ((collect3335 (lambda (l3336) (if (null? (car l3336)) r3330 (cons (map car l3336) (collect3335 (map cdr l3336))))))) (collect3335 l3334)) #f))) (if (memv atom-key3333 (quote (free-id))) (if (id?2104 e3327) (if (free-id=?2127 (wrap2132 e3327 w3329 mod3331) (vector-ref p3328 1)) r3330 #f) #f) (if (memv atom-key3333 (quote (atom))) (if (equal? (vector-ref p3328 1) (strip2151 e3327 w3329)) r3330 #f) (if (memv atom-key3333 (quote (vector))) (if (vector? e3327) (match3319 (vector->list e3327) (vector-ref p3328 1) w3329 r3330 mod3331) #f) (if #f #f))))))))))) (match-empty3317 (lambda (p3337 r3338) (if (null? p3337) r3338 (if (eq? p3337 (quote any)) (cons (quote ()) r3338) (if (pair? p3337) (match-empty3317 (car p3337) (match-empty3317 (cdr p3337) r3338)) (if (eq? p3337 (quote each-any)) (cons (quote ()) r3338) (let ((atom-key3339 (vector-ref p3337 0))) (if (memv atom-key3339 (quote (each))) (match-empty3317 (vector-ref p3337 1) r3338) (if (memv atom-key3339 (quote (free-id atom))) r3338 (if (memv atom-key3339 (quote (vector))) (match-empty3317 (vector-ref p3337 1) r3338) (if #f #f))))))))))) (match-each-any3316 (lambda (e3340 w3341 mod3342) (if (annotation? e3340) (match-each-any3316 (annotation-expression e3340) w3341 mod3342) (if (pair? e3340) (let ((l3343 (match-each-any3316 (cdr e3340) w3341 mod3342))) (if l3343 (cons (wrap2132 (car e3340) w3341 mod3342) l3343) #f)) (if (null? e3340) (quote ()) (if (syntax-object?2088 e3340) (match-each-any3316 (syntax-object-expression2089 e3340) (join-wraps2123 w3341 (syntax-object-wrap2090 e3340)) mod3342) #f)))))) (match-each3315 (lambda (e3344 p3345 w3346 mod3347) (if (annotation? e3344) (match-each3315 (annotation-expression e3344) p3345 w3346 mod3347) (if (pair? e3344) (let ((first3348 (match3319 (car e3344) p3345 w3346 (quote ()) mod3347))) (if first3348 (let ((rest3349 (match-each3315 (cdr e3344) p3345 w3346 mod3347))) (if rest3349 (cons first3348 rest3349) #f)) #f)) (if (null? e3344) (quote ()) (if (syntax-object?2088 e3344) (match-each3315 (syntax-object-expression2089 e3344) p3345 (join-wraps2123 w3346 (syntax-object-wrap2090 e3344)) (syntax-object-module2091 e3344)) #f))))))) (set! $sc-dispatch (lambda (e3350 p3351) (if (eq? p3351 (quote any)) (list e3350) (if (syntax-object?2088 e3350) (match*3318 (let ((e3352 (syntax-object-expression2089 e3350))) (if (annotation? e3352) (annotation-expression e3352) e3352)) p3351 (syntax-object-wrap2090 e3350) (quote ()) (syntax-object-module2091 e3350)) (match*3318 (let ((e3353 e3350)) (if (annotation? e3353) (annotation-expression e3353) e3353)) p3351 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x3354) ((lambda (tmp3355) ((lambda (tmp3356) (if tmp3356 (apply (lambda (_3357 e13358 e23359) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13358 e23359))) tmp3356) ((lambda (tmp3361) (if tmp3361 (apply (lambda (_3362 out3363 in3364 e13365 e23366) (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"))) (hygiene guile))) in3364 (quote ()) (list out3363 (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"))) (hygiene guile))) (cons e13365 e23366))))) tmp3361) ((lambda (tmp3368) (if tmp3368 (apply (lambda (_3369 out3370 in3371 e13372 e23373) (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"))) (hygiene guile))) (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"))) (hygiene guile))) in3371) (quote ()) (list out3370 (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"))) (hygiene guile))) (cons e13372 e23373))))) tmp3368) (syntax-violation #f "source expression failed to match any pattern" tmp3355))) ($sc-dispatch tmp3355 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3355 (quote (any () any . each-any))))) x3354)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x3377) ((lambda (tmp3378) ((lambda (tmp3379) (if tmp3379 (apply (lambda (_3380 k3381 keyword3382 pattern3383 template3384) (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"))) (hygiene guile))) (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"))) (hygiene guile)))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (cons k3381 (map (lambda (tmp3387 tmp3386) (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"))) (hygiene guile))) tmp3386) (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"))) (hygiene guile))) tmp3387))) template3384 pattern3383)))))) tmp3379) (syntax-violation #f "source expression failed to match any pattern" tmp3378))) ($sc-dispatch tmp3378 (quote (any each-any . #(each ((any . any) any))))))) x3377)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3388) ((lambda (tmp3389) ((lambda (tmp3390) (if (if tmp3390 (apply (lambda (let*3391 x3392 v3393 e13394 e23395) (and-map identifier? x3392)) tmp3390) #f) (apply (lambda (let*3397 x3398 v3399 e13400 e23401) (letrec ((f3402 (lambda (bindings3403) (if (null? bindings3403) (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"))) (hygiene guile))) (cons (quote ()) (cons e13400 e23401))) ((lambda (tmp3407) ((lambda (tmp3408) (if tmp3408 (apply (lambda (body3409 binding3410) (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"))) (hygiene guile))) (list binding3410) body3409)) tmp3408) (syntax-violation #f "source expression failed to match any pattern" tmp3407))) ($sc-dispatch tmp3407 (quote (any any))))) (list (f3402 (cdr bindings3403)) (car bindings3403))))))) (f3402 (map list x3398 v3399)))) tmp3390) (syntax-violation #f "source expression failed to match any pattern" tmp3389))) ($sc-dispatch tmp3389 (quote (any #(each (any any)) any . each-any))))) x3388)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x3411) ((lambda (tmp3412) ((lambda (tmp3413) (if tmp3413 (apply (lambda (_3414 var3415 init3416 step3417 e03418 e13419 c3420) ((lambda (tmp3421) ((lambda (tmp3422) (if tmp3422 (apply (lambda (step3423) ((lambda (tmp3424) ((lambda (tmp3425) (if tmp3425 (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var3415 init3416) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e03418) (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"))) (hygiene guile))) (append c3420 (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"))) (hygiene guile))) step3423))))))) tmp3425) ((lambda (tmp3430) (if tmp3430 (apply (lambda (e13431 e23432) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (map list var3415 init3416) (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"))) (hygiene guile))) e03418 (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"))) (hygiene guile))) (cons e13431 e23432)) (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"))) (hygiene guile))) (append c3420 (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"))) (hygiene guile))) step3423))))))) tmp3430) (syntax-violation #f "source expression failed to match any pattern" tmp3424))) ($sc-dispatch tmp3424 (quote (any . each-any)))))) ($sc-dispatch tmp3424 (quote ())))) e13419)) tmp3422) (syntax-violation #f "source expression failed to match any pattern" tmp3421))) ($sc-dispatch tmp3421 (quote each-any)))) (map (lambda (v3439 s3440) ((lambda (tmp3441) ((lambda (tmp3442) (if tmp3442 (apply (lambda () v3439) tmp3442) ((lambda (tmp3443) (if tmp3443 (apply (lambda (e3444) e3444) tmp3443) ((lambda (_3445) (syntax-violation (quote do) "bad step expression" orig-x3411 s3440)) tmp3441))) ($sc-dispatch tmp3441 (quote (any)))))) ($sc-dispatch tmp3441 (quote ())))) s3440)) var3415 step3417))) tmp3413) (syntax-violation #f "source expression failed to match any pattern" tmp3412))) ($sc-dispatch tmp3412 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x3411)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons3448 (lambda (x3452 y3453) ((lambda (tmp3454) ((lambda (tmp3455) (if tmp3455 (apply (lambda (x3456 y3457) ((lambda (tmp3458) ((lambda (tmp3459) (if tmp3459 (apply (lambda (dy3460) ((lambda (tmp3461) ((lambda (tmp3462) (if tmp3462 (apply (lambda (dx3463) (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"))) (hygiene guile))) (cons dx3463 dy3460))) tmp3462) ((lambda (_3464) (if (null? dy3460) (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"))) (hygiene guile))) x3456) (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"))) (hygiene guile))) x3456 y3457))) tmp3461))) ($sc-dispatch tmp3461 (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"))) (hygiene guile))) any))))) x3456)) tmp3459) ((lambda (tmp3465) (if tmp3465 (apply (lambda (stuff3466) (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"))) (hygiene guile))) (cons x3456 stuff3466))) tmp3465) ((lambda (else3467) (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"))) (hygiene guile))) x3456 y3457)) tmp3458))) ($sc-dispatch tmp3458 (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"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp3458 (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"))) (hygiene guile))) any))))) y3457)) tmp3455) (syntax-violation #f "source expression failed to match any pattern" tmp3454))) ($sc-dispatch tmp3454 (quote (any any))))) (list x3452 y3453)))) (quasiappend3449 (lambda (x3468 y3469) ((lambda (tmp3470) ((lambda (tmp3471) (if tmp3471 (apply (lambda (x3472 y3473) ((lambda (tmp3474) ((lambda (tmp3475) (if tmp3475 (apply (lambda () x3472) tmp3475) ((lambda (_3476) (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"))) (hygiene guile))) x3472 y3473)) tmp3474))) ($sc-dispatch tmp3474 (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"))) (hygiene guile))) ()))))) y3473)) tmp3471) (syntax-violation #f "source expression failed to match any pattern" tmp3470))) ($sc-dispatch tmp3470 (quote (any any))))) (list x3468 y3469)))) (quasivector3450 (lambda (x3477) ((lambda (tmp3478) ((lambda (x3479) ((lambda (tmp3480) ((lambda (tmp3481) (if tmp3481 (apply (lambda (x3482) (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"))) (hygiene guile))) (list->vector x3482))) tmp3481) ((lambda (tmp3484) (if tmp3484 (apply (lambda (x3485) (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"))) (hygiene guile))) x3485)) tmp3484) ((lambda (_3487) (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"))) (hygiene guile))) x3479)) tmp3480))) ($sc-dispatch tmp3480 (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"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp3480 (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"))) (hygiene guile))) each-any))))) x3479)) tmp3478)) x3477))) (quasi3451 (lambda (p3488 lev3489) ((lambda (tmp3490) ((lambda (tmp3491) (if tmp3491 (apply (lambda (p3492) (if (= lev3489 0) p3492 (quasicons3448 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi3451 (list p3492) (- lev3489 1))))) tmp3491) ((lambda (tmp3493) (if tmp3493 (apply (lambda (p3494 q3495) (if (= lev3489 0) (quasiappend3449 p3494 (quasi3451 q3495 lev3489)) (quasicons3448 (quasicons3448 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi3451 (list p3494) (- lev3489 1))) (quasi3451 q3495 lev3489)))) tmp3493) ((lambda (tmp3496) (if tmp3496 (apply (lambda (p3497) (quasicons3448 (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"))) (hygiene guile)) #(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"))) (hygiene guile)))) (quasi3451 (list p3497) (+ lev3489 1)))) tmp3496) ((lambda (tmp3498) (if tmp3498 (apply (lambda (p3499 q3500) (quasicons3448 (quasi3451 p3499 lev3489) (quasi3451 q3500 lev3489))) tmp3498) ((lambda (tmp3501) (if tmp3501 (apply (lambda (x3502) (quasivector3450 (quasi3451 x3502 lev3489))) tmp3501) ((lambda (p3504) (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"))) (hygiene guile))) p3504)) tmp3490))) ($sc-dispatch tmp3490 (quote #(vector each-any)))))) ($sc-dispatch tmp3490 (quote (any . any)))))) ($sc-dispatch tmp3490 (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"))) (hygiene guile))) any)))))) ($sc-dispatch tmp3490 (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"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp3490 (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"))) (hygiene guile))) any))))) p3488)))) (lambda (x3505) ((lambda (tmp3506) ((lambda (tmp3507) (if tmp3507 (apply (lambda (_3508 e3509) (quasi3451 e3509 0)) tmp3507) (syntax-violation #f "source expression failed to match any pattern" tmp3506))) ($sc-dispatch tmp3506 (quote (any any))))) x3505))))) +(define include (make-syncase-macro (quote macro) (lambda (x3510) (letrec ((read-file3511 (lambda (fn3512 k3513) (let ((p3514 (open-input-file fn3512))) (letrec ((f3515 (lambda (x3516) (if (eof-object? x3516) (begin (close-input-port p3514) (quote ())) (cons (datum->syntax k3513 x3516) (f3515 (read p3514))))))) (f3515 (read p3514))))))) ((lambda (tmp3517) ((lambda (tmp3518) (if tmp3518 (apply (lambda (k3519 filename3520) (let ((fn3521 (syntax->datum filename3520))) ((lambda (tmp3522) ((lambda (tmp3523) (if tmp3523 (apply (lambda (exp3524) (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"))) (hygiene guile))) exp3524)) tmp3523) (syntax-violation #f "source expression failed to match any pattern" tmp3522))) ($sc-dispatch tmp3522 (quote each-any)))) (read-file3511 fn3521 k3519)))) tmp3518) (syntax-violation #f "source expression failed to match any pattern" tmp3517))) ($sc-dispatch tmp3517 (quote (any any))))) x3510))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x3526) ((lambda (tmp3527) ((lambda (tmp3528) (if tmp3528 (apply (lambda (_3529 e3530) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x3526)) tmp3528) (syntax-violation #f "source expression failed to match any pattern" tmp3527))) ($sc-dispatch tmp3527 (quote (any any))))) x3526)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x3531) ((lambda (tmp3532) ((lambda (tmp3533) (if tmp3533 (apply (lambda (_3534 e3535) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x3531)) tmp3533) (syntax-violation #f "source expression failed to match any pattern" tmp3532))) ($sc-dispatch tmp3532 (quote (any any))))) x3531)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x3536) ((lambda (tmp3537) ((lambda (tmp3538) (if tmp3538 (apply (lambda (_3539 e3540 m13541 m23542) ((lambda (tmp3543) ((lambda (body3544) (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"))) (hygiene guile))) (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"))) (hygiene guile))) e3540)) body3544)) tmp3543)) (letrec ((f3545 (lambda (clause3546 clauses3547) (if (null? clauses3547) ((lambda (tmp3549) ((lambda (tmp3550) (if tmp3550 (apply (lambda (e13551 e23552) (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"))) (hygiene guile))) (cons e13551 e23552))) tmp3550) ((lambda (tmp3554) (if tmp3554 (apply (lambda (k3555 e13556 e23557) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k3555)) (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"))) (hygiene guile))) (cons e13556 e23557)))) tmp3554) ((lambda (_3560) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3549))) ($sc-dispatch tmp3549 (quote (each-any any . each-any)))))) ($sc-dispatch tmp3549 (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"))) (hygiene guile))) any . each-any))))) clause3546) ((lambda (tmp3561) ((lambda (rest3562) ((lambda (tmp3563) ((lambda (tmp3564) (if tmp3564 (apply (lambda (k3565 e13566 e23567) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) (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"))) (hygiene guile))) k3565)) (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"))) (hygiene guile))) (cons e13566 e23567)) rest3562)) tmp3564) ((lambda (_3570) (syntax-violation (quote case) "bad clause" x3536 clause3546)) tmp3563))) ($sc-dispatch tmp3563 (quote (each-any any . each-any))))) clause3546)) tmp3561)) (f3545 (car clauses3547) (cdr clauses3547))))))) (f3545 m13541 m23542)))) tmp3538) (syntax-violation #f "source expression failed to match any pattern" tmp3537))) ($sc-dispatch tmp3537 (quote (any any any . each-any))))) x3536)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x3571) ((lambda (tmp3572) ((lambda (tmp3573) (if tmp3573 (apply (lambda (_3574 e3575) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e3575)) (list (cons _3574 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e3575 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp3573) (syntax-violation #f "source expression failed to match any pattern" tmp3572))) ($sc-dispatch tmp3572 (quote (any any))))) x3571)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index fd7ad5906..1ad1ba60e 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -351,6 +351,12 @@ ;;; output constructors +(define build-void + (lambda (source) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-void) source)) + (else '(if #f #f))))) + (define build-application (lambda (source fun-exp arg-exps) (case (fluid-ref *mode*) @@ -444,10 +450,13 @@ (define build-primref (lambda (src name) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-primitive-ref) src name)) - ;; hygiene guile is a hack - (else (build-global-reference src name '(hygiene guile)))))) + (if (equal? (module-name (current-module)) '(guile)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) src name)) + (else name)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f)) + (else `(@@ (guile) ,name)))))) (define (build-data src exp) (case (fluid-ref *mode*) @@ -1483,7 +1492,7 @@ (define chi-void (lambda () - (build-application no-source (build-primref no-source 'if) '(#f #f)))) + (build-void no-source))) (define ellipsis? (lambda (x) @@ -1895,6 +1904,22 @@ (syntax->datum (syntax (private mod ...)))))))) +(global-extend 'core 'if + (lambda (e r w s mod) + (syntax-case e () + ((_ test then) + (build-conditional + s + (chi (syntax test) r w mod) + (chi (syntax then) r w mod) + (build-void no-source))) + ((_ test then else) + (build-conditional + s + (chi (syntax test) r w mod) + (chi (syntax then) r w mod) + (chi (syntax else) r w mod)))))) + (global-extend 'begin 'begin '()) (global-extend 'define 'define '()) diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm index 553a3fd43..4635abc8a 100644 --- a/module/language/scheme/compile-tree-il.scm +++ b/module/language/scheme/compile-tree-il.scm @@ -58,7 +58,7 @@ (save-module-excursion (lambda () (and=> (cenv-module e) set-current-module) - (let ((x (sc-expand x 'c '(compile load eval))) - (cenv (make-cenv (current-module) - (cenv-lexicals e) (cenv-externals e)))) + (let* ((x (sc-expand x 'c '(compile load eval))) + (cenv (make-cenv (current-module) + (cenv-lexicals e) (cenv-externals e)))) (values x cenv cenv))))) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 70085e8d7..e6b7d3bd3 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -47,8 +47,10 @@ #:version "0.5" #:reader read #:read-file read-file - #:compilers `((ghil . ,compile-ghil) - (tree-il . ,compile-tree-il)) + #:compilers `( + (tree-il . ,compile-tree-il) + (ghil . ,compile-ghil) + ) #:decompilers `((tree-il . ,decompile-tree-il)) #:evaluator (lambda (x module) (primitive-eval x)) #:printer write diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 1bd8d15d6..55ca102f0 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -144,7 +144,7 @@ (let lp ((vars vars) (n 0)) (if (null? vars) (hashq-set! allocation x - (let ((nlocs (allocate! body (1+ level) n))) + (let ((nlocs (- (allocate! body (1+ level) n) n))) (cons nlocs (1+ (hashq-ref heap-indexes x -1))))) (let ((v (if (pair? vars) (car vars) vars))) (let ((binder (hashq-ref heaps v))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index b617bd899..f69c91b86 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -39,13 +39,17 @@ ;; sym -> (local . index) | (heap level . index) ;; lambda -> (nlocs . nexts) +(define *comp-module* (make-fluid)) + (define (compile-glil x e opts) (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) (x (optimize! x e opts)) (allocation (analyze-lexicals x))) - (values (flatten-lambda x -1 allocation) - (and e (cons (car e) (cddr e))) - e))) + (with-fluid* *comp-module* (or (and e (car e)) (current-module)) + (lambda () + (values (flatten-lambda x -1 allocation) + (and e (cons (car e) (cddr e))) + e))))) @@ -128,11 +132,11 @@ ;; copy args to the heap if necessary (let lp ((in vars) (n 0)) (if (not (null? in)) - (let ((loc (hashq-ref allocation (car vars)))) + (let ((loc (hashq-ref allocation (car in)))) (case (car loc) ((heap) - (emit-code (make-glil-argument 'ref n)) - (emit-code (make-glil-external 'set 0 (cddr loc))))) + (emit-code #f (make-glil-local 'ref n)) + (emit-code #f (make-glil-external 'set 0 (cddr loc))))) (lp (cdr in) (1+ n))))) ;; and here, here, dear reader: we compile. @@ -197,11 +201,21 @@ (comp-push proc) (for-each comp-push args) (case context - ((drop) (emit-code src (make-glil-call 'apply (length args))) + ((drop) (emit-code src (make-glil-call 'apply (1+ (length args)))) (emit-code src (make-glil-call 'drop 1))) - ((tail) (emit-code src (make-glil-call 'goto/apply (length args)))) - ((push) (emit-code src (make-glil-call 'apply (length args))))))))) - + ((tail) (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) + ((push) (emit-code src (make-glil-call 'apply (1+ (length args)))))))))) + + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push))) + ;; tail: (lambda () (values '(1 2))) + ;; drop: (lambda () (values '(1 2)) 3) + ;; push: (lambda () (list (values '(10 12)) 1)) + (case context + ((drop) (for-each comp-drop args)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values (length args)))))) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-values) (= (length args) 2)) @@ -277,12 +291,23 @@ (emit-label L2)))) (( src name) - (case context - ((push) - (emit-code src (make-glil-module 'ref '(guile) name #f))) - ((tail) - (emit-code src (make-glil-module 'ref '(guile) name #f)) - (emit-code #f (make-glil-call 'return 1))))) + (cond + ((eq? (module-variable (fluid-ref *comp-module*) name) + (module-variable the-root-module name)) + (case context + ((push) + (emit-code src (make-glil-toplevel 'ref name))) + ((tail) + (emit-code src (make-glil-toplevel 'ref name)) + (emit-code #f (make-glil-call 'return 1))))) + (else + (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) + (case context + ((push) + (emit-code src (make-glil-module 'ref '(guile) name #f))) + ((tail) + (emit-code src (make-glil-module 'ref '(guile) name #f)) + (emit-code #f (make-glil-call 'return 1))))))) (( src name gensym) (case context diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index e4e4996fc..03193b256 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -78,7 +78,7 @@ (and (hashq-ref *interesting-primitive-vars* (module-variable mod name)) (make-primitive-ref src name))) - (( mod name public?) + (( src mod name public?) ;; for the moment, we're disabling primitive resolution for ;; public refs because resolve-interface can raise errors. (let ((m (and (not public?) (resolve-module mod)))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index a92ba923d..3150392ae 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -102,7 +102,7 @@ (with-test-prefix "primitive-ref" (assert-tree-il->glil (primitive +) - (program 0 0 0 0 () (module private ref (guile) +) (call return 1))) + (program 0 0 0 0 () (toplevel ref +) (call return 1))) (assert-tree-il->glil (begin (primitive +) (const #f)) @@ -110,7 +110,7 @@ (assert-tree-il->glil (apply (primitive null?) (primitive +)) - (program 0 0 0 0 () (module private ref (guile) +) (call null? 1) + (program 0 0 0 0 () (toplevel ref +) (call null? 1) (call return 1)))) (with-test-prefix "lexical refs" @@ -309,7 +309,7 @@ (assert-tree-il->glil (lambda (x) (y) () (const 2)) (program 0 0 0 0 () - (program 1 0 1 0 () + (program 1 0 0 0 () (bind (x local 0)) (const 2) (call return 1)) (call return 1))) @@ -317,7 +317,7 @@ (assert-tree-il->glil (lambda (x x1) (y y1) () (const 2)) (program 0 0 0 0 () - (program 2 0 2 0 () + (program 2 0 0 0 () (bind (x local 0) (x1 local 1)) (const 2) (call return 1)) (call return 1))) @@ -325,7 +325,7 @@ (assert-tree-il->glil (lambda x y () (const 2)) (program 0 0 0 0 () - (program 1 1 1 0 () + (program 1 1 0 0 () (bind (x local 0)) (const 2) (call return 1)) (call return 1))) @@ -333,7 +333,7 @@ (assert-tree-il->glil (lambda (x . x1) (y . y1) () (const 2)) (program 0 0 0 0 () - (program 2 1 2 0 () + (program 2 1 0 0 () (bind (x local 0) (x1 local 1)) (const 2) (call return 1)) (call return 1))) @@ -341,7 +341,7 @@ (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x y)) (program 0 0 0 0 () - (program 2 1 2 0 () + (program 2 1 0 0 () (bind (x local 0) (x1 local 1)) (local ref 0) (call return 1)) (call return 1))) @@ -349,9 +349,21 @@ (assert-tree-il->glil (lambda (x . x1) (y . y1) () (lexical x1 y1)) (program 0 0 0 0 () - (program 2 1 2 0 () + (program 2 1 0 0 () (bind (x local 0) (x1 local 1)) (local ref 1) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) + (program 0 0 0 0 () + (program 1 0 0 1 () + (bind (x external 0)) + (local ref 0) (external set 0 0) + (program 1 0 0 0 () + (bind (y local 0)) + (external ref 1 0) (call return 1)) + (call return 1)) (call return 1)))) (with-test-prefix "sequence" -- cgit v1.2.3 From 81fd3152992c8ef62e1ec036f5a39443c8f8d0aa Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 24 May 2009 13:09:01 +0200 Subject: update docs, clean up VM vestiges, macro docs, fix (/ a b c) * doc/ref/api-procedures.texi (Compiled Procedures): Fix for API changes. * doc/ref/compiler.texi (Compiling to the Virtual Machine): Replace GHIL docs with Tree-IL docs. Update the bits about the Scheme compiler to talk about Tree-IL and the expander instead of GHIL. Remove . Add placeholder sections for assembly and bytecode. * doc/ref/vm.texi: Update examples with what currently happens. Reword some things. Fix a couple errors. * libguile/vm-i-system.c (externals): Remove this instruction, it's not used. * module/ice-9/documentation.scm (object-documentation): If the object is a macro, try to return documentation on the macro transformer. * module/language/assembly/disassemble.scm (disassemble-load-program): Fix problem in which we skipped the first element of the object vector, because of changes to procedure layouts a few months ago. * module/language/scheme/spec.scm (read-file): Remove read-file definition. * module/language/tree-il.scm: Reorder exports. Remove , it was a compat shim to something that was never released. Fix `location'. * module/language/tree-il/primitives.scm (/): Fix expander for more than two args to /. * module/system/base/compile.scm (read-file-in): Remove unused definition. * module/system/base/language.scm (system): Remove language-read-file. * module/language/ecmascript/spec.scm (ecmascript): Remove read-file definition. --- doc/ref/api-procedures.texi | 28 +- doc/ref/compiler.texi | 579 ++++++++++++++----------------- doc/ref/vm.texi | 166 ++++----- libguile/vm-i-system.c | 6 - module/ice-9/documentation.scm | 2 + module/language/assembly/disassemble.scm | 2 +- module/language/ecmascript/spec.scm | 1 - module/language/scheme/spec.scm | 7 - module/language/tree-il.scm | 31 +- module/language/tree-il/primitives.scm | 2 +- module/system/base/compile.scm | 5 - module/system/base/language.scm | 3 +- 12 files changed, 347 insertions(+), 485 deletions(-) (limited to 'libguile') diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index e3cf25823..484f2e86f 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -162,18 +162,10 @@ appropriate module first, though: Returns @code{#t} iff @var{obj} is a compiled procedure. @end deffn -@deffn {Scheme Procedure} program-bytecode program -@deffnx {C Function} scm_program_bytecode (program) -Returns the object code associated with this program, as a -@code{u8vector}. -@end deffn - -@deffn {Scheme Procedure} program-base program -@deffnx {C Function} scm_program_base (program) -Returns the address in memory corresponding to the start of -@var{program}'s object code, as an integer. This is useful mostly when -you map the value of an instruction pointer from the VM to actual -instructions. +@deffn {Scheme Procedure} program-objcode program +@deffnx {C Function} scm_program_objcode (program) +Returns the object code associated with this program. @xref{Object +Code}, for more information. @end deffn @deffn {Scheme Procedure} program-objects program @@ -184,9 +176,9 @@ vector. @xref{VM Programs}, for more information. @deffn {Scheme Procedure} program-module program @deffnx {C Function} scm_program_module (program) -Returns the module that was current when this program was created. -Free variables in this program are looked up with respect to this -module. +Returns the module that was current when this program was created. Can +return @code{#f} if the compiler could determine that this information +was unnecessary. @end deffn @deffn {Scheme Procedure} program-external program @@ -250,9 +242,9 @@ REPL. The only tricky bit is that @var{extp} is a boolean, declaring whether the binding is heap-allocated or not. @xref{VM Concepts}, for more information. -Note that bindings information are stored in a program as part of its -metadata thunk, so including them in the generated object code does -not impose a runtime performance penalty. +Note that bindings information is stored in a program as part of its +metadata thunk, so including it in the generated object code does not +impose a runtime performance penalty. @end deffn @deffn {Scheme Procedure} program-sources program diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 27d8f79c8..e4a4f18d1 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -22,8 +22,10 @@ know how to compile your .scm file. @menu * Compiler Tower:: * The Scheme Compiler:: -* GHIL:: +* Tree-IL:: * GLIL:: +* Assembly:: +* Bytecode:: * Object Code:: * Extending the Compiler:: @end menu @@ -52,7 +54,7 @@ They are registered with the @code{define-language} form. @deffn {Scheme Syntax} define-language @ name title version reader printer @ -[parser=#f] [read-file=#f] [compilers='()] [evaluator=#f] +[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f] Define a language. This syntax defines a @code{#} object, bound to @var{name} @@ -62,17 +64,15 @@ for Scheme: @example (define-language scheme - #:title "Guile Scheme" - #:version "0.5" - #:reader read - #:read-file read-file - #:compilers `((,ghil . ,compile-ghil)) - #:evaluator (lambda (x module) (primitive-eval x)) - #:printer write) + #:title "Guile Scheme" + #:version "0.5" + #:reader read + #:compilers `((tree-il . ,compile-tree-il) + (ghil . ,compile-ghil)) + #:decompilers `((tree-il . ,decompile-tree-il)) + #:evaluator (lambda (x module) (primitive-eval x)) + #:printer write) @end example - -In this example, from @code{(language scheme spec)}, @code{read-file} -reads expressions from a port and wraps them in a @code{begin} block. @end deffn The interesting thing about having languages defined this way is that @@ -85,12 +85,12 @@ Guile Scheme interpreter 0.5 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -scheme@@(guile-user)> ,language ghil -Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0 +scheme@@(guile-user)> ,language tree-il +Tree Intermediate Language interpreter 1.0 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -ghil@@(guile-user)> +tree-il@@(guile-user)> @end example Languages can be looked up by name, as they were above. @@ -128,8 +128,10 @@ The normal tower of languages when compiling Scheme goes like this: @itemize @item Scheme, which we know and love -@item Guile High Intermediate Language (GHIL) +@item Tree Intermediate Language (Tree-IL) @item Guile Low Intermediate Language (GLIL) +@item Assembly +@item Bytecode @item Object code @end itemize @@ -137,8 +139,14 @@ Object code may be serialized to disk directly, though it has a cookie and version prepended to the front. But when compiling Scheme at run time, you want a Scheme value, e.g. a compiled procedure. For this reason, so as not to break the abstraction, Guile defines a fake -language, @code{value}. Compiling to @code{value} loads the object -code into a procedure, and wakes the sleeping giant. +language at the bottom of the tower: + +@itemize +@item Value +@end itemize + +Compiling to @code{value} loads the object code into a procedure, and +wakes the sleeping giant. Perhaps this strangeness can be explained by example: @code{compile-file} defaults to compiling to object code, because it @@ -156,340 +164,254 @@ different worlds indefinitely, as shown by the following quine: @node The Scheme Compiler @subsection The Scheme Compiler -The job of the Scheme compiler is to expand all macros and to resolve -all symbols to lexical variables. Its target language, GHIL, is fairly -close to Scheme itself, so this process is not very complicated. - -The Scheme compiler is driven by a table of @dfn{translators}, -declared with the @code{define-scheme-translator} form, defined in the -module, @code{(language scheme compile-ghil)}. - -@deffn {Scheme Syntax} define-scheme-translator head clause1 clause2... -The best documentation of this form is probably an example. Here is -the translator for @code{if}: - -@example -(define-scheme-translator if - ;; (if TEST THEN [ELSE]) - ((,test ,then) - (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin)))) - ((,test ,then ,else) - (make-ghil-if e l (retrans test) (retrans then) (retrans else)))) -@end example - -The match syntax is from the @code{pmatch} macro, defined in -@code{(system base pmatch)}. The result of a clause should be a valid -GHIL value. If no clause matches, a syntax error is signalled. - -In the body of the clauses, the following bindings are introduced: -@itemize -@item @code{e}, the current environment -@item @code{l}, the current source location (or @code{#f}) -@item @code{retrans}, a procedure that may be called to compile -subexpressions -@end itemize - -Note that translators are looked up by @emph{value}, not by name. That -is to say, the translator is keyed under the @emph{value} of -@code{if}, which normally prints as @code{#}. -@end deffn - -Users can extend the compiler by defining new translators. -Additionally, some forms can be inlined directly to -instructions -- @xref{Inlined Scheme Instructions}, for a list. The -actual inliners are defined in @code{(language scheme inline)}: - -@deffn {Scheme Syntax} define-inline head arity1 result1 arity2 result2... -Defines an inliner for @code{head}. As in -@code{define-scheme-translator}, inliners are keyed by value and not -by name. - -Expressions are matched on their arities. For example: - -@example -(define-inline eq? - (x y) (eq? x y)) -@end example - -This inlines calls to the Scheme procedure, @code{eq?}, to the -instruction @code{eq?}. - -A more complicated example would be: - -@example -(define-inline + - () 0 - (x) x - (x y) (add x y) - (x y . rest) (add x (+ y . rest))) -@end example -@end deffn - -Compilers take two arguments, an expression and an environment, and -return two values as well: an expression in the target language, and -an environment suitable for the target language. The format of the -environment is language-dependent. - -For Scheme, an environment may be one of three things: +The job of the Scheme compiler is to expand all macros and all of +Scheme to its most primitive expressions. The definition of +``primitive'' is given by the inventory of constructs provided by +Tree-IL, the target language of the Scheme compiler: procedure +applications, conditionals, lexical references, etc. This is described +more fully in the next section. + +The tricky and amusing thing about the Scheme-to-Tree-IL compiler is +that it is completely implemented by the macro expander. Since the +macro expander has to run over all of the source code already in order +to expand macros, it might as well do the analysis at the same time, +producing Tree-IL expressions directly. + +Because this compiler is actually the macro expander, it is +extensible. Any macro which the user writes becomes part of the +compiler. + +The Scheme-to-Tree-IL expander may be invoked using the generic +@code{compile} procedure: + +@lisp +(compile '(+ 1 2) #:from 'scheme #:to 'tree-il) +@result{} + #< src: #f + proc: #< src: #f name: +> + args: (#< src: #f exp: 1> + #< src: #f exp: 2>)> +@end lisp + +Or, since Tree-IL is so close to Scheme, it is often useful to expand +Scheme to Tree-IL, then translate back to Scheme. For that reason the +expander provides two interfaces. The former is equivalent to calling +@code{(sc-expand '(+ 1 2) 'c)}, where the @code{'c} is for +``compile''. With @code{'e} (the default), the result is translated +back to Scheme: + +@lisp +(sc-expand '(+ 1 2)) +@result{} (+ 1 2) +(sc-expand '(let ((x 10)) (* x x))) +@result{} (let ((x84 10)) (* x84 x84)) +@end lisp + +The second example shows that as part of its job, the macro expander +renames lexically-bound variables. The original names are preserved +when compiling to Tree-IL, but can't be represented in Scheme: a +lexical binding only has one name. It is for this reason that the +@emph{native} output of the expander is @emph{not} Scheme. There's too +much information we would lose if we translated to Scheme directly: +lexical variable names, source locations, and module hygiene. + +Note however that @code{sc-expand} does not have the same signature as +@code{compile-tree-il}. @code{compile-tree-il} is a small wrapper +around @code{sc-expand}, to make it conform to the general form of +compiler procedures in Guile's language tower. + +Compiler procedures take two arguments, an expression and an +environment. They return three values: the compiled expression, the +corresponding environment for the target language, and a +``continuation environment''. The compiled expression and environment +will serve as input to the next language's compiler. The +``continuation environment'' can be used to compile another expression +from the same source language within the same module. + +For example, you might compile the expression, @code{(define-module +(foo))}. This will result in a Tree-IL expression and environment. But +if you compiled a second expression, you would want to take into +account the compile-time effect of compiling the previous expression, +which puts the user in the @code{(foo)} module. That is purpose of the +``continuation environment''; you would pass it as the environment +when compiling the subsequent expression. + +For Scheme, an environment may be one of two things: @itemize @item @code{#f}, in which case compilation is performed in the context -of the current module; -@item a module, which specifies the context of the compilation; or -@item a @dfn{compile environment}, which specifies lexical variables -as well. +of the current module; or +@item a module, which specifies the context of the compilation. @end itemize -The format of a compile environment for scheme is @code{(@var{module} -@var{lexicals} . @var{externals})}, though users are strongly -discouraged from constructing these environments themselves. Instead, -if you need this functionality -- as in GOOPS' dynamic method compiler --- capture an environment with @code{compile-time-environment}, then -pass that environment to @code{compile}. - -@deffn {Scheme Procedure} compile-time-environment -A special function known to the compiler that, when compiled, will -return a representation of the lexical environment in place at compile -time. Useful for supporting some forms of dynamic compilation. Returns -@code{#f} if called from the interpreter. -@end deffn +@node Tree-IL +@subsection Tree-IL -@node GHIL -@subsection GHIL - -Guile High Intermediate Language (GHIL) is a structured intermediate +Tree Intermediate Language (Tree-IL) is a structured intermediate language that is close in expressive power to Scheme. It is an expanded, pre-analyzed Scheme. -GHIL is ``structured'' in the sense that its representation is based -on records, not S-expressions. This gives a rigidity to the language -that ensures that compiling to a lower-level language only requires a -limited set of transformations. Practically speaking, consider the -GHIL type, @code{}, which has fields named @code{env}, -@code{loc}, and @code{exp}. Instances of this type are records created -via @code{make-ghil-quote}, and whose fields are accessed as -@code{ghil-quote-env}, @code{ghil-quote-loc}, and -@code{ghil-quote-exp}. There is also a predicate, @code{ghil-quote?}. -@xref{Records}, for more information on records. - -Expressions of GHIL name their environments explicitly, and all -variables are referenced by identity in addition to by name. -@code{(language ghil)} defines a number of routines to deal explicitly -with variables and environments: - -@deftp {Scheme Variable} [table='()] -A toplevel environment. The @var{table} holds all toplevel variables -that have been resolved in this environment. -@end deftp -@deftp {Scheme Variable} parent [table='()] [variables='()] -A lexical environment. @var{parent} will be the enclosing lexical -environment, or a toplevel environment. @var{table} holds an alist -mapping symbols to variables bound in this environment, while -@var{variables} holds a cumulative list of all variables ever defined -in this environment. - -Lexical environments correspond to procedures. Bindings introduced -e.g. by Scheme's @code{let} add to the bindings in a lexical -environment. An example of a case in which a variable might be in -@var{variables} but not in @var{table} would be a variable that is in -the same procedure, but is out of scope. -@end deftp -@deftp {Scheme Variable} env name kind [index=#f] -A variable. @var{kind} is one of @code{argument}, @code{local}, -@code{external}, @code{toplevel}, @code{public}, or @code{private}; -see the procedures below for more information. @var{index} is used in -compilation. -@end deftp - -@deffn {Scheme Procedure} ghil-var-is-bound? env sym -Recursively look up a variable named @var{sym} in @var{env}, and -return it or @code{#f} if none is found. -@end deffn -@deffn {Scheme Procedure} ghil-var-for-ref! env sym -Recursively look up a variable named @var{sym} in @var{env}, and -return it. If the symbol was not bound, return a new toplevel -variable. -@end deffn -@deffn {Scheme Procedure} ghil-var-for-set! env sym -Like @code{ghil-var-for-ref!}, except that the returned variable will -be marked as @code{external}. @xref{Variables and the VM}. -@end deffn -@deffn {Scheme Procedure} ghil-var-define! toplevel-env sym -Return an existing or new toplevel variable named @var{sym}. -@var{toplevel-env} must be a toplevel environment. -@end deffn -@deffn {Scheme Procedure} ghil-var-at-module! env modname sym interface? -Return a variable that will be resolved at run-time with respect to a -specific module named @var{modname}. If @var{interface?} is true, the -variable will be of type @code{public}, otherwise @code{private}. -@end deffn -@deffn {Scheme Procedure} call-with-ghil-environment env syms func -Bind @var{syms} to fresh variables within a new lexical environment -whose parent is @var{env}, and call @var{func} as @code{(@var{func} -@var{new-env} @var{new-vars})}. -@end deffn -@deffn {Scheme Procedure} call-with-ghil-bindings env syms func -Like @code{call-with-ghil-environment}, except the existing -environment @var{env} is re-used. For that reason, @var{func} is -invoked as @code{(@var{func} @var{new-vars})} -@end deffn - -In the aforementioned @code{} type, the @var{env} slot -holds a pointer to the environment in which the expression occurs. The -@var{loc} slot holds source location information, so that errors -corresponding to this expression can be mapped back to the initial -expression in the higher-level language, e.g. Scheme. @xref{Compiled -Procedures}, for more information on source location objects. - -GHIL also has a declarative serialization format, which makes writing -and reading it a tractable problem for the human mind. Since all GHIL -language constructs contain @code{env} and @code{loc} pointers, they -are left out of the serialization. (Serializing @code{env} structures -would be difficult, as they are often circular.) What is left is the -type of expression, and the remaining slots defined in the expression -type. - -For example, an S-expression representation of the @code{} -expression would be: +Tree-IL is ``structured'' in the sense that its representation is +based on records, not S-expressions. This gives a rigidity to the +language that ensures that compiling to a lower-level language only +requires a limited set of transformations. Practically speaking, +consider the Tree-IL type, @code{}, which has two fields, +@code{src} and @code{exp}. Instances of this type are records created +via @code{make-const}, and whose fields are accessed as +@code{const-src}, and @code{const-exp}. There is also a predicate, +@code{const?}. @xref{Records}, for more information on records. + +@c alpha renaming + +All Tree-IL types have a @code{src} slot, which holds source location +information for the expression. This information, if present, will be +residualized into the compiled object code, allowing backtraces to +show source information. The format of @code{src} is the same as that +returned by Guile's @code{source-properties} function. @xref{Source +Properties}, for more information. + +Although Tree-IL objects are represented internally using records, +there is also an equivalent S-expression external representation for +each kind of Tree-IL. For example, an the S-expression representation +of @code{#} expression would be: @example -(quote 3) +(const 3) @end example -It's deceptively like Scheme. The general rule is, for a type defined -as @code{ env loc @var{slot1} @var{slot2}...}, the -S-expression representation will be @code{(@var{foo} @var{slot1} -@var{slot2}...)}. Users may program with this format directly at the -REPL: +Users may program with this format directly at the REPL: @example -scheme@@(guile-user)> ,language ghil -Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0 +scheme@@(guile-user)> ,language tree-il +Tree Intermediate Language interpreter 1.0 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -ghil@@(guile-user)> (call (ref +) (quote 32) (quote 10)) +tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10)) @result{} 42 @end example -For convenience, some slots are serialized as rest arguments; those -are noted below. The other caveat is that variables are serialized as -their names only, and not their identities. - -@deftp {Scheme Variable} env loc -The unspecified value. -@end deftp -@deftp {Scheme Variable} env loc exp -A quoted expression. - -Note that unlike in Scheme, there are no self-quoting expressions; all -constants must come from @code{quote} expressions. -@end deftp -@deftp {Scheme Variable} env loc exp -A quasiquoted expression. The expression is treated as a constant, -except for embedded @code{unquote} and @code{unquote-splicing} forms. -@end deftp -@deftp {Scheme Variable} env loc exp -Like Scheme's @code{unquote}; only valid within a quasiquote. -@end deftp -@deftp {Scheme Variable} env loc exp -Like Scheme's @code{unquote-splicing}; only valid within a quasiquote. -@end deftp -@deftp {Scheme Variable} env loc var -A variable reference. Note that for purposes of serialization, -@var{var} is serialized as its name, as a symbol. -@end deftp -@deftp {Scheme Variable} env loc var val -A variable mutation. @var{var} is serialized as a symbol. -@end deftp -@deftp {Scheme Variable} env loc var val -A toplevel variable definition. See @code{ghil-var-define!}. -@end deftp -@deftp {Scheme Variable} env loc test then else +The @code{src} fields are left out of the external representation. + +@deftp {Scheme Variable} src +@deftpx {External Representation} (void) +An empty expression. In practice, equivalent to Scheme's @code{(if #f +#f)}. +@end deftp +@deftp {Scheme Variable} src exp +@deftpx {External Representation} (const @var{exp}) +A constant. +@end deftp +@deftp {Scheme Variable} src name +@deftpx {External Representation} (primitive @var{name}) +A reference to a ``primitive''. A primitive is a procedure that, when +compiled, may be open-coded. For example, @code{cons} is usually +recognized as a primitive, so that it compiles down to a single +instruction. + +Compilation of Tree-IL usually begins with a pass that resolves some +@code{} and @code{} expressions to +@code{} expressions. The actual compilation pass +has special cases for applications of certain primitives, like +@code{apply} or @code{cons}. +@end deftp +@deftp {Scheme Variable} src name gensym +@deftpx {External Representation} (lexical @var{name} @var{gensym}) +A reference to a lexically-bound variable. The @var{name} is the +original name of the variable in the source program. @var{gensym} is a +unique identifier for this variable. +@end deftp +@deftp {Scheme Variable} src name gensym exp +@deftpx {External Representation} (set! (lexical @var{name} @var{gensym}) @var{exp}) +Sets a lexically-bound variable. +@end deftp +@deftp {Scheme Variable} src mod name public? +@deftpx {External Representation} (@@ @var{mod} @var{name}) +@deftpx {External Representation} (@@@@ @var{mod} @var{name}) +A reference to a variable in a specific module. @var{mod} should be +the name of the module, e.g. @code{(guile-user)}. + +If @var{public?} is true, the variable named @var{name} will be looked +up in @var{mod}'s public interface, and serialized with @code{@@}; +otherwise it will be looked up among the module's private bindings, +and is serialized with @code{@@@@}. +@end deftp +@deftp {Scheme Variable} src mod name public? exp +@deftpx {External Representation} (set! (@@ @var{mod} @var{name}) @var{exp}) +@deftpx {External Representation} (set! (@@@@ @var{mod} @var{name}) @var{exp}) +Sets a variable in a specific module. +@end deftp +@deftp {Scheme Variable} src name +@deftpx {External Representation} (toplevel @var{name}) +References a variable from the current procedure's module. +@end deftp +@deftp {Scheme Variable} src name exp +@deftpx {External Representation} (set! (toplevel @var{name}) @var{exp}) +Sets a variable in the current procedure's module. +@end deftp +@deftp {Scheme Variable} src name exp +@deftpx {External Representation} (define (toplevel @var{name}) @var{exp}) +Defines a new top-level variable in the current procedure's module. +@end deftp +@deftp {Scheme Variable} src test then else +@deftpx {External Representation} (if @var{test} @var{then} @var{else}) A conditional. Note that @var{else} is not optional. @end deftp -@deftp {Scheme Variable} env loc . exps -Like Scheme's @code{and}. -@end deftp -@deftp {Scheme Variable} env loc . exps -Like Scheme's @code{or}. -@end deftp -@deftp {Scheme Variable} env loc . body -Like Scheme's @code{begin}. -@end deftp -@deftp {Scheme Variable} env loc vars exprs . body -Like a deconstructed @code{let}: each element of @var{vars} will be -bound to the corresponding GHIL expression in @var{exprs}. - -Note that for purposes of the serialization format, @var{exprs} are -evaluated before the new bindings are added to the environment. For -@code{letrec} semantics, there also exists a @code{bindrec} parse -flavor. This is useful for writing GHIL at the REPL, but the -serializer does not currently have the cleverness needed to determine -whether a @code{} has @code{let} or @code{letrec} -semantics, and thus only serializes @code{} as @code{bind}. -@end deftp -@deftp {Scheme Variable} env loc vars rest producer . body -Like Scheme's @code{receive} -- binds the values returned by -applying @code{producer}, which should be a thunk, to the -@code{lambda}-like bindings described by @var{vars} and @var{rest}. -@end deftp -@deftp {Scheme Variable} env loc vars rest meta . body -A closure. @var{vars} is the argument list, serialized as a list of -symbols. @var{rest} is a boolean, which is @code{#t} iff the last -argument is a rest argument. @var{meta} is an association list of -properties. The actual @var{body} should be a list of GHIL -expressions. -@end deftp -@deftp {Scheme Variable} env loc proc . args +@deftp {Scheme Variable} src proc args +@deftpx {External Representation} (apply @var{proc} . @var{args}) A procedure call. @end deftp -@deftp {Scheme Variable} env loc producer consumer -Like Scheme's @code{call-with-values}. -@end deftp -@deftp {Scheme Variable} env loc op . args -An inlined VM instruction. @var{op} should be the instruction name as -a symbol, and @var{args} should be its arguments, as GHIL expressions. -@end deftp -@deftp {Scheme Variable} env loc . values -Like Scheme's @code{values}. -@end deftp -@deftp {Scheme Variable} env loc . values -@var{values} are as in the Scheme expression, @code{(apply values . -@var{vals})}. -@end deftp -@deftp {Scheme Variable} env loc -Produces, at run-time, a reification of the environment at compile -time. Used in the implementation of Scheme's -@code{compile-time-environment}. +@deftp {Scheme Variable} src exps +@deftpx {External Representation} (begin . @var{exps}) +Like Scheme's @code{begin}. @end deftp - -GHIL implements a compiler to GLIL that recursively traverses GHIL -expressions, writing out GLIL expressions into a linear list. The -compiler also keeps some state as to whether the current expression is -in tail context, and whether its value will be used in future -computations. This state allows the compiler not to emit code for -constant expressions that will not be used (e.g. docstrings), and to -perform tail calls when in tail position. - -Just as the Scheme to GHIL compiler introduced new hidden state---the -environment---the GHIL to GLIL compiler introduces more state, the -stack. While not represented explicitly, the stack is present in the -compilation of each GHIL expression: compiling a GHIL expression -should leave the run-time value stack in the same state. For example, -if the intermediate value stack has two elements before evaluating an -@code{if} expression, it should have two elements after that -expression. +@deftp {Scheme Variable} src names vars meta body +@deftpx {External Representation} (lambda @var{names} @var{vars} @var{meta} @var{body}) +A closure. @var{names} is original binding form, as given in the +source code, which may be an improper list. @var{vars} are gensyms +corresponding to the @var{names}. @var{meta} is an association list of +properties. The actual @var{body} is a single Tree-IL expression. +@end deftp +@deftp {Scheme Variable} src names vars vals exp +@deftpx {External Representation} (let @var{names} @var{vars} @var{vals} @var{exp}) +Lexical binding, like Scheme's @code{let}. @var{names} are the +original binding names, @var{vars} are gensyms corresponding to the +@var{names}, and @var{vals} are Tree-IL expressions for the values. +@var{exp} is a single Tree-IL expression. +@end deftp +@deftp {Scheme Variable} src names vars vals exp +@deftpx {External Representation} (letrec @var{names} @var{vars} @var{vals} @var{exp}) +A version of @code{} that creates recursive bindings, like +Scheme's @code{letrec}. +@end deftp + +@c FIXME -- need to revive this one +@c @deftp {Scheme Variable} src vars rest producer . body +@c Like Scheme's @code{receive} -- binds the values returned by +@c applying @code{producer}, which should be a thunk, to the +@c @code{lambda}-like bindings described by @var{vars} and @var{rest}. +@c @end deftp + +Tree-IL implements a compiler to GLIL that recursively traverses +Tree-IL expressions, writing out GLIL expressions into a linear list. +The compiler also keeps some state as to whether the current +expression is in tail context, and whether its value will be used in +future computations. This state allows the compiler not to emit code +for constant expressions that will not be used (e.g. docstrings), and +to perform tail calls when in tail position. + +In the future, there will be a pass at the beginning of the +Tree-IL->GLIL compilation step to perform inlining, copy propagation, +dead code elimination, and constant folding. Interested readers are encouraged to read the implementation in -@code{(language ghil compile-glil)} for more details. +@code{(language tree-il compile-glil)} for more details. @node GLIL @subsection GLIL Guile Low Intermediate Language (GLIL) is a structured intermediate -language whose expressions closely mirror the functionality of Guile's -VM instruction set. +language whose expressions more closely approximate Guile's VM +instruction set. Its expression types are defined in @code{(language glil)}, and as with GHIL, some of its fields parse as rest arguments. @@ -544,14 +466,11 @@ Pushes a constant value onto the stack. @var{obj} must be a number, string, symbol, keyword, boolean, character, or a pair or vector or list thereof, or the empty list. @end deftp -@deftp {Scheme Variable} op index -Accesses an argument on the stack. If @var{op} is @code{ref}, the -argument is pushed onto the stack; if it is @code{set}, the argument -is set from the top value on the stack, which is popped off. -@end deftp @deftp {Scheme Variable} op index -Like @code{}, but for local variables. @xref{Stack -Layout}, for more information. +Accesses a lexically variable from the stack. If @var{op} is +@code{ref}, the value is pushed onto the stack; if it is @code{set}, +the variable is set from the top value on the stack, which is popped +off. @xref{Stack Layout}, for more information. @end deftp @deftp {Scheme Variable} op depth index Accesses a heap-allocated variable, addressed by @var{depth}, the nth @@ -607,6 +526,12 @@ Just as in all of Guile's compilers, an environment is passed to the GLIL-to-object code compiler, and one is returned as well, along with the object code. +@node Assembly +@subsection Assembly + +@node Bytecode +@subsection Bytecode + @node Object Code @subsection Object Code diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 042645200..ae87fbae2 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -111,7 +111,7 @@ The registers that a VM has are as follows: In other architectures, the instruction pointer is sometimes called the ``program counter'' (pc). This set of registers is pretty typical for stack machines; their exact meanings in the context of Guile's VM -is described in the next section. +are described in the next section. A virtual machine executes by loading a compiled procedure, and executing the object code associated with that procedure. Of course, @@ -119,14 +119,17 @@ that procedure may call other procedures, tail-call others, ad infinitum---indeed, within a guile whose modules have all been compiled to object code, one might never leave the virtual machine. -@c wingo: I wish the following were true, but currently we just use -@c the one engine. This kind of thing is possible tho. +@c wingo: The following is true, but I don't know in what context to +@c describe it. A documentation FIXME. @c A VM may have one of three engines: reckless, regular, or debugging. @c Reckless engine is fastest but dangerous. Regular engine is normally @c fail-safe and reasonably fast. Debugging engine is safest and @c functional but very slow. +@c (Actually we have just a regular and a debugging engine; normally +@c we use the latter, it's almost as fast as the ``regular'' engine.) + @node Stack Layout @subsection Stack Layout @@ -174,7 +177,7 @@ The structure of the fixed part of an application frame is as follows: In the above drawing, the stack grows upward. The intermediate values stored in the application of this frame are stored above @code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the -@code{struct scm_program*} data associated with the program at +@code{struct scm_objcode} data associated with the program at @code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the compiled procedure, which will be discussed later. @@ -226,7 +229,7 @@ programs are implemented, @xref{VM Programs}. @node Variables and the VM @subsection Variables and the VM -Let's think about the following Scheme code as an example: +Consider the following Scheme code as an example: @example (define (foo a) @@ -236,22 +239,15 @@ Let's think about the following Scheme code as an example: Within the lambda expression, "foo" is a top-level variable, "a" is a lexically captured variable, and "b" is a local variable. -That is to say: @code{b} may safely be allocated on the stack, as -there is no enclosed procedure that references it, nor is it ever -mutated. +@code{b} may safely be allocated on the stack, as there is no enclosed +procedure that references it, nor is it ever mutated. @code{a}, on the other hand, is referenced by an enclosed procedure, that of the lambda. Thus it must be allocated on the heap, as it may (and will) outlive the dynamic extent of the invocation of @code{foo}. -@code{foo} is a toplevel variable, as mandated by Scheme's semantics: - -@example - (define proc (foo 'bar)) ; assuming prev. definition of @code{foo} - (define foo 42) ; redefinition - (proc 'baz) - @result{} (42 bar baz) -@end example +@code{foo} is a top-level variable, because it names the procedure +@code{foo}, which is here defined at the top-level. Note that variables that are mutated (via @code{set!}) must be allocated on the heap, even if they are local variables. This is @@ -276,6 +272,7 @@ You can pick apart these pieces with the accessors in @code{(system vm program)}. @xref{Compiled Procedures}, for a full API reference. @cindex object table +@cindex object array The object array of a compiled procedure, also known as the @dfn{object table}, holds all Scheme objects whose values are known not to change across invocations of the procedure: constant strings, @@ -293,31 +290,27 @@ instruction, which uses the object vector, and are almost as fast as local variable references. We can see how these concepts tie together by disassembling the -@code{foo} function to see what is going on: +@code{foo} function we defined earlier to see what is going on: @smallexample scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b))) scheme@@(guile-user)> ,x foo Disassembly of #: -Bytecode: - 0 (local-ref 0) ;; `a' (arg) 2 (external-set 0) ;; `a' (arg) - 4 (object-ref 0) ;; # - 6 (make-closure) at (unknown file):0:16 + 4 (object-ref 1) ;; #:0:16 (b)> + 6 (make-closure) 7 (return) ---------------------------------------- -Disassembly of #: +Disassembly of #:0:16 (b)>: -Bytecode: - - 0 (toplevel-ref 0) ;; `list' - 2 (toplevel-ref 1) ;; `foo' - 4 (external-ref 0) ;; (closure variable) - 6 (local-ref 0) ;; `b' (arg) - 8 (goto/args 3) at (unknown file):0:28 + 0 (toplevel-ref 1) ;; `foo' + 2 (external-ref 0) ;; (closure variable) + 4 (local-ref 0) ;; `b' (arg) + 6 (list 0 3) ;; 3 elements at (unknown file):0:28 + 9 (return) @end smallexample At @code{ip} 0 and 2, we do the copy from argument to heap for @@ -336,8 +329,9 @@ Control Instructions}, for more details. Then we see a reference to an external variable, corresponding to @code{a}. The disassembler doesn't have enough information to give a name to that variable, so it just marks it as being a ``closure -variable''. Finally we see the reference to @code{b}, then a tail call -(@code{goto/args}) with three arguments. +variable''. Finally we see the reference to @code{b}, then the +@code{list} opcode, an inline implementation of the @code{list} scheme +routine. @node Instruction Set @subsection Instruction Set @@ -365,7 +359,8 @@ their own test-and-branch instructions: @end example In addition, some Scheme primitives have their own inline -implementations, e.g. @code{cons}. +implementations, e.g. @code{cons}, and @code{list}, as we saw in the +previous section. So Guile's instruction set is a @emph{complete} instruction set, in that it provides the instructions that are suited to the problem, and @@ -421,12 +416,6 @@ efficient in the future via addressing by frame and index. Currently, external variables are all consed onto a list, which results in O(N) lookup time. -@deffn Instruction externals -Pushes the current list of external variables onto the stack. This -instruction is used in the implementation of -@code{compile-time-environment}. @xref{The Scheme Compiler}. -@end deffn - @deffn Instruction toplevel-ref index Push the value of the toplevel binding whose location is stored in at position @var{index} in the object table. @@ -440,11 +429,11 @@ created. Alternately, the lookup may be performed relative to a particular module, determined at compile-time (e.g. via @code{@@} or @code{@@@@}). In that case, the cell in the object table holds a list: -@code{(@var{modname} @var{sym} @var{interface?})}. The symbol -@var{sym} will be looked up in the module named @var{modname} (a list -of symbols). The lookup will be performed against the module's public -interface, unless @var{interface?} is @code{#f}, which it is for -example when compiling @code{@@@@}. +@code{(@var{modname} @var{sym} @var{public?})}. The symbol @var{sym} +will be looked up in the module named @var{modname} (a list of +symbols). The lookup will be performed against the module's public +interface, unless @var{public?} is @code{#f}, which it is for example +when compiling @code{@@@@}. In any case, if the symbol is unbound, an error is signalled. Otherwise the initial form is replaced with the looked-up variable, an @@ -550,8 +539,9 @@ may be encoded in 1, 2, or 4 bytes. @deffn Instruction load-integer length @deffnx Instruction load-unsigned-integer length -Load a 32-bit integer (respectively unsigned integer) from the -instruction stream. +Load a 32-bit integer or unsigned integer from the instruction stream. +The bytes of the integer are read in order of decreasing significance +(i.e., big-endian). @end deffn @deffn Instruction load-number length Load an arbitrary number from the instruction stream. The number is @@ -573,43 +563,23 @@ the current toplevel environment, creating the binding if necessary. Push the variable corresponding to the binding. @end deffn -@deffn Instruction load-program length +@deffn Instruction load-program Load bytecode from the instruction stream, and push a compiled -procedure. This instruction pops the following values from the stack: +procedure. -@itemize -@item Optionally, a thunk, which when called should return metadata -associated with this program---for example its name, the names of its -arguments, its documentation string, debugging information, etc. - -Normally, this thunk its itself a compiled procedure (with no -metadata). Metadata is represented this way so that the initial load -of a procedure is fast: the VM just mmap's the thunk and goes. The -symbols and pairs associated with the metadata are only created if the -user asks for them. - -For information on the format of the thunk's return value, -@xref{Compiled Procedures}. -@item Optionally, the program's object table, as a vector. - -A program that does not reference toplevel bindings and does not use -@code{object-ref} does not need an object table. -@item Finally, either one immediate integer or four immediate integers -representing the arity of the program. - -In the four-fixnum case, the values are respectively the number of -arguments taken by the function (@var{nargs}), the number of @dfn{rest -arguments} (@var{nrest}, 0 or 1), the number of local variables -(@var{nlocs}) and the number of external variables (@var{nexts}) -(@pxref{Environment Control Instructions}). - -The common single-fixnum case represents all of these values within a -16-bit bitmask. -@end itemize +This instruction pops one value from the stack: the program's object +table, as a vector, or @code{#f} in the case that the program has no +object table. A program that does not reference toplevel bindings and +does not use @code{object-ref} does not need an object table. + +This instruction is unlike the rest of the loading instructions, +because instead of parsing its data, it directly maps the instruction +stream onto a C structure, @code{struct scm_objcode}. @xref{Object +Code}, for more information. The resulting compiled procedure will not have any ``external'' -variables captured, so it will be loaded only once but may be used -many times to create closures. +variables captured, so it may be loaded only once but used many times +to create closures. @end deffn Finally, while this instruction is not strictly a ``loading'' @@ -620,7 +590,10 @@ here: Pop the program object from the stack, capture the current set of ``external'' variables, and assign those external variables to a copy of the program. Push the new program object, which shares state with -the original program. Also captures the current module. +the original program. + +At the time of this writing, the space overhead of closures is 4 words +per closure. @end deffn @node Procedural Instructions @@ -640,22 +613,24 @@ set to the returned value. @deffn Instruction call nargs Call the procedure located at @code{sp[-nargs]} with the @var{nargs} -arguments located from @code{sp[0]} to @code{sp[-nargs + 1]}. +arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}. + +For compiled procedures, this instruction sets up a new stack frame, +as described in @ref{Stack Layout}, and then dispatches to the first +instruction in the called procedure, relying on the called procedure +to return one value to the newly-created continuation. Because the new +frame pointer will point to sp[-nargs + 1], the arguments don't have +to be shuffled around -- they are already in place. For non-compiled procedures (continuations, primitives, and interpreted procedures), @code{call} will pop the procedure and arguments off the stack, and push the result of calling @code{scm_apply}. - -For compiled procedures, this instruction sets up a new stack frame, -as described in @ref{Stack Layout}, and then dispatches to the first -instruction in the called procedure, relying on the called procedure -to return one value to the newly-created continuation. @end deffn @deffn Instruction goto/args nargs Like @code{call}, but reusing the current continuation. This -instruction implements tail calling as required by RnRS. +instruction implements tail calls as required by RnRS. For compiled procedures, that means that @code{goto/args} reuses the current frame instead of building a new one. The @code{goto/*} @@ -726,14 +701,14 @@ values. This is an optimization for the common @code{(apply values @deffn Instruction truncate-values nbinds nrest Used in multiple-value continuations, this instruction takes the -values that are on the stack (including the number-of-value marker) +values that are on the stack (including the number-of-values marker) and truncates them for a binding construct. For example, a call to @code{(receive (x y . z) (foo) ...)} would, logically speaking, pop off the values returned from @code{(foo)} and push them as three values, corresponding to @code{x}, @code{y}, and @code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would -be 1 (to indicate that one of the bindings was a rest arguments). +be 1 (to indicate that one of the bindings was a rest argument). Signals an error if there is an insufficient number of values. @end deffn @@ -779,12 +754,14 @@ Push @var{value}, an 8-bit character, onto the stack. @deffn Instruction list n Pops off the top @var{n} values off of the stack, consing them up into a list, then pushes that list on the stack. What was the topmost value -will be the last element in the list. +will be the last element in the list. @var{n} is a two-byte value, +most significant byte first. @end deffn @deffn Instruction vector n Create and fill a vector with the top @var{n} values from the stack, -popping off those values and pushing on the resulting vector. +popping off those values and pushing on the resulting vector. @var{n} +is a two-byte value, like in @code{vector}. @end deffn @deffn Instruction mark @@ -850,9 +827,8 @@ Pushes ``the unspecified value'' onto the stack. @subsubsection Inlined Scheme Instructions The Scheme compiler can recognize the application of standard Scheme -procedures, or unbound variables that look like they are bound to -standard Scheme procedures. It tries to inline these small operations -to avoid the overhead of creating new stack frames. +procedures. It tries to inline these small operations to avoid the +overhead of creating new stack frames. Since most of these operations are historically implemented as C primitives, not inlining them would entail constantly calling out from @@ -876,12 +852,12 @@ stream. @deffnx Instruction eqv? x y @deffnx Instruction equal? x y @deffnx Instruction pair? x y -@deffnx Instruction list? x y +@deffnx Instruction list? x @deffnx Instruction set-car! pair x @deffnx Instruction set-cdr! pair x @deffnx Instruction slot-ref struct n @deffnx Instruction slot-set struct n x -@deffnx Instruction cons x +@deffnx Instruction cons x y @deffnx Instruction car x @deffnx Instruction cdr x Inlined implementations of their Scheme equivalents. diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index a6cb66dbc..42f2b1973 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -410,12 +410,6 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1) -{ - PUSH (external); - NEXT; -} - /* * branch and jump diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm index 234cd064c..92d31cabc 100644 --- a/module/ice-9/documentation.scm +++ b/module/ice-9/documentation.scm @@ -198,6 +198,8 @@ OBJECT can be a procedure, macro or any object that has its (object-property object 'documentation) (and (program? object) (program-documentation object)) + (and (macro? object) + (object-documentation (macro-transformer object))) (and (procedure? object) (not (closure? object)) (procedure-name object) diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index 2752934f9..df6199977 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -82,7 +82,7 @@ (if (program? x) (begin (display "----------------------------------------\n") (disassemble x)))) - (cddr (vector->list objs)))))) + (cdr (vector->list objs)))))) (else (error "bad load-program form" asm)))) diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm index 550a0b734..0112af5a4 100644 --- a/module/language/ecmascript/spec.scm +++ b/module/language/ecmascript/spec.scm @@ -33,7 +33,6 @@ #:title "Guile ECMAScript" #:version "3.0" #:reader (lambda () (read-ecmascript/1 (current-input-port))) - #:read-file read-ecmascript #:compilers `((ghil . ,compile-ghil)) ;; a pretty-printer would be interesting. #:printer write diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 4564fb933..cec2693aa 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -32,12 +32,6 @@ (read-enable 'positions) -(define (read-file port) - (do ((x (read port) (read port)) - (l '() (cons x l))) - ((eof-object? x) - (cons 'begin (reverse! l))))) - ;;; ;;; Language definition ;;; @@ -46,7 +40,6 @@ #:title "Guile Scheme" #:version "0.5" #:reader read - #:read-file read-file #:compilers `((tree-il . ,compile-tree-il) (ghil . ,compile-ghil)) #:decompilers `((tree-il . ,decompile-tree-il)) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index a81947749..335031182 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -21,12 +21,8 @@ #:use-module (system base syntax) #:export (tree-il-src - make-lexical - lexical-name lexical-gensym - void? make-void void-src - application? make-application application-src application-proc application-args - conditional? make-conditional conditional-src conditional-test conditional-then conditional-else + const? make-const const-src const-exp primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp @@ -35,9 +31,10 @@ toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp - lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body - const? make-const const-src const-exp + conditional? make-conditional conditional-src conditional-test conditional-then conditional-else + application? make-application application-src application-proc application-args sequence? make-sequence sequence-src sequence-exps + lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body let? make-let let-src let-names let-vars let-vals let-exp letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp @@ -50,8 +47,7 @@ (define-type ( #:common-slots (src)) () - ( proc args) - ( test then else) + ( exp) ( name) ( name gensym) ( name gensym exp) @@ -60,28 +56,19 @@ ( name) ( name exp) ( name exp) - ( names vars meta body) - ( exp) + ( test then else) + ( proc args) ( exps) + ( names vars meta body) ( names vars vals exp) ( names vars vals exp)) -(define ) -(define lexical? lexical-ref?) -(define make-lexical make-lexical-ref) -(define lexical-name lexical-ref-name) -(define lexical-gensym lexical-ref-gensym) - -;; FIXME: use this in psyntax (define (location x) (and (pair? x) (let ((props (source-properties x))) - (and (not (null? props)) - (vector (assq-ref props 'line) - (assq-ref props 'column) - (assq-ref props 'filename)))))) + (and (pair? props) props)))) (define (parse-tree-il exp) (let ((loc (location exp)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 25fd8c79e..51bbfeae9 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -152,7 +152,7 @@ (define-primitive-expander / (x) (/ 1 x) - (x y z . rest) (div x (* y z . rest))) + (x y z . rest) (/ x (* y z . rest))) (define-primitive-expander caar (x) (car (car x))) (define-primitive-expander cadr (x) (car (cdr x))) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index d0ebde040..74fb59852 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -135,11 +135,6 @@ ;;; Compiler interface ;;; -(define (read-file-in file lang) - (call-with-input-file file - (or (language-read-file lang) - (error "language has no #:read-file" lang)))) - (define (compile-passes from to opts) (map cdr (or (lookup-compilation-order from to) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 649137c4d..8ae4d9667 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -23,7 +23,7 @@ #:use-module (system base syntax) #:export (define-language language? lookup-language make-language language-name language-title language-version language-reader - language-printer language-parser language-read-file + language-printer language-parser language-compilers language-decompilers language-evaluator language-joiner @@ -42,7 +42,6 @@ reader printer (parser #f) - (read-file #f) (compilers '()) (decompilers '()) (evaluator #f) -- cgit v1.2.3 From 442f3f20ddd33b43743ea181d95024c10622df52 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 17:39:58 +0200 Subject: symbols are now hidden unless explicitly exported by SCM_API * libguile/__scm.h (SCM_API, SCM_INTERNAL): Take the reverse strategy: symbols will be hidden by default, and only exported with SCM_API. In addition to working on Mac OS, it has the several nice efficiency benefits on Linux, and unifies codepaths with Win32. * libguile/Makefile.am: Define BUILDING_LIBGUILE when building Guile. --- libguile/Makefile.am | 4 ++-- libguile/__scm.h | 26 ++++++++++++-------------- 2 files changed, 14 insertions(+), 16 deletions(-) (limited to 'libguile') diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 369b24951..63f2ef2bf 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -32,10 +32,10 @@ DEFAULT_INCLUDES = ## Check for headers in $(srcdir)/.., so that #include ## will find MUMBLE.h in this dir when we're ## building. Also look for Gnulib headers in `lib'. -AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \ +AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \ -I$(top_srcdir)/lib -I$(top_builddir)/lib -AM_CFLAGS = $(GCC_CFLAGS) +AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY) ## The Gnulib Libtool archive. gnulib_library = $(top_builddir)/lib/libgnu.la diff --git a/libguile/__scm.h b/libguile/__scm.h index 3672b1c09..07d7b4d3d 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -98,13 +98,10 @@ #define SCM_UNLIKELY(_expr) SCM_EXPECT ((_expr), 0) /* The SCM_INTERNAL macro makes it possible to explicitly declare a function - * as having "internal" linkage. */ -#if (defined __GNUC__) && \ - ((__GNUC__ >= 4) || (__GNUC__ == 3 && __GNUC_MINOR__ == 3)) -# define SCM_INTERNAL extern __attribute__ ((__visibility__ ("internal"))) -#else -# define SCM_INTERNAL extern -#endif + * as having "internal" linkage. However our current tack on this problem is + * to use GCC 4's -fvisibility=hidden, making functions internal by default, + * and then SCM_API marks them for export. */ +#define SCM_INTERNAL extern @@ -154,13 +151,14 @@ /* SCM_API is a macro prepended to all function and data definitions - which should be exported or imported in the resulting dynamic link - library (DLL) in the Win32 port. */ - -#if defined (SCM_IMPORT) -# define SCM_API __declspec (dllimport) extern -#elif defined (SCM_EXPORT) || defined (DLL_EXPORT) -# define SCM_API __declspec (dllexport) extern + which should be exported from libguile. */ + +#if BUILDING_LIBGUILE && HAVE_VISIBILITY +# define SCM_API extern __attribute__((__visibility__("default"))) +#elif BUILDING_LIBGUILE && defined _MSC_VER +# define SCM_API __declspec(dllexport) extern +#elif defined _MSC_VER +# define SCM_API __declspec(dllimport) extern #else # define SCM_API extern #endif -- cgit v1.2.3 From b579617b2db0e83f620c5b856dcc320cea9d6d1f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 18:06:21 +0200 Subject: gnulib-tool --import environ; rely on gnulib for environ definitions * libguile/posix.c: * libguile/stime.c: Remove environ definition, gnulib provides it now. --- lib/Makefile.am | 2 +- libguile/posix.c | 13 ------------- libguile/stime.c | 13 ------------- m4/environ.m4 | 36 ++++++++++++++++++++++++++++++++++++ m4/gnulib-cache.m4 | 3 ++- m4/gnulib-comp.m4 | 3 +++ 6 files changed, 42 insertions(+), 28 deletions(-) create mode 100644 m4/environ.m4 (limited to 'libguile') diff --git a/lib/Makefile.am b/lib/Makefile.am index 8f431c2b1..f321b0b16 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -9,7 +9,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime +# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits environ extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime AUTOMAKE_OPTIONS = 1.5 gnits diff --git a/libguile/posix.c b/libguile/posix.c index 2799209d9..5e6f05fb7 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -101,8 +101,6 @@ extern char *ttyname(); #include -extern char ** environ; - #ifdef HAVE_GRP_H #include #endif @@ -140,10 +138,6 @@ extern char ** environ; #include /* from Gnulib */ -#if HAVE_CRT_EXTERNS_H -#include /* for Darwin _NSGetEnviron */ -#endif - /* Some Unix systems don't define these. CPP hair is dangerous, but this seems safe enough... */ #ifndef R_OK @@ -196,13 +190,6 @@ int sethostname (char *name, size_t namelen); -/* On Apple Darwin in a shared library there's no "environ" to access - directly, instead the address of that variable must be obtained with - _NSGetEnviron(). */ -#if HAVE__NSGETENVIRON && defined (PIC) -#define environ (*_NSGetEnviron()) -#endif - /* Two often used patterns diff --git a/libguile/stime.c b/libguile/stime.c index 34c8a98fa..5384783e3 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -77,10 +77,6 @@ # include #endif -#if HAVE_CRT_EXTERNS_H -#include /* for Darwin _NSGetEnviron */ -#endif - #ifndef tzname /* For SGI. */ extern char *tzname[]; /* RS6000 and others reject char **tzname. */ #endif @@ -98,15 +94,6 @@ extern char *strptime (); # define timet long #endif -extern char ** environ; - -/* On Apple Darwin in a shared library there's no "environ" to access - directly, instead the address of that variable must be obtained with - _NSGetEnviron(). */ -#if HAVE__NSGETENVIRON && defined (PIC) -#define environ (*_NSGetEnviron()) -#endif - #ifdef HAVE_TIMES static diff --git a/m4/environ.m4 b/m4/environ.m4 new file mode 100644 index 000000000..b17bb60a7 --- /dev/null +++ b/m4/environ.m4 @@ -0,0 +1,36 @@ +# environ.m4 serial 2 +dnl Copyright (C) 2001-2004, 2006-2009 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_ENVIRON], +[ + AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + dnl Persuade glibc to declare environ. + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + gt_CHECK_VAR_DECL([#include ], environ) + if test $gt_cv_var_environ_declaration != yes; then + HAVE_DECL_ENVIRON=0 + fi +]) + +# Check if a variable is properly declared. +# gt_CHECK_VAR_DECL(includes,variable) +AC_DEFUN([gt_CHECK_VAR_DECL], +[ + define([gt_cv_var], [gt_cv_var_]$2[_declaration]) + AC_MSG_CHECKING([if $2 is properly declared]) + AC_CACHE_VAL([gt_cv_var], [ + AC_TRY_COMPILE([$1 + extern struct { int foo; } $2;], + [$2.foo = 1;], + gt_cv_var=no, + gt_cv_var=yes)]) + AC_MSG_RESULT([$gt_cv_var]) + if test $gt_cv_var = yes; then + AC_DEFINE([HAVE_]translit($2, [a-z], [A-Z])[_DECL], 1, + [Define if you have the declaration of $2.]) + fi + undefine([gt_cv_var]) +]) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index fd6c4fe91..c7cfb83dd 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -15,7 +15,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime +# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild count-one-bits environ extensions flock fpieee full-read full-write lib-symbol-visibility putenv stdlib strcase strftime # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([]) @@ -23,6 +23,7 @@ gl_MODULES([ alloca-opt autobuild count-one-bits + environ extensions flock fpieee diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 77100fa1b..b6d10a862 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -45,6 +45,8 @@ AC_DEFUN([gl_INIT], gl_source_base='lib' gl_FUNC_ALLOCA gl_COUNT_ONE_BITS + gl_ENVIRON + gl_UNISTD_MODULE_INDICATOR([environ]) gl_FUNC_FLOCK gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock]) gl_INLINE @@ -251,6 +253,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/autobuild.m4 m4/codeset.m4 m4/count-one-bits.m4 + m4/environ.m4 m4/extensions.m4 m4/flock.m4 m4/fpieee.m4 -- cgit v1.2.3 From 560b9c256d9cd5f80dead6ddb0d747a21c6c003a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 May 2009 22:23:44 +0200 Subject: adjust VM copyright notices to LGPL, use SCM_INTERNAL/API properly * libguile/frames.c: * libguile/frames.h: * libguile/instructions.c: * libguile/instructions.h: * libguile/objcodes.c: * libguile/objcodes.h: * libguile/programs.c: * libguile/programs.h: * libguile/vm-bootstrap.h: * libguile/vm-engine.c: * libguile/vm-engine.h: * libguile/vm-expand.h: * libguile/vm-i-scheme.c: * libguile/vm.c: * libguile/vm.h: Update to use SCM_API and SCM_INTERNAL correctly. Adjust copyright to be the same as the copyright of Guile itself, which should be fine given that the FSF holds the whole thing. --- libguile/frames.c | 49 ++++++--------------- libguile/frames.h | 84 +++++++++++++----------------------- libguile/instructions.c | 50 ++++++---------------- libguile/instructions.h | 66 +++++++++-------------------- libguile/objcodes.c | 49 ++++++--------------- libguile/objcodes.h | 66 +++++++++-------------------- libguile/programs.c | 49 ++++++--------------- libguile/programs.h | 86 ++++++++++++++----------------------- libguile/vm-bootstrap.h | 50 ++++++---------------- libguile/vm-engine.c | 48 ++++++--------------- libguile/vm-engine.h | 48 ++++++--------------- libguile/vm-expand.h | 48 ++++++--------------- libguile/vm-i-scheme.c | 48 ++++++--------------- libguile/vm.c | 49 ++++++--------------- libguile/vm.h | 110 +++++++++++++++++++----------------------------- 15 files changed, 273 insertions(+), 627 deletions(-) (limited to 'libguile') diff --git a/libguile/frames.c b/libguile/frames.c index f53cade95..c08fd3134 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include @@ -45,6 +21,7 @@ #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "frames.h" diff --git a/libguile/frames.h b/libguile/frames.h index 836763700..d74476ac8 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. + * * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_FRAMES_H_ #define _SCM_FRAMES_H_ @@ -97,7 +73,7 @@ * Heap frames */ -extern scm_t_bits scm_tc16_vm_frame; +SCM_API scm_t_bits scm_tc16_vm_frame; struct scm_vm_frame { @@ -118,24 +94,24 @@ struct scm_vm_frame #define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P) /* FIXME rename scm_byte_t */ -extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, +SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, scm_byte_t *ip, scm_t_ptrdiff offset); -extern SCM scm_vm_frame_p (SCM obj); -extern SCM scm_vm_frame_program (SCM frame); -extern SCM scm_vm_frame_arguments (SCM frame); -extern SCM scm_vm_frame_source (SCM frame); -extern SCM scm_vm_frame_local_ref (SCM frame, SCM index); -extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); -extern SCM scm_vm_frame_return_address (SCM frame); -extern SCM scm_vm_frame_mv_return_address (SCM frame); -extern SCM scm_vm_frame_dynamic_link (SCM frame); -extern SCM scm_vm_frame_external_link (SCM frame); -extern SCM scm_vm_frame_stack (SCM frame); - -extern SCM scm_c_vm_frame_prev (SCM frame); - -extern void scm_bootstrap_frames (void); -extern void scm_init_frames (void); +SCM_API SCM scm_vm_frame_p (SCM obj); +SCM_API SCM scm_vm_frame_program (SCM frame); +SCM_API SCM scm_vm_frame_arguments (SCM frame); +SCM_API SCM scm_vm_frame_source (SCM frame); +SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index); +SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); +SCM_API SCM scm_vm_frame_return_address (SCM frame); +SCM_API SCM scm_vm_frame_mv_return_address (SCM frame); +SCM_API SCM scm_vm_frame_dynamic_link (SCM frame); +SCM_API SCM scm_vm_frame_external_link (SCM frame); +SCM_API SCM scm_vm_frame_stack (SCM frame); + +SCM_API SCM scm_c_vm_frame_prev (SCM frame); + +SCM_INTERNAL void scm_bootstrap_frames (void); +SCM_INTERNAL void scm_init_frames (void); #endif /* _SCM_FRAMES_H_ */ diff --git a/libguile/instructions.c b/libguile/instructions.c index 4f504f0a2..f0f52e422 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -1,49 +1,27 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include #endif #include + +#include "_scm.h" #include "vm-bootstrap.h" #include "instructions.h" diff --git a/libguile/instructions.h b/libguile/instructions.h index 4968671b5..f4f45b371 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_INSTRUCTIONS_H_ #define _SCM_INSTRUCTIONS_H_ @@ -57,16 +33,16 @@ enum scm_opcode { scm_op_last = SCM_VM_NUM_INSTRUCTIONS }; -extern SCM scm_instruction_list (void); -extern SCM scm_instruction_p (SCM obj); -extern SCM scm_instruction_length (SCM inst); -extern SCM scm_instruction_pops (SCM inst); -extern SCM scm_instruction_pushes (SCM inst); -extern SCM scm_instruction_to_opcode (SCM inst); -extern SCM scm_opcode_to_instruction (SCM op); +SCM_API SCM scm_instruction_list (void); +SCM_API SCM scm_instruction_p (SCM obj); +SCM_API SCM scm_instruction_length (SCM inst); +SCM_API SCM scm_instruction_pops (SCM inst); +SCM_API SCM scm_instruction_pushes (SCM inst); +SCM_API SCM scm_instruction_to_opcode (SCM inst); +SCM_API SCM scm_opcode_to_instruction (SCM op); -extern void scm_bootstrap_instructions (void); -extern void scm_init_instructions (void); +SCM_INTERNAL void scm_bootstrap_instructions (void); +SCM_INTERNAL void scm_init_instructions (void); #endif /* _SCM_INSTRUCTIONS_H_ */ diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 8bc203dda..6a0a11b29 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include @@ -51,6 +27,7 @@ #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "programs.h" #include "objcodes.h" diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 222691668..acd43a600 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. + * * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_OBJCODES_H_ #define _SCM_OBJCODES_H_ @@ -60,7 +36,7 @@ struct scm_objcode { #define SCM_F_OBJCODE_IS_U8VECTOR (1<<1) #define SCM_F_OBJCODE_IS_SLICE (1<<2) -extern scm_t_bits scm_tc16_objcode; +SCM_API scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x)) #define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x)) @@ -80,15 +56,15 @@ extern scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE) SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr); -extern SCM scm_load_objcode (SCM file); -extern SCM scm_objcode_p (SCM obj); -extern SCM scm_objcode_meta (SCM objcode); -extern SCM scm_bytecode_to_objcode (SCM bytecode); -extern SCM scm_objcode_to_bytecode (SCM objcode); -extern SCM scm_write_objcode (SCM objcode, SCM port); +SCM_API SCM scm_load_objcode (SCM file); +SCM_API SCM scm_objcode_p (SCM obj); +SCM_API SCM scm_objcode_meta (SCM objcode); +SCM_API SCM scm_bytecode_to_objcode (SCM bytecode); +SCM_API SCM scm_objcode_to_bytecode (SCM objcode); +SCM_API SCM scm_write_objcode (SCM objcode, SCM port); -extern void scm_bootstrap_objcodes (void); -extern void scm_init_objcodes (void); +SCM_INTERNAL void scm_bootstrap_objcodes (void); +SCM_INTERNAL void scm_init_objcodes (void); #endif /* _SCM_OBJCODES_H_ */ diff --git a/libguile/programs.c b/libguile/programs.c index 8e8982994..68e0b8541 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,49 +1,26 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include #endif #include +#include "_scm.h" #include "vm-bootstrap.h" #include "instructions.h" #include "modules.h" diff --git a/libguile/programs.h b/libguile/programs.h index 68a6936a2..ae819ef85 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_PROGRAMS_H_ #define _SCM_PROGRAMS_H_ @@ -51,7 +27,7 @@ typedef unsigned char scm_byte_t; -extern scm_t_bits scm_tc16_program; +SCM_API scm_t_bits scm_tc16_program; #define SCM_F_PROGRAM_IS_BOOT (1<<0) @@ -63,27 +39,27 @@ extern scm_t_bits scm_tc16_program; #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) #define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT) -extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); +SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); -extern SCM scm_program_p (SCM obj); -extern SCM scm_program_base (SCM program); -extern SCM scm_program_arity (SCM program); -extern SCM scm_program_meta (SCM program); -extern SCM scm_program_bindings (SCM program); -extern SCM scm_program_sources (SCM program); -extern SCM scm_program_source (SCM program, SCM ip); -extern SCM scm_program_properties (SCM program); -extern SCM scm_program_name (SCM program); -extern SCM scm_program_objects (SCM program); -extern SCM scm_program_module (SCM program); -extern SCM scm_program_external (SCM program); -extern SCM scm_program_external_set_x (SCM program, SCM external); -extern SCM scm_program_objcode (SCM program); +SCM_API SCM scm_program_p (SCM obj); +SCM_API SCM scm_program_base (SCM program); +SCM_API SCM scm_program_arity (SCM program); +SCM_API SCM scm_program_meta (SCM program); +SCM_API SCM scm_program_bindings (SCM program); +SCM_API SCM scm_program_sources (SCM program); +SCM_API SCM scm_program_source (SCM program, SCM ip); +SCM_API SCM scm_program_properties (SCM program); +SCM_API SCM scm_program_name (SCM program); +SCM_API SCM scm_program_objects (SCM program); +SCM_API SCM scm_program_module (SCM program); +SCM_API SCM scm_program_external (SCM program); +SCM_API SCM scm_program_external_set_x (SCM program, SCM external); +SCM_API SCM scm_program_objcode (SCM program); -extern SCM scm_c_program_source (SCM program, size_t ip); +SCM_API SCM scm_c_program_source (SCM program, size_t ip); -extern void scm_bootstrap_programs (void); -extern void scm_init_programs (void); +SCM_INTERNAL void scm_bootstrap_programs (void); +SCM_INTERNAL void scm_init_programs (void); #endif /* _SCM_PROGRAMS_H_ */ diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h index beecf0fc2..587766a67 100644 --- a/libguile/vm-bootstrap.h +++ b/libguile/vm-bootstrap.h @@ -1,48 +1,24 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_VM_BOOTSTRAP_H_ #define _SCM_VM_BOOTSTRAP_H_ -extern void scm_bootstrap_vm (void); +SCM_INTERNAL void scm_bootstrap_vm (void); #endif /* _SCM_VM_BOOTSTRAP_H_ */ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 45251fd70..f43f8c7fe 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ /* This file is included in vm.c multiple times */ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index fbd2c6c75..8c919f630 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ /* This file is included in vm_engine.c */ diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h index 7ad2b9da8..02dfbc4d0 100644 --- a/libguile/vm-expand.h +++ b/libguile/vm-expand.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef VM_LABEL #define VM_LABEL(tag) l_##tag diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 4af60265e..38dea32b9 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ /* This file is included in vm_engine.c */ diff --git a/libguile/vm.c b/libguile/vm.c index 38d085c99..081a691ff 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #if HAVE_CONFIG_H # include @@ -46,6 +22,7 @@ #include #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "frames.h" #include "instructions.h" diff --git a/libguile/vm.h b/libguile/vm.h index 5c38f9ffa..2f2b617ce 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ #ifndef _SCM_VM_H_ #define _SCM_VM_H_ @@ -78,37 +54,37 @@ struct scm_vm { SCM trace_frame; /* a frame being traced */ }; -extern SCM scm_the_vm_fluid; +SCM_API SCM scm_the_vm_fluid; #define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x) #define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm)) #define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P) -extern SCM scm_the_vm (); -extern SCM scm_make_vm (void); -extern SCM scm_vm_apply (SCM vm, SCM program, SCM args); -extern SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); -extern SCM scm_vm_option_ref (SCM vm, SCM key); -extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); - -extern SCM scm_vm_version (void); -extern SCM scm_the_vm (void); -extern SCM scm_vm_p (SCM obj); -extern SCM scm_vm_ip (SCM vm); -extern SCM scm_vm_sp (SCM vm); -extern SCM scm_vm_fp (SCM vm); -extern SCM scm_vm_boot_hook (SCM vm); -extern SCM scm_vm_halt_hook (SCM vm); -extern SCM scm_vm_next_hook (SCM vm); -extern SCM scm_vm_break_hook (SCM vm); -extern SCM scm_vm_enter_hook (SCM vm); -extern SCM scm_vm_apply_hook (SCM vm); -extern SCM scm_vm_exit_hook (SCM vm); -extern SCM scm_vm_return_hook (SCM vm); -extern SCM scm_vm_option (SCM vm, SCM key); -extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); -extern SCM scm_vm_stats (SCM vm); -extern SCM scm_vm_trace_frame (SCM vm); +SCM_API SCM scm_the_vm (); +SCM_API SCM scm_make_vm (void); +SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args); +SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); +SCM_API SCM scm_vm_option_ref (SCM vm, SCM key); +SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); + +SCM_API SCM scm_vm_version (void); +SCM_API SCM scm_the_vm (void); +SCM_API SCM scm_vm_p (SCM obj); +SCM_API SCM scm_vm_ip (SCM vm); +SCM_API SCM scm_vm_sp (SCM vm); +SCM_API SCM scm_vm_fp (SCM vm); +SCM_API SCM scm_vm_boot_hook (SCM vm); +SCM_API SCM scm_vm_halt_hook (SCM vm); +SCM_API SCM scm_vm_next_hook (SCM vm); +SCM_API SCM scm_vm_break_hook (SCM vm); +SCM_API SCM scm_vm_enter_hook (SCM vm); +SCM_API SCM scm_vm_apply_hook (SCM vm); +SCM_API SCM scm_vm_exit_hook (SCM vm); +SCM_API SCM scm_vm_return_hook (SCM vm); +SCM_API SCM scm_vm_option (SCM vm, SCM key); +SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); +SCM_API SCM scm_vm_stats (SCM vm); +SCM_API SCM scm_vm_trace_frame (SCM vm); struct scm_vm_cont { scm_byte_t *ip; @@ -119,16 +95,16 @@ struct scm_vm_cont { scm_t_ptrdiff reloc; }; -extern scm_t_bits scm_tc16_vm_cont; +SCM_API scm_t_bits scm_tc16_vm_cont; #define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) #define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT)) -extern SCM scm_vm_capture_continuations (void); -extern void scm_vm_reinstate_continuations (SCM conts); +SCM_API SCM scm_vm_capture_continuations (void); +SCM_API void scm_vm_reinstate_continuations (SCM conts); -extern SCM scm_load_compiled_with_vm (SCM file); +SCM_API SCM scm_load_compiled_with_vm (SCM file); -extern void scm_init_vm (void); +SCM_INTERNAL void scm_init_vm (void); #endif /* _SCM_VM_H_ */ -- cgit v1.2.3 From 4201062de5e4f2eb7b2207a3c09e02a12b9bda50 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 23 May 2009 17:55:58 +0100 Subject: Fix wait-condition-variable so that it doesn't leave asyncs blocked * libguile/threads.c (fat_mutex_unlock): Unblock asyncs when breaking out of loop. * test-suite/tests/threads.test (asyncs-still-working?): New function, to test if asyncs are working (i.e. unblocked). Use this throughout threads.test, in particular before and after the "timed locking succeeds if mutex unlocked within timeout" test. --- libguile/threads.c | 1 + test-suite/tests/threads.test | 43 +++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 42 insertions(+), 2 deletions(-) (limited to 'libguile') diff --git a/libguile/threads.c b/libguile/threads.c index bb874e230..947e59546 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1491,6 +1491,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, { if (relock) scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner); + t->block_asyncs--; break; } diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index caace7fd4..62048eaba 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -21,6 +21,20 @@ :use-module (ice-9 threads) :use-module (test-suite lib)) +(define (asyncs-still-working?) + (let ((a #f)) + (system-async-mark (lambda () + (set! a #t))) + ;; The point of the following (equal? ...) is to go through + ;; primitive code (scm_equal_p) that includes a SCM_TICK call and + ;; hence gives system asyncs a chance to run. Of course the + ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the + ;; near future we may be using the VM instead of the traditional + ;; compiler, and then we will still want asyncs-still-working? to + ;; work. (The VM should probably have SCM_TICK calls too, but + ;; let's not rely on that here.) + (equal? '(a b c) '(a b c)) + a)) (if (provided? 'threads) (begin @@ -101,6 +115,9 @@ (with-test-prefix "n-for-each-par-map" + (pass-if "asyncs are still working 2" + (asyncs-still-working?)) + (pass-if "0 in limit 10" (n-for-each-par-map 10 noop noop '()) #t) @@ -143,12 +160,18 @@ (with-test-prefix "lock-mutex" + (pass-if "asyncs are still working 3" + (asyncs-still-working?)) + (pass-if "timed locking fails if timeout exceeded" (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (lock-mutex m (+ (current-time) 1))))) (not (join-thread t))))) + (pass-if "asyncs are still working 6" + (asyncs-still-working?)) + (pass-if "timed locking succeeds if mutex unlocked within timeout" (let* ((m (make-mutex)) (c (make-condition-variable)) @@ -164,7 +187,12 @@ (unlock-mutex cm) (sleep 1) (unlock-mutex m) - (join-thread t))))) + (join-thread t)))) + + (pass-if "asyncs are still working 7" + (asyncs-still-working?)) + + ) ;; ;; timed mutex unlocking @@ -172,12 +200,18 @@ (with-test-prefix "unlock-mutex" + (pass-if "asyncs are still working 5" + (asyncs-still-working?)) + (pass-if "timed unlocking returns #f if timeout exceeded" (let ((m (make-mutex)) (c (make-condition-variable))) (lock-mutex m) (not (unlock-mutex m c (current-time))))) + (pass-if "asyncs are still working 4" + (asyncs-still-working?)) + (pass-if "timed unlocking returns #t if condition signaled" (let ((m1 (make-mutex)) (m2 (make-mutex)) @@ -226,7 +260,12 @@ (pass-if "timed joining succeeds if thread exits within timeout" (let ((t (begin-thread (begin (sleep 1) #t)))) - (join-thread t (+ (current-time) 2))))) + (join-thread t (+ (current-time) 2)))) + + (pass-if "asyncs are still working 1" + (asyncs-still-working?)) + + ) ;; ;; thread cancellation -- cgit v1.2.3 From 21346c4f5e30910e3950c40bc267bb4249973240 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 20 May 2009 21:55:35 +0100 Subject: Remove possible deadlock in scm_join_thread_timed * libguile/threads.c (scm_join_thread_timed): Recheck t->exited before looping round to call block_self again, in case thread t has now exited. * test-suite/tests/threads.test ("don't hang when joined thread terminates in SCM_TICK"): New test. --- libguile/threads.c | 10 ++++++++++ test-suite/tests/threads.test | 26 +++++++++++++++++++++++++- 2 files changed, 35 insertions(+), 1 deletion(-) (limited to 'libguile') diff --git a/libguile/threads.c b/libguile/threads.c index 947e59546..d63c6197e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1161,6 +1161,16 @@ SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0, scm_i_pthread_mutex_unlock (&t->admin_mutex); SCM_TICK; scm_i_scm_pthread_mutex_lock (&t->admin_mutex); + + /* Check for exit again, since we just released and + reacquired the admin mutex, before the next block_self + call (which would block forever if t has already + exited). */ + if (t->exited) + { + res = t->result; + break; + } } } diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 62048eaba..6400d2dd8 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -265,7 +265,31 @@ (pass-if "asyncs are still working 1" (asyncs-still-working?)) - ) + ;; scm_join_thread_timed has a SCM_TICK in the middle of it, + ;; to allow asyncs to run (including signal delivery). We + ;; used to have a bug whereby if the joined thread terminated + ;; at the same time as the joining thread is in this SCM_TICK, + ;; scm_join_thread_timed would not notice and would hang + ;; forever. So in this test we are setting up the following + ;; sequence of events. + ;; T=0 other thread is created and starts running + ;; T=2 main thread sets up an async that will sleep for 10 seconds + ;; T=2 main thread calls join-thread, which will... + ;; T=2 ...call the async, which starts sleeping + ;; T=5 other thread finishes its work and terminates + ;; T=7 async completes, main thread continues inside join-thread. + (pass-if "don't hang when joined thread terminates in SCM_TICK" + (let ((other-thread (make-thread sleep 5))) + (letrec ((delay-count 10) + (aproc (lambda () + (set! delay-count (- delay-count 1)) + (if (zero? delay-count) + (sleep 5) + (system-async-mark aproc))))) + (sleep 2) + (system-async-mark aproc) + (join-thread other-thread))) + #t)) ;; ;; thread cancellation -- cgit v1.2.3 From 34f3d47df9311852ba7eab6f8d1c36535c3774dd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 28 May 2009 14:49:33 +0200 Subject: add reader support for #; #` #' #, and #,@. fix bug in compile-and-load. * libguile/read.c (flush_ws, scm_read_commented_expression) (scm_read_sharp): Add support for commenting out expressions with #;. (scm_read_syntax, scm_read_sharp): Add support for #', #`, #, and #,@. * module/ice-9/boot-9.scm: Remove #' read-hash extension, which actually didn't do anything at all. It's been there since 1997, but no Guile code I've ever seen uses it, and it conflicts with #'x => (syntax x) from modern Scheme. * module/system/base/compile.scm (compile-and-load): Whoops, fix a number of bugs here. --- libguile/read.c | 83 ++++++++++++++++++++++++++++++++++++++++++ module/ice-9/boot-9.scm | 3 -- module/system/base/compile.scm | 6 +-- 3 files changed, 86 insertions(+), 6 deletions(-) (limited to 'libguile') diff --git a/libguile/read.c b/libguile/read.c index 47b80041e..a4db2ab41 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -182,6 +182,7 @@ static SCM *scm_read_hash_procedures; /* Read an SCSH block comment. */ static inline SCM scm_read_scsh_block_comment (int chr, SCM port); +static SCM scm_read_commented_expression (int chr, SCM port); /* Read from PORT until a delimiter (e.g., a whitespace) is read. Return zero if the whole token fits in BUF, non-zero otherwise. */ @@ -257,6 +258,9 @@ flush_ws (SCM port, const char *eoferr) case '!': scm_read_scsh_block_comment (c, port); break; + case ';': + scm_read_commented_expression (c, port); + break; default: scm_ungetc (c, port); return '#'; @@ -691,6 +695,65 @@ scm_read_quote (int chr, SCM port) return p; } +SCM_SYMBOL (sym_syntax, "syntax"); +SCM_SYMBOL (sym_quasisyntax, "quasisyntax"); +SCM_SYMBOL (sym_unsyntax, "unsyntax"); +SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing"); + +static SCM +scm_read_syntax (int chr, SCM port) +{ + SCM p; + long line = SCM_LINUM (port); + int column = SCM_COL (port) - 1; + + switch (chr) + { + case '`': + p = sym_quasisyntax; + break; + + case '\'': + p = sym_syntax; + break; + + case ',': + { + int c; + + c = scm_getc (port); + if ('@' == c) + p = sym_unsyntax_splicing; + else + { + scm_ungetc (c, port); + p = sym_unsyntax; + } + break; + } + + default: + fprintf (stderr, "%s: unhandled syntax character (%i)\n", + "scm_read_syntax", chr); + abort (); + } + + p = scm_cons2 (p, scm_read_expression (port), SCM_EOL); + if (SCM_RECORD_POSITIONS_P) + scm_whash_insert (scm_source_whash, p, + scm_make_srcprops (line, column, + SCM_FILENAME (port), + SCM_COPY_SOURCE_P + ? (scm_cons2 (SCM_CAR (p), + SCM_CAR (SCM_CDR (p)), + SCM_EOL)) + : SCM_UNDEFINED, + SCM_EOL)); + + + return p; +} + static inline SCM scm_read_semicolon_comment (int chr, SCM port) { @@ -853,6 +916,20 @@ scm_read_scsh_block_comment (int chr, SCM port) return SCM_UNSPECIFIED; } +static SCM +scm_read_commented_expression (int chr, SCM port) +{ + int c; + + c = flush_ws (port, (char *) NULL); + if (EOF == c) + scm_i_input_error ("read_commented_expression", port, + "no expression after #; comment", SCM_EOL); + scm_ungetc (c, port); + scm_read_expression (port); + return SCM_UNSPECIFIED; +} + static SCM scm_read_extended_symbol (int chr, SCM port) { @@ -1014,6 +1091,12 @@ scm_read_sharp (int chr, SCM port) return (scm_read_extended_symbol (chr, port)); case '!': return (scm_read_scsh_block_comment (chr, port)); + case ';': + return (scm_read_commented_expression (chr, port)); + case '`': + case '\'': + case ',': + return (scm_read_syntax (chr, port)); default: result = scm_read_sharp_extension (chr, port); if (scm_is_eq (result, SCM_UNSPECIFIED)) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 26ce1a905..44066312a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -961,9 +961,6 @@ ;;; Reader code for various "#c" forms. ;;; -(read-hash-extend #\' (lambda (c port) - (read port))) - (define read-eval? (make-fluid)) (fluid-set! read-eval? #f) (read-hash-extend #\. diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 74fb59852..f6522f735 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -107,9 +107,9 @@ port))) comp)) -(define* (compile-and-load file #:key (to 'value) (opts '())) - (read-and-compile (open-input-port file) - #:from lang #:to to #:opts opts)) +(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '())) + (read-and-compile (open-input-file file) + #:from from #:to to #:opts opts)) (define (compiled-file-name file) (let ((base (basename file)) -- cgit v1.2.3 From 1ee2c72eafaae5f91f4c899bc4b4853af5c16f28 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 May 2009 18:18:07 +0200 Subject: Import R6RS bytevectors and I/O ports from Guile-R6RS-Libs 0.2. * README: Document dependency on GNU libunistring. * benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add `benchmark/bytevectors.bm'. * configure.in: Make sure we have libunistring; update $LIBS. * libguile.h: Include "bytevectors.h" and "r6rs-ports.h". * libguile/Makefile.am (libguile_la_SOURCES): Add `bytevectors.c' and `r6rs-ports.c' (DOT_X_FILES): Add `bytevectors.x' and `r6rs-ports.x'. (DOT_DOC_FILES): Add `bytevectors.doc' and `r6rs-ports.doc'. (noinst_HEADERS): Add `ieee-754.h'. (modinclude_HEADERS): Add `bytevectors.h' and `r6rs-ports.h' * libguile/validate.h (SCM_VALIDATE_BYTEVECTOR): New macro. * module/Makefile.am (SOURCES): Add $(RNRS_SOURCES). (RNRS_SOURCES): New variable. * test-suite/Makefile.am (SCM_TESTS): Add `bytevectors.test' and `r6rs-ports.test'. --- README | 6 + benchmark-suite/Makefile.am | 1 + benchmark-suite/benchmarks/bytevectors.bm | 99 ++ configure.in | 7 + libguile.h | 4 +- libguile/Makefile.am | 26 +- libguile/bytevectors.c | 1978 +++++++++++++++++++++++++++++ libguile/bytevectors.h | 133 ++ libguile/ieee-754.h | 90 ++ libguile/r6rs-ports.c | 1118 ++++++++++++++++ libguile/r6rs-ports.h | 43 + libguile/validate.h | 5 +- module/Makefile.am | 7 +- module/rnrs/bytevector.scm | 84 ++ module/rnrs/io/ports.scm | 111 ++ test-suite/Makefile.am | 2 + test-suite/tests/bytevectors.test | 531 ++++++++ test-suite/tests/r6rs-ports.test | 455 +++++++ 18 files changed, 4688 insertions(+), 12 deletions(-) create mode 100644 benchmark-suite/benchmarks/bytevectors.bm create mode 100644 libguile/bytevectors.c create mode 100644 libguile/bytevectors.h create mode 100644 libguile/ieee-754.h create mode 100644 libguile/r6rs-ports.c create mode 100644 libguile/r6rs-ports.h create mode 100644 module/rnrs/bytevector.scm create mode 100644 module/rnrs/io/ports.scm create mode 100644 test-suite/tests/bytevectors.test create mode 100644 test-suite/tests/r6rs-ports.test (limited to 'libguile') diff --git a/README b/README index 9993fcfaf..4950229df 100644 --- a/README +++ b/README @@ -61,6 +61,12 @@ Guile requires the following external packages: libltdl is used for loading extensions at run-time. It is available from http://www.gnu.org/software/libtool/ + - GNU libunistring + + libunistring is used for Unicode string operations, such as the + `utf*->string' procedures. It is available from + http://www.gnu.org/software/libunistring/ . + Special Instructions For Some Systems ===================================== diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index e65e8bcb2..dcadd5869 100644 --- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -1,4 +1,5 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \ + benchmarks/bytevectors.bm \ benchmarks/continuations.bm \ benchmarks/if.bm \ benchmarks/logand.bm \ diff --git a/benchmark-suite/benchmarks/bytevectors.bm b/benchmark-suite/benchmarks/bytevectors.bm new file mode 100644 index 000000000..9547a71df --- /dev/null +++ b/benchmark-suite/benchmarks/bytevectors.bm @@ -0,0 +1,99 @@ +;;; -*- mode: scheme; coding: latin-1; -*- +;;; R6RS Byte Vectors. +;;; +;;; Copyright 2009 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks bytevector) + :use-module (rnrs bytevector) + :use-module (srfi srfi-4) + :use-module (benchmark-suite lib)) + +(define bv (make-bytevector 16384)) + +(define %native-endianness + (native-endianness)) + +(define %foreign-endianness + (if (eq? (native-endianness) (endianness little)) + (endianness big) + (endianness little))) + +(define u8v (make-u8vector 16384)) +(define u16v (make-u16vector 8192)) +(define u32v (make-u32vector 4196)) +(define u64v (make-u64vector 2048)) + + +(with-benchmark-prefix "ref/set!" + + (benchmark "bytevector-u8-ref" 1000000 + (bytevector-u8-ref bv 0)) + + (benchmark "bytevector-u16-ref (foreign)" 1000000 + (bytevector-u16-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u16-ref (native)" 1000000 + (bytevector-u16-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u16-native-ref" 1000000 + (bytevector-u16-native-ref bv 0)) + + (benchmark "bytevector-u32-ref (foreign)" 1000000 + (bytevector-u32-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u32-ref (native)" 1000000 + (bytevector-u32-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u32-native-ref" 1000000 + (bytevector-u32-native-ref bv 0)) + + (benchmark "bytevector-u64-ref (foreign)" 1000000 + (bytevector-u64-ref bv 0 %foreign-endianness)) + + (benchmark "bytevector-u64-ref (native)" 1000000 + (bytevector-u64-ref bv 0 %native-endianness)) + + (benchmark "bytevector-u64-native-ref" 1000000 + (bytevector-u16-native-ref bv 0))) + + +(with-benchmark-prefix "lists" + + (benchmark "bytevector->u8-list" 2000 + (bytevector->u8-list bv)) + + (benchmark "bytevector->uint-list 16-bit" 2000 + (bytevector->uint-list bv (native-endianness) 2)) + + (benchmark "bytevector->uint-list 64-bit" 2000 + (bytevector->uint-list bv (native-endianness) 8))) + + +(with-benchmark-prefix "SRFI-4" ;; for comparison + + (benchmark "u8vector-ref" 1000000 + (u8vector-ref u8v 0)) + + (benchmark "u16vector-ref" 1000000 + (u16vector-ref u16v 0)) + + (benchmark "u32vector-ref" 1000000 + (u32vector-ref u32v 0)) + + (benchmark "u64vector-ref" 1000000 + (u64vector-ref u64v 0))) diff --git a/configure.in b/configure.in index 07c476686..6568e524f 100644 --- a/configure.in +++ b/configure.in @@ -836,6 +836,13 @@ AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], [], [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])]) +dnl GNU libunistring tests. +if test "x$LTLIBUNISTRING" != "x"; then + LIBS="$LTLIBUNISTRING $LIBS" +else + AC_MSG_ERROR([GNU libunistring is required, please install it.]) +fi + dnl i18n tests #AC_CHECK_HEADERS([libintl.h]) #AC_CHECK_FUNCS(gettext) diff --git a/libguile.h b/libguile.h index 40122dfa2..6a6d232f9 100644 --- a/libguile.h +++ b/libguile.h @@ -1,7 +1,7 @@ #ifndef SCM_LIBGUILE_H #define SCM_LIBGUILE_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -32,6 +32,7 @@ extern "C" { #include "libguile/arbiters.h" #include "libguile/async.h" #include "libguile/boolean.h" +#include "libguile/bytevectors.h" #include "libguile/chars.h" #include "libguile/continuations.h" #include "libguile/dynl.h" @@ -75,6 +76,7 @@ extern "C" { #include "libguile/procprop.h" #include "libguile/properties.h" #include "libguile/procs.h" +#include "libguile/r6rs-ports.h" #include "libguile/ramap.h" #include "libguile/random.h" #include "libguile/read.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 63f2ef2bf..fcf197a54 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -106,7 +106,8 @@ guile_LDFLAGS = $(GUILE_CFLAGS) libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS) libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ - chars.c continuations.c convert.c debug.c deprecation.c \ + bytevectors.c chars.c continuations.c \ + convert.c debug.c deprecation.c \ deprecated.c discouraged.c dynwind.c eq.c error.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \ futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \ @@ -115,7 +116,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ guardians.c hash.c hashtab.c hooks.c init.c inline.c \ ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \ modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ - print.c procprop.c procs.c properties.c random.c rdelim.c read.c \ + print.c procprop.c procs.c properties.c \ + r6rs-ports.c random.c rdelim.c read.c \ root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \ stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \ strorder.c strports.c struct.c symbols.c threads.c null-threads.c \ @@ -134,7 +136,8 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \ -module -L$(builddir) -lguile \ -version-info @LIBGUILE_I18N_INTERFACE@ -DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ +DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x \ + bytevectors.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ dynl.x dynwind.x eq.x error.x eval.x evalext.x \ extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \ @@ -143,7 +146,8 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \ list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \ - properties.x random.x rdelim.x read.x root.x rw.x scmsigs.x \ + properties.x r6rs-ports.x random.x rdelim.x \ + read.x root.x rw.x scmsigs.x \ script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x \ stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x \ strports.x struct.x symbols.x threads.x throw.x values.x \ @@ -155,7 +159,8 @@ DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ - boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \ + boolean.doc bytevectors.doc chars.doc \ + continuations.doc debug.doc deprecation.doc \ deprecated.doc discouraged.doc dynl.doc dynwind.doc \ eq.doc error.doc eval.doc evalext.doc \ extensions.doc feature.doc fluids.doc fports.doc futures.doc \ @@ -165,7 +170,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \ list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \ objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \ - procprop.doc procs.doc properties.doc random.doc rdelim.doc \ + procprop.doc procs.doc properties.doc r6rs-ports.doc \ + random.doc rdelim.doc \ read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc \ smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc \ strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc \ @@ -204,7 +210,7 @@ install-exec-hook: ## working. noinst_HEADERS = convert.i.c \ conv-integer.i.c conv-uinteger.i.c \ - eval.i.c \ + eval.i.c ieee-754.h \ srfi-4.i.c \ quicksort.i.c \ win32-uname.h win32-dirent.h win32-socket.h \ @@ -223,7 +229,8 @@ pkginclude_HEADERS = # These are headers visible as . modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ - boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \ + boolean.h bytevectors.h chars.h continuations.h convert.h \ + debug.h debug-malloc.h \ deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \ eq.h error.h eval.h evalext.h extensions.h \ feature.h filesys.h fluids.h fports.h futures.h gc.h \ @@ -232,7 +239,8 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \ keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \ - posix.h regex-posix.h print.h procprop.h procs.h properties.h \ + posix.h r6rs-ports.h regex-posix.h print.h \ + procprop.h procs.h properties.h \ random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \ script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \ stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \ diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c new file mode 100644 index 000000000..4c3a353a1 --- /dev/null +++ b/libguile/bytevectors.c @@ -0,0 +1,1978 @@ +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include + +#include "libguile/_scm.h" +#include "libguile/bytevectors.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/ieee-754.h" + +#include +#include +#include + +#ifdef HAVE_LIMITS_H +# include +#else +/* Assuming 32-bit longs. */ +# define ULONG_MAX 4294967295UL +#endif + +#include + + + +/* Utilities. */ + +/* Convenience macros. These are used by the various templates (macros) that + are parameterized by integer signedness. */ +#define INT8_T_signed scm_t_int8 +#define INT8_T_unsigned scm_t_uint8 +#define INT16_T_signed scm_t_int16 +#define INT16_T_unsigned scm_t_uint16 +#define INT32_T_signed scm_t_int32 +#define INT32_T_unsigned scm_t_uint32 +#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L)) +#define is_unsigned_int8(_x) ((_x) <= 255UL) +#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L)) +#define is_unsigned_int16(_x) ((_x) <= 65535UL) +#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L)) +#define is_unsigned_int32(_x) ((_x) <= 4294967295UL) +#define SIGNEDNESS_signed 1 +#define SIGNEDNESS_unsigned 0 + +#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign +#define INT_SWAP(_size) bswap_ ## _size +#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size +#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign + + +#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \ + unsigned c_len, c_index; \ + _sign char *c_bv; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + c_index = scm_to_uint (index); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \ + scm_out_of_range (FUNC_NAME, index); + +/* Template for fixed-size integer access (only 8, 16 or 32-bit). */ +#define INTEGER_REF(_len, _sign) \ + SCM result; \ + \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + { \ + INT_TYPE (_len, _sign) c_result; \ + \ + memcpy (&c_result, &c_bv[c_index], (_len) / 8); \ + if (!scm_is_eq (endianness, native_endianness)) \ + c_result = INT_SWAP (_len) (c_result); \ + \ + result = SCM_I_MAKINUM (c_result); \ + } \ + \ + return result; + +/* Template for fixed-size integer access using the native endianness. */ +#define INTEGER_NATIVE_REF(_len, _sign) \ + SCM result; \ + \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + { \ + INT_TYPE (_len, _sign) c_result; \ + \ + memcpy (&c_result, &c_bv[c_index], (_len) / 8); \ + result = SCM_I_MAKINUM (c_result); \ + } \ + \ + return result; + +/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */ +#define INTEGER_SET(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + { \ + _sign long c_value; \ + INT_TYPE (_len, _sign) c_value_short; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + scm_wrong_type_arg (FUNC_NAME, 3, value); \ + \ + c_value = SCM_I_INUM (value); \ + if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + c_value_short = (INT_TYPE (_len, _sign)) c_value; \ + if (!scm_is_eq (endianness, native_endianness)) \ + c_value_short = INT_SWAP (_len) (c_value_short); \ + \ + memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \ + } \ + \ + return SCM_UNSPECIFIED; + +/* Template for fixed-size integer modification using the native + endianness. */ +#define INTEGER_NATIVE_SET(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + { \ + _sign long c_value; \ + INT_TYPE (_len, _sign) c_value_short; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + scm_wrong_type_arg (FUNC_NAME, 3, value); \ + \ + c_value = SCM_I_INUM (value); \ + if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + c_value_short = (INT_TYPE (_len, _sign)) c_value; \ + \ + memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \ + } \ + \ + return SCM_UNSPECIFIED; + + + +/* Bytevector type. */ + +SCM_GLOBAL_SMOB (scm_tc16_bytevector, "r6rs-bytevector", 0); + +#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \ + SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len)) +#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \ + SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf)) + +/* The empty bytevector. */ +SCM scm_null_bytevector = SCM_UNSPECIFIED; + + +static inline SCM +make_bytevector_from_buffer (unsigned len, signed char *contents) +{ + /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */ + SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents); +} + +static inline SCM +make_bytevector (unsigned len) +{ + SCM bv; + + if (SCM_UNLIKELY (len == 0)) + bv = scm_null_bytevector; + else + { + signed char *contents = NULL; + + if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)) + contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR); + + bv = make_bytevector_from_buffer (len, contents); + } + + return bv; +} + +/* Return a new bytevector of size LEN octets. */ +SCM +scm_c_make_bytevector (unsigned len) +{ + return (make_bytevector (len)); +} + +/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to + by CONTENTS must have been allocated using `scm_gc_malloc ()'. */ +SCM +scm_c_take_bytevector (signed char *contents, unsigned len) +{ + SCM bv; + + if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))) + { + /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */ + signed char *c_bv; + + bv = make_bytevector (len); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + memcpy (c_bv, contents, len); + scm_gc_free (contents, len, SCM_GC_BYTEVECTOR); + } + else + bv = make_bytevector_from_buffer (len, contents); + + return bv; +} + +/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current + size) and return BV. */ +SCM +scm_i_shrink_bytevector (SCM bv, unsigned c_new_len) +{ + if (!SCM_BYTEVECTOR_INLINE_P (bv)) + { + unsigned c_len; + signed char *c_bv, *c_new_bv; + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len); + + if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len)) + { + /* Copy to the in-line buffer and free the current buffer. */ + c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv); + memcpy (c_new_bv, c_bv, c_new_len); + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + /* Resize the existing buffer. */ + c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len, + SCM_GC_BYTEVECTOR); + SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv); + } + } + + return bv; +} + +SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector, + bv, port, pstate) +{ + unsigned c_len, i; + unsigned char *c_bv; + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + scm_puts ("#vu8(", port); + for (i = 0; i < c_len; i++) + { + if (i > 0) + scm_putc (' ', port); + + scm_uintprint (c_bv[i], 10, port); + } + + scm_putc (')', port); + + /* Make GCC think we use it. */ + scm_remember_upto_here ((SCM) pstate); + + return 1; +} + +SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv) +{ + + if (!SCM_BYTEVECTOR_INLINE_P (bv)) + { + unsigned c_len; + signed char *c_bv; + + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + + return 0; +} + + + +/* General operations. */ + +SCM_SYMBOL (scm_sym_big, "big"); +SCM_SYMBOL (scm_sym_little, "little"); + +SCM scm_endianness_big, scm_endianness_little; + +/* Host endianness (a symbol). */ +static SCM native_endianness = SCM_UNSPECIFIED; + +/* Byte-swapping. */ +#ifndef bswap_24 +# define bswap_24(_x) \ + ((((_x) & 0xff0000) >> 16) | \ + (((_x) & 0x00ff00)) | \ + (((_x) & 0x0000ff) << 16)) +#endif + + +SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0, + (void), + "Return a symbol denoting the machine's native endianness.") +#define FUNC_NAME s_scm_native_endianness +{ + return native_endianness; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0, + (SCM obj), + "Return true if @var{obj} is a bytevector.") +#define FUNC_NAME s_scm_bytevector_p +{ + return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector, + obj))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0, + (SCM len, SCM fill), + "Return a newly allocated bytevector of @var{len} bytes, " + "optionally filled with @var{fill}.") +#define FUNC_NAME s_scm_make_bytevector +{ + SCM bv; + unsigned c_len; + signed char c_fill = '\0'; + + SCM_VALIDATE_UINT_COPY (1, len, c_len); + if (fill != SCM_UNDEFINED) + { + int value; + + value = scm_to_int (fill); + if (SCM_UNLIKELY ((value < -128) || (value > 255))) + scm_out_of_range (FUNC_NAME, fill); + c_fill = (signed char) value; + } + + bv = make_bytevector (c_len); + if (fill != SCM_UNDEFINED) + { + unsigned i; + signed char *contents; + + contents = SCM_BYTEVECTOR_CONTENTS (bv); + for (i = 0; i < c_len; i++) + contents[i] = c_fill; + } + + return bv; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0, + (SCM bv), + "Return the length (in bytes) of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_length +{ + SCM_VALIDATE_BYTEVECTOR (1, bv); + + return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0, + (SCM bv1, SCM bv2), + "Return is @var{bv1} equals to @var{bv2}---i.e., if they " + "have the same length and contents.") +#define FUNC_NAME s_scm_bytevector_eq_p +{ + SCM result = SCM_BOOL_F; + unsigned c_len1, c_len2; + + SCM_VALIDATE_BYTEVECTOR (1, bv1); + SCM_VALIDATE_BYTEVECTOR (2, bv2); + + c_len1 = SCM_BYTEVECTOR_LENGTH (bv1); + c_len2 = SCM_BYTEVECTOR_LENGTH (bv2); + + if (c_len1 == c_len2) + { + signed char *c_bv1, *c_bv2; + + c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1); + c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2); + + result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1)); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0, + (SCM bv, SCM fill), + "Fill bytevector @var{bv} with @var{fill}, a byte.") +#define FUNC_NAME s_scm_bytevector_fill_x +{ + unsigned c_len, i; + signed char *c_bv, c_fill; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + c_fill = scm_to_int8 (fill); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + for (i = 0; i < c_len; i++) + c_bv[i] = c_fill; + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0, + (SCM source, SCM source_start, SCM target, SCM target_start, + SCM len), + "Copy @var{len} bytes from @var{source} into @var{target}, " + "starting reading from @var{source_start} (a positive index " + "within @var{source}) and start writing at " + "@var{target_start}.") +#define FUNC_NAME s_scm_bytevector_copy_x +{ + unsigned c_len, c_source_len, c_target_len; + unsigned c_source_start, c_target_start; + signed char *c_source, *c_target; + + SCM_VALIDATE_BYTEVECTOR (1, source); + SCM_VALIDATE_BYTEVECTOR (3, target); + + c_len = scm_to_uint (len); + c_source_start = scm_to_uint (source_start); + c_target_start = scm_to_uint (target_start); + + c_source = SCM_BYTEVECTOR_CONTENTS (source); + c_target = SCM_BYTEVECTOR_CONTENTS (target); + c_source_len = SCM_BYTEVECTOR_LENGTH (source); + c_target_len = SCM_BYTEVECTOR_LENGTH (target); + + if (SCM_UNLIKELY (c_source_start + c_len > c_source_len)) + scm_out_of_range (FUNC_NAME, source_start); + if (SCM_UNLIKELY (c_target_start + c_len > c_target_len)) + scm_out_of_range (FUNC_NAME, target_start); + + memcpy (c_target + c_target_start, + c_source + c_source_start, + c_len); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0, + (SCM bv), + "Return a newly allocated copy of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_copy +{ + SCM copy; + unsigned c_len; + signed char *c_bv, *c_copy; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = SCM_BYTEVECTOR_CONTENTS (bv); + + copy = make_bytevector (c_len); + c_copy = SCM_BYTEVECTOR_CONTENTS (copy); + memcpy (c_copy, c_bv, c_len); + + return copy; +} +#undef FUNC_NAME + + +/* Operations on bytes and octets. */ + +SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0, + (SCM bv, SCM index), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_ref +{ + INTEGER_NATIVE_REF (8, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0, + (SCM bv, SCM index), + "Return the byte located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_s8_ref +{ + INTEGER_NATIVE_REF (8, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_set_x +{ + INTEGER_NATIVE_SET (8, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Return the octet located at @var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_u8_set_x +{ + INTEGER_NATIVE_SET (8, signed); +} +#undef FUNC_NAME + +#undef OCTET_ACCESSOR_PROLOGUE + + +SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0, + (SCM bv), + "Return a newly allocated list of octets containing the " + "contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_u8_list +{ + SCM lst, pair; + unsigned c_len, i; + unsigned char *c_bv; + + SCM_VALIDATE_BYTEVECTOR (1, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED); + for (i = 0, pair = lst; + i < c_len; + i++, pair = SCM_CDR (pair)) + { + SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i])); + } + + return lst; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0, + (SCM lst), + "Turn @var{lst}, a list of octets, into a bytevector.") +#define FUNC_NAME s_scm_u8_list_to_bytevector +{ + SCM bv, item; + long c_len, i; + unsigned char *c_bv; + + SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); + + bv = make_bytevector (c_len); + c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + + for (i = 0; i < c_len; lst = SCM_CDR (lst), i++) + { + item = SCM_CAR (lst); + + if (SCM_LIKELY (SCM_I_INUMP (item))) + { + long c_item; + + c_item = SCM_I_INUM (item); + if (SCM_LIKELY ((c_item >= 0) && (c_item < 256))) + c_bv[i] = (unsigned char) c_item; + else + goto type_error; + } + else + goto type_error; + } + + return bv; + + type_error: + scm_wrong_type_arg (FUNC_NAME, 1, item); + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +/* Compute the two's complement of VALUE (a positive integer) on SIZE octets + using (2^(SIZE * 8) - VALUE). */ +static inline void +twos_complement (mpz_t value, size_t size) +{ + unsigned long bit_count; + + /* We expect BIT_COUNT to fit in a unsigned long thanks to the range + checking on SIZE performed earlier. */ + bit_count = (unsigned long) size << 3UL; + + if (SCM_LIKELY (bit_count < sizeof (unsigned long))) + mpz_ui_sub (value, 1UL << bit_count, value); + else + { + mpz_t max; + + mpz_init (max); + mpz_ui_pow_ui (max, 2, bit_count); + mpz_sub (value, max, value); + mpz_clear (max); + } +} + +static inline SCM +bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p, + SCM endianness) +{ + SCM result; + mpz_t c_mpz; + int c_endianness, negative_p = 0; + + if (signed_p) + { + if (scm_is_eq (endianness, scm_sym_big)) + negative_p = c_bv[0] & 0x80; + else + negative_p = c_bv[c_size - 1] & 0x80; + } + + c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1; + + mpz_init (c_mpz); + mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */, + c_size /* word is C_SIZE-byte long */, + c_endianness, + 0 /* nails */, c_bv); + + if (signed_p && negative_p) + { + twos_complement (c_mpz, c_size); + mpz_neg (c_mpz, c_mpz); + } + + result = scm_from_mpz (c_mpz); + mpz_clear (c_mpz); /* FIXME: Needed? */ + + return result; +} + +static inline int +bytevector_large_set (char *c_bv, size_t c_size, int signed_p, + SCM value, SCM endianness) +{ + mpz_t c_mpz; + int c_endianness, c_sign, err = 0; + + c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1; + + mpz_init (c_mpz); + scm_to_mpz (value, c_mpz); + + c_sign = mpz_sgn (c_mpz); + if (c_sign < 0) + { + if (SCM_LIKELY (signed_p)) + { + mpz_neg (c_mpz, c_mpz); + twos_complement (c_mpz, c_size); + } + else + { + err = -1; + goto finish; + } + } + + if (c_sign == 0) + /* Zero. */ + memset (c_bv, 0, c_size); + else + { + size_t word_count, value_size; + + value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size); + if (SCM_UNLIKELY (value_size > c_size)) + { + err = -2; + goto finish; + } + + + mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */, + c_size, c_endianness, + 0 /* nails */, c_mpz); + if (SCM_UNLIKELY (word_count != 1)) + /* Shouldn't happen since we already checked with VALUE_SIZE. */ + abort (); + } + + finish: + mpz_clear (c_mpz); + + return err; +} + +#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \ + unsigned long c_len, c_index, c_size; \ + char *c_bv; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + c_index = scm_to_ulong (index); \ + c_size = scm_to_ulong (size); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + /* C_SIZE must have its 3 higher bits set to zero so that \ + multiplying it by 8 yields a number that fits in an \ + unsigned long. */ \ + if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \ + scm_out_of_range (FUNC_NAME, size); \ + if (SCM_UNLIKELY (c_index + c_size > c_len)) \ + scm_out_of_range (FUNC_NAME, index); + + +/* Template of an integer reference function. */ +#define GENERIC_INTEGER_REF(_sign) \ + SCM result; \ + \ + if (c_size < 3) \ + { \ + int swap; \ + _sign int value; \ + \ + swap = !scm_is_eq (endianness, native_endianness); \ + switch (c_size) \ + { \ + case 1: \ + { \ + _sign char c_value8; \ + memcpy (&c_value8, c_bv, 1); \ + value = c_value8; \ + } \ + break; \ + case 2: \ + { \ + INT_TYPE (16, _sign) c_value16; \ + memcpy (&c_value16, c_bv, 2); \ + if (swap) \ + value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \ + else \ + value = c_value16; \ + } \ + break; \ + default: \ + abort (); \ + } \ + \ + result = SCM_I_MAKINUM ((_sign int) value); \ + } \ + else \ + result = bytevector_large_ref ((char *) c_bv, \ + c_size, SIGNEDNESS (_sign), \ + endianness); \ + \ + return result; + +static inline SCM +bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness) +{ + GENERIC_INTEGER_REF (signed); +} + +static inline SCM +bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness) +{ + GENERIC_INTEGER_REF (unsigned); +} + + +/* Template of an integer assignment function. */ +#define GENERIC_INTEGER_SET(_sign) \ + if (c_size < 3) \ + { \ + _sign int c_value; \ + \ + if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \ + goto range_error; \ + \ + c_value = SCM_I_INUM (value); \ + switch (c_size) \ + { \ + case 1: \ + if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \ + { \ + _sign char c_value8; \ + c_value8 = (_sign char) c_value; \ + memcpy (c_bv, &c_value8, 1); \ + } \ + else \ + goto range_error; \ + break; \ + \ + case 2: \ + if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \ + { \ + int swap; \ + INT_TYPE (16, _sign) c_value16; \ + \ + swap = !scm_is_eq (endianness, native_endianness); \ + \ + if (swap) \ + c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \ + else \ + c_value16 = c_value; \ + \ + memcpy (c_bv, &c_value16, 2); \ + } \ + else \ + goto range_error; \ + break; \ + \ + default: \ + abort (); \ + } \ + } \ + else \ + { \ + int err; \ + \ + err = bytevector_large_set (c_bv, c_size, \ + SIGNEDNESS (_sign), \ + value, endianness); \ + if (err) \ + goto range_error; \ + } \ + \ + return; \ + \ + range_error: \ + scm_out_of_range (FUNC_NAME, value); \ + return; + +static inline void +bytevector_signed_set (char *c_bv, size_t c_size, + SCM value, SCM endianness, + const char *func_name) +#define FUNC_NAME func_name +{ + GENERIC_INTEGER_SET (signed); +} +#undef FUNC_NAME + +static inline void +bytevector_unsigned_set (char *c_bv, size_t c_size, + SCM value, SCM endianness, + const char *func_name) +#define FUNC_NAME func_name +{ + GENERIC_INTEGER_SET (unsigned); +} +#undef FUNC_NAME + +#undef GENERIC_INTEGER_SET +#undef GENERIC_INTEGER_REF + + +SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0, + (SCM bv, SCM index, SCM endianness, SCM size), + "Return the @var{size}-octet long unsigned integer at index " + "@var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_uint_ref +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); + + return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0, + (SCM bv, SCM index, SCM endianness, SCM size), + "Return the @var{size}-octet long unsigned integer at index " + "@var{index} in @var{bv}.") +#define FUNC_NAME s_scm_bytevector_sint_ref +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); + + return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness, SCM size), + "Set the @var{size}-octet long unsigned integer at @var{index} " + "to @var{value}.") +#define FUNC_NAME s_scm_bytevector_uint_set_x +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); + + bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness, + FUNC_NAME); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness, SCM size), + "Set the @var{size}-octet long signed integer at @var{index} " + "to @var{value}.") +#define FUNC_NAME s_scm_bytevector_sint_set_x +{ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); + + bytevector_signed_set (&c_bv[c_index], c_size, value, endianness, + FUNC_NAME); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* Operations on integers of arbitrary size. */ + +#define INTEGERS_TO_LIST(_sign) \ + SCM lst, pair; \ + size_t i, c_len, c_size; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + c_size = scm_to_uint (size); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + if (SCM_UNLIKELY (c_len == 0)) \ + lst = SCM_EOL; \ + else if (SCM_UNLIKELY (c_len < c_size)) \ + scm_out_of_range (FUNC_NAME, size); \ + else \ + { \ + const char *c_bv; \ + \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + lst = scm_make_list (scm_from_uint (c_len / c_size), \ + SCM_UNSPECIFIED); \ + for (i = 0, pair = lst; \ + i <= c_len - c_size; \ + i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \ + { \ + SCM_SETCAR (pair, \ + bytevector_ ## _sign ## _ref (c_bv, c_size, \ + endianness)); \ + } \ + } \ + \ + return lst; + +SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list", + 3, 0, 0, + (SCM bv, SCM endianness, SCM size), + "Return a list of signed integers of @var{size} octets " + "representing the contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_sint_list +{ + INTEGERS_TO_LIST (signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list", + 3, 0, 0, + (SCM bv, SCM endianness, SCM size), + "Return a list of unsigned integers of @var{size} octets " + "representing the contents of @var{bv}.") +#define FUNC_NAME s_scm_bytevector_to_uint_list +{ + INTEGERS_TO_LIST (unsigned); +} +#undef FUNC_NAME + +#undef INTEGER_TO_LIST + + +#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \ + SCM bv; \ + long c_len; \ + size_t c_size; \ + char *c_bv, *c_bv_ptr; \ + \ + SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + c_size = scm_to_uint (size); \ + \ + if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \ + scm_out_of_range (FUNC_NAME, size); \ + \ + bv = make_bytevector (c_len * c_size); \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + for (c_bv_ptr = c_bv; \ + !scm_is_null (lst); \ + lst = SCM_CDR (lst), c_bv_ptr += c_size) \ + { \ + bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \ + SCM_CAR (lst), endianness, \ + FUNC_NAME); \ + } \ + \ + return bv; + + +SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector", + 3, 0, 0, + (SCM lst, SCM endianness, SCM size), + "Return a bytevector containing the unsigned integers " + "listed in @var{lst} and encoded on @var{size} octets " + "according to @var{endianness}.") +#define FUNC_NAME s_scm_uint_list_to_bytevector +{ + INTEGER_LIST_TO_BYTEVECTOR (unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector", + 3, 0, 0, + (SCM lst, SCM endianness, SCM size), + "Return a bytevector containing the signed integers " + "listed in @var{lst} and encoded on @var{size} octets " + "according to @var{endianness}.") +#define FUNC_NAME s_scm_sint_list_to_bytevector +{ + INTEGER_LIST_TO_BYTEVECTOR (signed); +} +#undef FUNC_NAME + +#undef INTEGER_LIST_TO_BYTEVECTOR + + + +/* Operations on 16-bit integers. */ + +SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u16_ref +{ + INTEGER_REF (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 16-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s16_ref +{ + INTEGER_REF (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u16_native_ref +{ + INTEGER_NATIVE_REF (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 16-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s16_native_ref +{ + INTEGER_NATIVE_REF (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u16_set_x +{ + INTEGER_SET (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s16_set_x +{ + INTEGER_SET (16, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u16_native_set_x +{ + INTEGER_NATIVE_SET (16, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s16_native_set_x +{ + INTEGER_NATIVE_SET (16, signed); +} +#undef FUNC_NAME + + + +/* Operations on 32-bit integers. */ + +/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold + arbitrary 32-bit integers. Thus we fall back to using the + `large_{ref,set}' variants on 32-bit machines. */ + +#define LARGE_INTEGER_REF(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), endianness)); + +#define LARGE_INTEGER_SET(_len, _sign) \ + int err; \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + SCM_VALIDATE_SYMBOL (4, endianness); \ + \ + err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), value, endianness); \ + if (SCM_UNLIKELY (err)) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + return SCM_UNSPECIFIED; + +#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ + return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), native_endianness)); + +#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \ + int err; \ + INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + \ + err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ + SIGNEDNESS (_sign), value, \ + native_endianness); \ + if (SCM_UNLIKELY (err)) \ + scm_out_of_range (FUNC_NAME, value); \ + \ + return SCM_UNSPECIFIED; + + +SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u32_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_REF (32, unsigned); +#else + LARGE_INTEGER_REF (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 32-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s32_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_REF (32, signed); +#else + LARGE_INTEGER_REF (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u32_native_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_REF (32, unsigned); +#else + LARGE_INTEGER_NATIVE_REF (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 32-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s32_native_ref +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_REF (32, signed); +#else + LARGE_INTEGER_NATIVE_REF (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u32_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_SET (32, unsigned); +#else + LARGE_INTEGER_SET (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s32_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_SET (32, signed); +#else + LARGE_INTEGER_SET (32, signed); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u32_native_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_SET (32, unsigned); +#else + LARGE_INTEGER_NATIVE_SET (32, unsigned); +#endif +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s32_native_set_x +{ +#if SIZEOF_VOID_P > 4 + INTEGER_NATIVE_SET (32, signed); +#else + LARGE_INTEGER_NATIVE_SET (32, signed); +#endif +} +#undef FUNC_NAME + + + +/* Operations on 64-bit integers. */ + +/* For 64-bit integers, we use only the `large_{ref,set}' variant. */ + +SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_u64_ref +{ + LARGE_INTEGER_REF (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the signed 64-bit integer from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_s64_ref +{ + LARGE_INTEGER_REF (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u64_native_ref +{ + LARGE_INTEGER_NATIVE_REF (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the unsigned 64-bit integer from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s64_native_ref +{ + LARGE_INTEGER_NATIVE_REF (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_u64_set_x +{ + LARGE_INTEGER_SET (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_s64_set_x +{ + LARGE_INTEGER_SET (64, signed); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the unsigned integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_u64_native_set_x +{ + LARGE_INTEGER_NATIVE_SET (64, unsigned); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the signed integer @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_s64_native_set_x +{ + LARGE_INTEGER_NATIVE_SET (64, signed); +} +#undef FUNC_NAME + + + +/* Operations on IEEE-754 numbers. */ + +/* There are two possible word endians, visible in glibc's . + However, in R6RS, when the endianness is `little', little endian is + assumed for both the byte order and the word order. This is clear from + Section 2.1 of R6RS-lib (in response to + http://www.r6rs.org/formal-comments/comment-187.txt). */ + + +/* Convert to/from a floating-point number with different endianness. This + method is probably not the most efficient but it should be portable. */ + +static inline void +float_to_foreign_endianness (union scm_ieee754_float *target, + float source) +{ + union scm_ieee754_float src; + + src.f = source; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + target->little_endian.negative = src.big_endian.negative; + target->little_endian.exponent = src.big_endian.exponent; + target->little_endian.mantissa = src.big_endian.mantissa; +#else + target->big_endian.negative = src.little_endian.negative; + target->big_endian.exponent = src.little_endian.exponent; + target->big_endian.mantissa = src.little_endian.mantissa; +#endif +} + +static inline float +float_from_foreign_endianness (const union scm_ieee754_float *source) +{ + union scm_ieee754_float result; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + result.big_endian.negative = source->little_endian.negative; + result.big_endian.exponent = source->little_endian.exponent; + result.big_endian.mantissa = source->little_endian.mantissa; +#else + result.little_endian.negative = source->big_endian.negative; + result.little_endian.exponent = source->big_endian.exponent; + result.little_endian.mantissa = source->big_endian.mantissa; +#endif + + return (result.f); +} + +static inline void +double_to_foreign_endianness (union scm_ieee754_double *target, + double source) +{ + union scm_ieee754_double src; + + src.d = source; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + target->little_little_endian.negative = src.big_endian.negative; + target->little_little_endian.exponent = src.big_endian.exponent; + target->little_little_endian.mantissa0 = src.big_endian.mantissa0; + target->little_little_endian.mantissa1 = src.big_endian.mantissa1; +#else + target->big_endian.negative = src.little_little_endian.negative; + target->big_endian.exponent = src.little_little_endian.exponent; + target->big_endian.mantissa0 = src.little_little_endian.mantissa0; + target->big_endian.mantissa1 = src.little_little_endian.mantissa1; +#endif +} + +static inline double +double_from_foreign_endianness (const union scm_ieee754_double *source) +{ + union scm_ieee754_double result; + +#ifdef WORDS_BIGENDIAN + /* Assuming little endian for both byte and word order. */ + result.big_endian.negative = source->little_little_endian.negative; + result.big_endian.exponent = source->little_little_endian.exponent; + result.big_endian.mantissa0 = source->little_little_endian.mantissa0; + result.big_endian.mantissa1 = source->little_little_endian.mantissa1; +#else + result.little_little_endian.negative = source->big_endian.negative; + result.little_little_endian.exponent = source->big_endian.exponent; + result.little_little_endian.mantissa0 = source->big_endian.mantissa0; + result.little_little_endian.mantissa1 = source->big_endian.mantissa1; +#endif + + return (result.d); +} + +/* Template macros to abstract over doubles and floats. + XXX: Guile can only convert to/from doubles. */ +#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type +#define IEEE754_TO_SCM(_c_type) scm_from_double +#define IEEE754_FROM_SCM(_c_type) scm_to_double +#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \ + _c_type ## _from_foreign_endianness +#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \ + _c_type ## _to_foreign_endianness + + +/* Templace getters and setters. */ + +#define IEEE754_ACCESSOR_PROLOGUE(_type) \ + INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed); + +#define IEEE754_REF(_type) \ + _type c_result; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_SYMBOL (3, endianness); \ + \ + if (scm_is_eq (endianness, native_endianness)) \ + memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ + else \ + { \ + IEEE754_UNION (_type) c_raw; \ + \ + memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \ + c_result = \ + IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \ + } \ + \ + return (IEEE754_TO_SCM (_type) (c_result)); + +#define IEEE754_NATIVE_REF(_type) \ + _type c_result; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + \ + memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ + return (IEEE754_TO_SCM (_type) (c_result)); + +#define IEEE754_SET(_type) \ + _type c_value; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_REAL (3, value); \ + SCM_VALIDATE_SYMBOL (4, endianness); \ + c_value = IEEE754_FROM_SCM (_type) (value); \ + \ + if (scm_is_eq (endianness, native_endianness)) \ + memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \ + else \ + { \ + IEEE754_UNION (_type) c_raw; \ + \ + IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \ + memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \ + } \ + \ + return SCM_UNSPECIFIED; + +#define IEEE754_NATIVE_SET(_type) \ + _type c_value; \ + \ + IEEE754_ACCESSOR_PROLOGUE (_type); \ + SCM_VALIDATE_REAL (3, value); \ + c_value = IEEE754_FROM_SCM (_type) (value); \ + \ + memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \ + return SCM_UNSPECIFIED; + + +/* Single precision. */ + +SCM_DEFINE (scm_bytevector_ieee_single_ref, + "bytevector-ieee-single-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the IEEE-754 single from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_ieee_single_ref +{ + IEEE754_REF (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_native_ref, + "bytevector-ieee-single-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the IEEE-754 single from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref +{ + IEEE754_NATIVE_REF (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_set_x, + "bytevector-ieee-single-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store real @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_ieee_single_set_x +{ + IEEE754_SET (float); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_single_native_set_x, + "bytevector-ieee-single-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the real @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x +{ + IEEE754_NATIVE_SET (float); +} +#undef FUNC_NAME + + +/* Double precision. */ + +SCM_DEFINE (scm_bytevector_ieee_double_ref, + "bytevector-ieee-double-ref", + 3, 0, 0, + (SCM bv, SCM index, SCM endianness), + "Return the IEEE-754 double from @var{bv} at " + "@var{index}.") +#define FUNC_NAME s_scm_bytevector_ieee_double_ref +{ + IEEE754_REF (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_native_ref, + "bytevector-ieee-double-native-ref", + 2, 0, 0, + (SCM bv, SCM index), + "Return the IEEE-754 double from @var{bv} at " + "@var{index} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref +{ + IEEE754_NATIVE_REF (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_set_x, + "bytevector-ieee-double-set!", + 4, 0, 0, + (SCM bv, SCM index, SCM value, SCM endianness), + "Store real @var{value} in @var{bv} at @var{index} according to " + "@var{endianness}.") +#define FUNC_NAME s_scm_bytevector_ieee_double_set_x +{ + IEEE754_SET (double); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytevector_ieee_double_native_set_x, + "bytevector-ieee-double-native-set!", + 3, 0, 0, + (SCM bv, SCM index, SCM value), + "Store the real @var{value} at index @var{index} " + "of @var{bv} using the native endianness.") +#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x +{ + IEEE754_NATIVE_SET (double); +} +#undef FUNC_NAME + + +#undef IEEE754_UNION +#undef IEEE754_TO_SCM +#undef IEEE754_FROM_SCM +#undef IEEE754_FROM_FOREIGN_ENDIANNESS +#undef IEEE754_TO_FOREIGN_ENDIANNESS +#undef IEEE754_REF +#undef IEEE754_NATIVE_REF +#undef IEEE754_SET +#undef IEEE754_NATIVE_SET + + +/* Operations on strings. */ + + +/* Produce a function that returns the length of a UTF-encoded string. */ +#define UTF_STRLEN_FUNCTION(_utf_width) \ +static inline size_t \ +utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \ +{ \ + size_t len = 0; \ + const uint ## _utf_width ## _t *ptr; \ + for (ptr = str; \ + *ptr != 0; \ + ptr++) \ + { \ + len++; \ + } \ + \ + return (len * ((_utf_width) / 8)); \ +} + +UTF_STRLEN_FUNCTION (8) + + +/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */ +#define UTF_STRLEN(_utf_width, _str) \ + utf ## _utf_width ## _strlen (_str) + +/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and + ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the + encoding name). */ +static inline void +utf_encoding_name (char *name, size_t utf_width, SCM endianness) +{ + strcpy (name, "UTF-"); + strcat (name, ((utf_width == 8) + ? "8" + : ((utf_width == 16) + ? "16" + : ((utf_width == 32) + ? "32" + : "??")))); + strcat (name, + ((scm_is_eq (endianness, scm_sym_big)) + ? "BE" + : ((scm_is_eq (endianness, scm_sym_little)) + ? "LE" + : "unknown"))); +} + +/* Maximum length of a UTF encoding name. */ +#define MAX_UTF_ENCODING_NAME_LEN 16 + +/* Produce the body of a `string->utf' function. */ +#define STRING_TO_UTF(_utf_width) \ + SCM utf; \ + int err; \ + char *c_str; \ + char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \ + char *c_utf = NULL, *c_locale; \ + size_t c_strlen, c_raw_strlen, c_utf_len = 0; \ + \ + SCM_VALIDATE_STRING (1, str); \ + if (endianness == SCM_UNDEFINED) \ + endianness = scm_sym_big; \ + else \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + \ + c_strlen = scm_c_string_length (str); \ + c_raw_strlen = c_strlen * ((_utf_width) / 8); \ + do \ + { \ + c_str = (char *) alloca (c_raw_strlen + 1); \ + c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \ + } \ + while (c_raw_strlen > c_strlen); \ + c_str[c_raw_strlen] = '\0'; \ + \ + utf_encoding_name (c_utf_name, (_utf_width), endianness); \ + \ + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \ + strcpy (c_locale, locale_charset ()); \ + \ + err = mem_iconveh (c_str, c_raw_strlen, \ + c_locale, c_utf_name, \ + iconveh_question_mark, NULL, \ + &c_utf, &c_utf_len); \ + if (SCM_UNLIKELY (err)) \ + scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \ + scm_list_1 (str), err); \ + else \ + /* C_UTF is null-terminated. */ \ + utf = scm_c_take_bytevector ((signed char *) c_utf, \ + c_utf_len); \ + \ + return (utf); + + + +SCM_DEFINE (scm_string_to_utf8, "string->utf8", + 1, 0, 0, + (SCM str), + "Return a newly allocated bytevector that contains the UTF-8 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf8 +{ + SCM utf; + char *c_str; + uint8_t *c_utf; + size_t c_strlen, c_raw_strlen; + + SCM_VALIDATE_STRING (1, str); + + c_strlen = scm_c_string_length (str); + c_raw_strlen = c_strlen; + do + { + c_str = (char *) alloca (c_raw_strlen + 1); + c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); + } + while (c_raw_strlen > c_strlen); + c_str[c_raw_strlen] = '\0'; + + c_utf = u8_strconv_from_locale (c_str); + if (SCM_UNLIKELY (c_utf == NULL)) + scm_syserror (FUNC_NAME); + else + /* C_UTF is null-terminated. */ + utf = scm_c_take_bytevector ((signed char *) c_utf, + UTF_STRLEN (8, c_utf)); + + return (utf); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_to_utf16, "string->utf16", + 1, 1, 0, + (SCM str, SCM endianness), + "Return a newly allocated bytevector that contains the UTF-16 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf16 +{ + STRING_TO_UTF (16); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_to_utf32, "string->utf32", + 1, 1, 0, + (SCM str, SCM endianness), + "Return a newly allocated bytevector that contains the UTF-32 " + "encoding of @var{str}.") +#define FUNC_NAME s_scm_string_to_utf32 +{ + STRING_TO_UTF (32); +} +#undef FUNC_NAME + + +/* Produce the body of a function that converts a UTF-encoded bytevector to a + string. */ +#define UTF_TO_STRING(_utf_width) \ + SCM str = SCM_BOOL_F; \ + int err; \ + char *c_str = NULL, *c_locale; \ + char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \ + const char *c_utf; \ + size_t c_strlen = 0, c_utf_len; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, utf); \ + if (endianness == SCM_UNDEFINED) \ + endianness = scm_sym_big; \ + else \ + SCM_VALIDATE_SYMBOL (2, endianness); \ + \ + c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \ + c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \ + utf_encoding_name (c_utf_name, (_utf_width), endianness); \ + \ + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \ + strcpy (c_locale, locale_charset ()); \ + \ + err = mem_iconveh (c_utf, c_utf_len, \ + c_utf_name, c_locale, \ + iconveh_question_mark, NULL, \ + &c_str, &c_strlen); \ + if (SCM_UNLIKELY (err)) \ + scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \ + scm_list_1 (utf), err); \ + else \ + /* C_STR is null-terminated. */ \ + str = scm_take_locale_stringn (c_str, c_strlen); \ + \ + return (str); + + +SCM_DEFINE (scm_utf8_to_string, "utf8->string", + 1, 0, 0, + (SCM utf), + "Return a newly allocate string that contains from the UTF-8-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf8_to_string +{ + SCM str; + int err; + char *c_str = NULL, *c_locale; + const char *c_utf; + size_t c_utf_len, c_strlen = 0; + + SCM_VALIDATE_BYTEVECTOR (1, utf); + + c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); + + c_locale = (char *) alloca (strlen (locale_charset ()) + 1); + strcpy (c_locale, locale_charset ()); + + c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); + err = mem_iconveh (c_utf, c_utf_len, + "UTF-8", c_locale, + iconveh_question_mark, NULL, + &c_str, &c_strlen); + if (SCM_UNLIKELY (err)) + scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", + scm_list_1 (utf), err); + else + /* C_STR is null-terminated. */ + str = scm_take_locale_stringn (c_str, c_strlen); + + return (str); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_utf16_to_string, "utf16->string", + 1, 1, 0, + (SCM utf, SCM endianness), + "Return a newly allocate string that contains from the UTF-16-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf16_to_string +{ + UTF_TO_STRING (16); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_utf32_to_string, "utf32->string", + 1, 1, 0, + (SCM utf, SCM endianness), + "Return a newly allocate string that contains from the UTF-32-" + "encoded contents of bytevector @var{utf}.") +#define FUNC_NAME s_scm_utf32_to_string +{ + UTF_TO_STRING (32); +} +#undef FUNC_NAME + + + +/* Initialization. */ + +void +scm_init_bytevectors (void) +{ +#include "libguile/bytevectors.x" + +#ifdef WORDS_BIGENDIAN + native_endianness = scm_sym_big; +#else + native_endianness = scm_sym_little; +#endif + + scm_endianness_big = scm_sym_big; + scm_endianness_little = scm_sym_little; + + scm_null_bytevector = + scm_gc_protect_object (make_bytevector_from_buffer (0, NULL)); +} diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h new file mode 100644 index 000000000..98c38aca2 --- /dev/null +++ b/libguile/bytevectors.h @@ -0,0 +1,133 @@ +#ifndef SCM_BYTEVECTORS_H +#define SCM_BYTEVECTORS_H + +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + + + +#include "libguile/__scm.h" + + +/* R6RS bytevectors. */ + +#define SCM_BYTEVECTOR_LENGTH(_bv) \ + ((unsigned) SCM_SMOB_DATA (_bv)) +#define SCM_BYTEVECTOR_CONTENTS(_bv) \ + (SCM_BYTEVECTOR_INLINE_P (_bv) \ + ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \ + : (signed char *) SCM_SMOB_DATA_2 (_bv)) + + +SCM_API SCM scm_endianness_big; +SCM_API SCM scm_endianness_little; + +SCM_API SCM scm_make_bytevector (SCM, SCM); +SCM_API SCM scm_c_make_bytevector (unsigned); +SCM_API SCM scm_native_endianness (void); +SCM_API SCM scm_bytevector_p (SCM); +SCM_API SCM scm_bytevector_length (SCM); +SCM_API SCM scm_bytevector_eq_p (SCM, SCM); +SCM_API SCM scm_bytevector_fill_x (SCM, SCM); +SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_copy (SCM); + +SCM_API SCM scm_bytevector_to_u8_list (SCM); +SCM_API SCM scm_u8_list_to_bytevector (SCM); +SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_to_uint_list (SCM, SCM, SCM); +SCM_API SCM scm_sint_list_to_bytevector (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_to_sint_list (SCM, SCM, SCM); + +SCM_API SCM scm_bytevector_u16_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s16_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u32_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s32_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u64_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s64_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_u8_ref (SCM, SCM); +SCM_API SCM scm_bytevector_s8_ref (SCM, SCM); +SCM_API SCM scm_bytevector_uint_ref (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_sint_ref (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u8_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s8_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_uint_set_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_sint_set_x (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u16_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s16_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u32_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s32_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_u64_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_s64_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_single_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_ref (SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_native_ref (SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_set_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_bytevector_ieee_double_native_set_x (SCM, SCM, SCM); +SCM_API SCM scm_string_to_utf8 (SCM); +SCM_API SCM scm_string_to_utf16 (SCM, SCM); +SCM_API SCM scm_string_to_utf32 (SCM, SCM); +SCM_API SCM scm_utf8_to_string (SCM); +SCM_API SCM scm_utf16_to_string (SCM, SCM); +SCM_API SCM scm_utf32_to_string (SCM, SCM); + + + +/* Internal API. */ + +/* The threshold (in octets) under which bytevectors are stored "in-line", + i.e., without allocating memory beside the SMOB itself (a double cell). + This optimization is necessary since small bytevectors are expected to be + common. */ +#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM)) +#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \ + ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD) +#define SCM_BYTEVECTOR_INLINE_P(_bv) \ + (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv))) + +/* Hint that is passed to `scm_gc_malloc ()' and friends. */ +#define SCM_GC_BYTEVECTOR "bytevector" + +SCM_API void scm_init_bytevectors (void); + +SCM_INTERNAL scm_t_bits scm_tc16_bytevector; +SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, unsigned); + +#define scm_c_shrink_bytevector(_bv, _len) \ + (SCM_BYTEVECTOR_INLINE_P (_bv) \ + ? (_bv) \ + : scm_i_shrink_bytevector ((_bv), (_len))) + +SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, unsigned); +SCM_INTERNAL SCM scm_null_bytevector; + +#endif /* SCM_BYTEVECTORS_H */ diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h new file mode 100644 index 000000000..e345efaae --- /dev/null +++ b/libguile/ieee-754.h @@ -0,0 +1,90 @@ +/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, write to the Free + Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307 USA. */ + +#ifndef SCM_IEEE_754_H +#define SCM_IEEE_754_H 1 + +/* Based on glibc's and modified by Ludovic Courtès to include + all possible IEEE-754 double-precision representations. */ + + +/* IEEE 754 simple-precision format (32-bit). */ + +union scm_ieee754_float + { + float f; + + struct + { + unsigned int negative:1; + unsigned int exponent:8; + unsigned int mantissa:23; + } big_endian; + + struct + { + unsigned int mantissa:23; + unsigned int exponent:8; + unsigned int negative:1; + } little_endian; + }; + + + +/* IEEE 754 double-precision format (64-bit). */ + +union scm_ieee754_double + { + double d; + + struct + { + /* Big endian. */ + + unsigned int negative:1; + unsigned int exponent:11; + /* Together these comprise the mantissa. */ + unsigned int mantissa0:20; + unsigned int mantissa1:32; + } big_endian; + + struct + { + /* Both byte order and word order are little endian. */ + + /* Together these comprise the mantissa. */ + unsigned int mantissa1:32; + unsigned int mantissa0:20; + unsigned int exponent:11; + unsigned int negative:1; + } little_little_endian; + + struct + { + /* Byte order is little endian but word order is big endian. Not + sure this is very wide spread. */ + unsigned int mantissa0:20; + unsigned int exponent:11; + unsigned int negative:1; + unsigned int mantissa1:32; + } little_big_endian; + + }; + + +#endif /* SCM_IEEE_754_H */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c new file mode 100644 index 000000000..a07636fce --- /dev/null +++ b/libguile/r6rs-ports.c @@ -0,0 +1,1118 @@ +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#ifdef HAVE_UNISTD_H +# include +#endif + +#include +#include +#include + +#include "libguile/_scm.h" +#include "libguile/bytevectors.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/r6rs-ports.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/values.h" +#include "libguile/vectors.h" + + + +/* Unimplemented features. */ + + +/* Transoders are currently not implemented since Guile 1.8 is not + Unicode-capable. Thus, most of the code here assumes the use of the + binary transcoder. */ +static inline void +transcoders_not_implemented (void) +{ + fprintf (stderr, "%s: warning: transcoders not implemented\n", + PACKAGE_NAME); +} + + +/* End-of-file object. */ + +SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, + (void), + "Return the end-of-file object.") +#define FUNC_NAME s_scm_eof_object +{ + return (SCM_EOF_VAL); +} +#undef FUNC_NAME + + +/* Input ports. */ + +#ifndef MIN +# define MIN(a,b) ((a) < (b) ? (a) : (b)) +#endif + +/* Bytevector input ports or "bip" for short. */ +static scm_t_bits bytevector_input_port_type = 0; + +static inline SCM +make_bip (SCM bv) +{ + SCM port; + char *c_bv; + unsigned c_len; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + + port = scm_new_port_table_entry (bytevector_input_port_type); + + /* Prevent BV from being GC'd. */ + SCM_SETSTREAM (port, SCM_UNPACK (bv)); + + /* Have the port directly access the bytevector. */ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + c_port = SCM_PTAB_ENTRY (port); + c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv; + c_port->read_end = (unsigned char *) c_bv + c_len; + c_port->read_buf_size = c_len; + + /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ + SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits); + + return port; +} + +static SCM +bip_mark (SCM port) +{ + /* Mark the underlying bytevector. */ + return (SCM_PACK (SCM_STREAM (port))); +} + +static int +bip_fill_input (SCM port) +{ + int result; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + if (c_port->read_pos >= c_port->read_end) + result = EOF; + else + result = (int) *c_port->read_pos; + + return result; +} + +static off_t +bip_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "bip_seek" +{ + off_t c_result = 0; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + switch (whence) + { + case SEEK_CUR: + offset += c_port->read_pos - c_port->read_buf; + /* Fall through. */ + + case SEEK_SET: + if (c_port->read_buf + offset < c_port->read_end) + { + c_port->read_pos = c_port->read_buf + offset; + c_result = offset; + } + else + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + break; + + case SEEK_END: + if (c_port->read_end - offset >= c_port->read_buf) + { + c_port->read_pos = c_port->read_end - offset; + c_result = c_port->read_pos - c_port->read_buf; + } + else + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + break; + + default: + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "invalid `seek' parameter"); + } + + return c_result; +} +#undef FUNC_NAME + + +/* Instantiate the bytevector input port type. */ +static inline void +initialize_bytevector_input_ports (void) +{ + bytevector_input_port_type = + scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input, + NULL); + + scm_set_port_mark (bytevector_input_port_type, bip_mark); + scm_set_port_seek (bytevector_input_port_type, bip_seek); +} + + +SCM_DEFINE (scm_open_bytevector_input_port, + "open-bytevector-input-port", 1, 1, 0, + (SCM bv, SCM transcoder), + "Return an input port whose contents are drawn from " + "bytevector @var{bv}.") +#define FUNC_NAME s_scm_open_bytevector_input_port +{ + SCM_VALIDATE_BYTEVECTOR (1, bv); + if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) + transcoders_not_implemented (); + + return (make_bip (bv)); +} +#undef FUNC_NAME + + +/* Custom binary ports. The following routines are shared by input and + output custom binary ports. */ + +#define SCM_CBP_GET_POSITION_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1) +#define SCM_CBP_SET_POSITION_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2) +#define SCM_CBP_CLOSE_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3) + +static SCM +cbp_mark (SCM port) +{ + /* Mark the underlying method and object vector. */ + return (SCM_PACK (SCM_STREAM (port))); +} + +static off_t +cbp_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "cbp_seek" +{ + SCM result; + off_t c_result = 0; + + switch (whence) + { + case SEEK_CUR: + { + SCM get_position_proc; + + get_position_proc = SCM_CBP_GET_POSITION_PROC (port); + if (SCM_LIKELY (scm_is_true (get_position_proc))) + result = scm_call_0 (get_position_proc); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary port does not " + "support `port-position'"); + + offset += scm_to_int (result); + /* Fall through. */ + } + + case SEEK_SET: + { + SCM set_position_proc; + + set_position_proc = SCM_CBP_SET_POSITION_PROC (port); + if (SCM_LIKELY (scm_is_true (set_position_proc))) + result = scm_call_1 (set_position_proc, scm_from_int (offset)); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary port does not " + "support `set-port-position!'"); + + /* Assuming setting the position succeeded. */ + c_result = offset; + break; + } + + default: + /* `SEEK_END' cannot be supported. */ + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary ports do not " + "support `SEEK_END'"); + } + + return c_result; +} +#undef FUNC_NAME + +static int +cbp_close (SCM port) +{ + SCM close_proc; + + close_proc = SCM_CBP_CLOSE_PROC (port); + if (scm_is_true (close_proc)) + /* Invoke the `close' thunk. */ + scm_call_0 (close_proc); + + return 1; +} + + +/* Custom binary input port ("cbip" for short). */ + +static scm_t_bits custom_binary_input_port_type = 0; + +/* Size of the buffer embedded in custom binary input ports. */ +#define CBIP_BUFFER_SIZE 4096 + +/* Return the bytevector associated with PORT. */ +#define SCM_CBIP_BYTEVECTOR(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4) + +/* Return the various procedures of PORT. */ +#define SCM_CBIP_READ_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) + + +static inline SCM +make_cbip (SCM read_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) +{ + SCM port, bv, method_vector; + char *c_bv; + unsigned c_len; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + + /* Use a bytevector as the underlying buffer. */ + c_len = CBIP_BUFFER_SIZE; + bv = scm_c_make_bytevector (c_len); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + + /* Store the various methods and bytevector in a vector. */ + method_vector = scm_c_make_vector (5, SCM_BOOL_F); + SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv); + SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + + port = scm_new_port_table_entry (custom_binary_input_port_type); + + /* Attach it the method vector. */ + SCM_SETSTREAM (port, SCM_UNPACK (method_vector)); + + /* Have the port directly access the buffer (bytevector). */ + c_port = SCM_PTAB_ENTRY (port); + c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv; + c_port->read_end = (unsigned char *) c_bv; + c_port->read_buf_size = c_len; + + /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ + SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits); + + return port; +} + +static int +cbip_fill_input (SCM port) +#define FUNC_NAME "cbip_fill_input" +{ + int result; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + again: + if (c_port->read_pos >= c_port->read_end) + { + /* Invoke the user's `read!' procedure. */ + unsigned c_octets; + SCM bv, read_proc, octets; + + /* Use the bytevector associated with PORT as the buffer passed to the + `read!' procedure, thereby avoiding additional allocations. */ + bv = SCM_CBIP_BYTEVECTOR (port); + read_proc = SCM_CBIP_READ_PROC (port); + + /* The assumption here is that C_PORT's internal buffer wasn't changed + behind our back. */ + assert (c_port->read_buf == + (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); + assert ((unsigned) c_port->read_buf_size + == SCM_BYTEVECTOR_LENGTH (bv)); + + octets = scm_call_3 (read_proc, bv, SCM_INUM0, + SCM_I_MAKINUM (CBIP_BUFFER_SIZE)); + c_octets = scm_to_uint (octets); + + c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_port->read_end = (unsigned char *) c_port->read_pos + c_octets; + + if (c_octets > 0) + goto again; + else + result = EOF; + } + else + result = (int) *c_port->read_pos; + + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_custom_binary_input_port, + "make-custom-binary-input-port", 5, 0, 0, + (SCM id, SCM read_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary input port whose input is drained " + "by invoking @var{read_proc} and passing it a bytevector, an " + "index where octets should be written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_input_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, read_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (3, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (4, set_position_proc); + + if (!scm_is_false (close_proc)) + SCM_VALIDATE_PROC (5, close_proc); + + return (make_cbip (read_proc, get_position_proc, set_position_proc, + close_proc)); +} +#undef FUNC_NAME + + +/* Instantiate the custom binary input port type. */ +static inline void +initialize_custom_binary_input_ports (void) +{ + custom_binary_input_port_type = + scm_make_port_type ("r6rs-custom-binary-input-port", + cbip_fill_input, NULL); + + scm_set_port_mark (custom_binary_input_port_type, cbp_mark); + scm_set_port_seek (custom_binary_input_port_type, cbp_seek); + scm_set_port_close (custom_binary_input_port_type, cbp_close); +} + + + +/* Binary input. */ + +/* We currently don't support specific binary input ports. */ +#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT + +SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0, + (SCM port), + "Read an octet from @var{port}, a binary input port, " + "blocking as necessary.") +#define FUNC_NAME s_scm_get_u8 +{ + SCM result; + int c_result; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_result = scm_getc (port); + if (c_result == EOF) + result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM ((unsigned char) c_result); + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0, + (SCM port), + "Like @code{get-u8} but does not update @var{port} to " + "point past the octet.") +#define FUNC_NAME s_scm_lookahead_u8 +{ + SCM result; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + result = scm_peek_char (port); + if (SCM_CHARP (result)) + result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result)); + else + result = SCM_EOF_VAL; + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, + (SCM port, SCM count), + "Read @var{count} octets from @var{port}, blocking as " + "necessary and return a bytevector containing the octets " + "read. If fewer bytes are available, a bytevector smaller " + "than @var{count} is returned.") +#define FUNC_NAME s_scm_get_bytevector_n +{ + SCM result; + char *c_bv; + unsigned c_count; + size_t c_read; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + c_count = scm_to_uint (count); + + result = scm_c_make_bytevector (c_count); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result); + + if (SCM_LIKELY (c_count > 0)) + /* XXX: `scm_c_read ()' does not update the port position. */ + c_read = scm_c_read (port, c_bv, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read = 0; + + if ((c_read == 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result = SCM_EOF_VAL; + else + result = scm_null_bytevector; + } + else + { + if (c_read < c_count) + result = scm_c_shrink_bytevector (result, c_read); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, + (SCM port, SCM bv, SCM start, SCM count), + "Read @var{count} bytes from @var{port} and store them " + "in @var{bv} starting at index @var{start}. Return either " + "the number of bytes actually read or the end-of-file " + "object.") +#define FUNC_NAME s_scm_get_bytevector_n_x +{ + SCM result; + char *c_bv; + unsigned c_start, c_count, c_len; + size_t c_read; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + c_start = scm_to_uint (start); + c_count = scm_to_uint (count); + + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + if (SCM_UNLIKELY (c_start + c_count > c_len)) + scm_out_of_range (FUNC_NAME, count); + + if (SCM_LIKELY (c_count > 0)) + c_read = scm_c_read (port, c_bv + c_start, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read = 0; + + if ((c_read == 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM (0); + } + else + result = scm_from_size_t (c_read); + + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, + (SCM port), + "Read from @var{port}, blocking as necessary, until data " + "are available or and end-of-file is reached. Return either " + "a new bytevector containing the data read or the " + "end-of-file object.") +#define FUNC_NAME s_scm_get_bytevector_some +{ + /* Read at least one byte, unless the end-of-file is already reached, and + read while characters are available (buffered). */ + + SCM result; + char *c_bv; + unsigned c_len; + size_t c_total; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_len = 4096; + c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_total = 0; + + do + { + int c_chr; + + if (c_total + 1 > c_len) + { + /* Grow the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_len *= 2; + } + + /* We can't use `scm_c_read ()' since it blocks. */ + c_chr = scm_getc (port); + if (c_chr != EOF) + { + c_bv[c_total] = (char) c_chr; + c_total++; + } + } + while ((scm_is_true (scm_char_ready_p (port))) + && (!SCM_EOF_OBJECT_P (scm_peek_char (port)))); + + if (c_total == 0) + { + result = SCM_EOF_VAL; + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + if (c_len > c_total) + { + /* Shrink the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, + SCM_GC_BYTEVECTOR); + c_len = (unsigned) c_total; + } + + result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, + (SCM port), + "Read from @var{port}, blocking as necessary, until " + "the end-of-file is reached. Return either " + "a new bytevector containing the data read or the " + "end-of-file object (if no data were available).") +#define FUNC_NAME s_scm_get_bytevector_all +{ + SCM result; + char *c_bv; + unsigned c_len, c_count; + size_t c_read, c_total; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_len = c_count = 4096; + c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_total = c_read = 0; + + do + { + if (c_total + c_read > c_len) + { + /* Grow the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_count = c_len; + c_len *= 2; + } + + /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is + reached. */ + c_read = scm_c_read (port, c_bv + c_total, c_count); + c_total += c_read, c_count -= c_read; + } + while (!SCM_EOF_OBJECT_P (scm_peek_char (port))); + + if (c_total == 0) + { + result = SCM_EOF_VAL; + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + if (c_len > c_total) + { + /* Shrink the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, + SCM_GC_BYTEVECTOR); + c_len = (unsigned) c_total; + } + + result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + + + +/* Binary output. */ + +/* We currently don't support specific binary input ports. */ +#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT + + +SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0, + (SCM port, SCM octet), + "Write @var{octet} to binary port @var{port}.") +#define FUNC_NAME s_scm_put_u8 +{ + scm_t_uint8 c_octet; + + SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); + c_octet = scm_to_uint8 (octet); + + scm_putc ((char) c_octet, port); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, + (SCM port, SCM bv, SCM start, SCM count), + "Write the contents of @var{bv} to @var{port}, optionally " + "starting at index @var{start} and limiting to @var{count} " + "octets.") +#define FUNC_NAME s_scm_put_bytevector +{ + char *c_bv; + unsigned c_start, c_count, c_len; + + SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + + if (start != SCM_UNDEFINED) + { + c_start = scm_to_uint (start); + + if (count != SCM_UNDEFINED) + { + c_count = scm_to_uint (count); + if (SCM_UNLIKELY (c_start + c_count > c_len)) + scm_out_of_range (FUNC_NAME, count); + } + else + { + if (SCM_UNLIKELY (c_start >= c_len)) + scm_out_of_range (FUNC_NAME, start); + else + c_count = c_len - c_start; + } + } + else + c_start = 0, c_count = c_len; + + scm_c_write (port, c_bv + c_start, c_count); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + +/* Bytevector output port ("bop" for short). */ + +/* Implementation of "bops". + + Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to + it. The procedure returned along with the output port is actually an + applicable SMOB. The SMOB holds a reference to the port. When applied, + the SMOB swallows the port's internal buffer, turning it into a + bytevector, and resets it. + + XXX: Access to a bop's internal buffer is not thread-safe. */ + +static scm_t_bits bytevector_output_port_type = 0; + +SCM_SMOB (bytevector_output_port_procedure, + "r6rs-bytevector-output-port-procedure", + 0); + +#define SCM_GC_BOP "r6rs-bytevector-output-port" +#define SCM_BOP_BUFFER_INITIAL_SIZE 4096 + +/* Representation of a bop's internal buffer. */ +typedef struct +{ + size_t total_len; + size_t len; + size_t pos; + char *buffer; +} scm_t_bop_buffer; + + +/* Accessing a bop's buffer. */ +#define SCM_BOP_BUFFER(_port) \ + ((scm_t_bop_buffer *) SCM_STREAM (_port)) +#define SCM_SET_BOP_BUFFER(_port, _buf) \ + (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf))) + + +static inline void +bop_buffer_init (scm_t_bop_buffer *buf) +{ + buf->total_len = buf->len = buf->pos = 0; + buf->buffer = NULL; +} + +static inline void +bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size) +{ + char *new_buf; + size_t new_size; + + for (new_size = buf->total_len + ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE; + new_size < min_size; + new_size *= 2); + + if (buf->buffer) + new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, + new_size, SCM_GC_BOP); + else + new_buf = scm_gc_malloc (new_size, SCM_GC_BOP); + + buf->buffer = new_buf; + buf->total_len = new_size; +} + +static inline SCM +make_bop (void) +{ + SCM port, bop_proc; + scm_t_port *c_port; + scm_t_bop_buffer *buf; + const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + + port = scm_new_port_table_entry (bytevector_output_port_type); + + buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP); + bop_buffer_init (buf); + + c_port = SCM_PTAB_ENTRY (port); + c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; + c_port->write_buf_size = 0; + + SCM_SET_BOP_BUFFER (port, buf); + + /* Mark PORT as open and writable. */ + SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits); + + /* Make the bop procedure. */ + SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, + SCM_PACK (port)); + + return (scm_values (scm_list_2 (port, bop_proc))); +} + +static size_t +bop_free (SCM port) +{ + /* The port itself is necessarily freed _after_ the bop proc, since the bop + proc holds a reference to it. Thus we can safely free the internal + buffer when the bop becomes unreferenced. */ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + if (buf->buffer) + scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP); + + scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP); + + return 0; +} + +/* Write SIZE octets from DATA to PORT. */ +static void +bop_write (SCM port, const void *data, size_t size) +{ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + + if (buf->pos + size > buf->total_len) + bop_buffer_grow (buf, buf->pos + size); + + memcpy (buf->buffer + buf->pos, data, size); + buf->pos += size; + buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; +} + +static off_t +bop_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "bop_seek" +{ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + switch (whence) + { + case SEEK_CUR: + offset += (off_t) buf->pos; + /* Fall through. */ + + case SEEK_SET: + if (offset < 0 || (unsigned) offset > buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = offset; + break; + + case SEEK_END: + if (offset < 0 || (unsigned) offset >= buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = buf->len - (offset + 1); + break; + + default: + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "invalid `seek' parameter"); + } + + return buf->pos; +} +#undef FUNC_NAME + +/* Fetch data from a bop. */ +SCM_SMOB_APPLY (bytevector_output_port_procedure, + bop_proc_apply, 0, 0, 0, (SCM bop_proc)) +{ + SCM port, bv; + scm_t_bop_buffer *buf, result_buf; + + port = SCM_PACK (SCM_SMOB_DATA (bop_proc)); + buf = SCM_BOP_BUFFER (port); + + result_buf = *buf; + bop_buffer_init (buf); + + if (result_buf.len == 0) + bv = scm_c_take_bytevector (NULL, 0); + else + { + if (result_buf.total_len > result_buf.len) + /* Shrink the buffer. */ + result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer, + result_buf.total_len, + result_buf.len, + SCM_GC_BOP); + + bv = scm_c_take_bytevector ((signed char *) result_buf.buffer, + result_buf.len); + } + + return bv; +} + +SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark, + bop_proc) +{ + /* Mark the port associated with BOP_PROC. */ + return (SCM_PACK (SCM_SMOB_DATA (bop_proc))); +} + + +SCM_DEFINE (scm_open_bytevector_output_port, + "open-bytevector-output-port", 0, 1, 0, + (SCM transcoder), + "Return two values: an output port and a procedure. The latter " + "should be called with zero arguments to obtain a bytevector " + "containing the data accumulated by the port.") +#define FUNC_NAME s_scm_open_bytevector_output_port +{ + if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) + transcoders_not_implemented (); + + return (make_bop ()); +} +#undef FUNC_NAME + +static inline void +initialize_bytevector_output_ports (void) +{ + bytevector_output_port_type = + scm_make_port_type ("r6rs-bytevector-output-port", + NULL, bop_write); + + scm_set_port_seek (bytevector_output_port_type, bop_seek); + scm_set_port_free (bytevector_output_port_type, bop_free); +} + + +/* Custom binary output port ("cbop" for short). */ + +static scm_t_bits custom_binary_output_port_type; + +/* Return the various procedures of PORT. */ +#define SCM_CBOP_WRITE_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) + + +static inline SCM +make_cbop (SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) +{ + SCM port, method_vector; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + + /* Store the various methods and bytevector in a vector. */ + method_vector = scm_c_make_vector (4, SCM_BOOL_F); + SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + + port = scm_new_port_table_entry (custom_binary_output_port_type); + + /* Attach it the method vector. */ + SCM_SETSTREAM (port, SCM_UNPACK (method_vector)); + + /* Have the port directly access the buffer (bytevector). */ + c_port = SCM_PTAB_ENTRY (port); + c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; + c_port->write_buf_size = c_port->read_buf_size = 0; + + /* Mark PORT as open, writable and unbuffered. */ + SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits); + + return port; +} + +/* Write SIZE octets from DATA to PORT. */ +static void +cbop_write (SCM port, const void *data, size_t size) +#define FUNC_NAME "cbop_write" +{ + long int c_result; + size_t c_written; + SCM bv, write_proc, result; + + /* XXX: Allocating a new bytevector at each `write' call is inefficient, + but necessary since (1) we don't control the lifetime of the buffer + pointed to by DATA, and (2) the `write!' procedure could capture the + bytevector it is passed. */ + bv = scm_c_make_bytevector (size); + memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); + + write_proc = SCM_CBOP_WRITE_PROC (port); + + /* Since the `write' procedure of Guile's ports has type `void', it must + try hard to write exactly SIZE bytes, regardless of how many bytes the + sink can handle. */ + for (c_written = 0; + c_written < size; + c_written += c_result) + { + result = scm_call_3 (write_proc, bv, + scm_from_size_t (c_written), + scm_from_size_t (size - c_written)); + + c_result = scm_to_long (result); + if (SCM_UNLIKELY (c_result < 0 + || (size_t) c_result > (size - c_written))) + scm_wrong_type_arg_msg (FUNC_NAME, 0, result, + "R6RS custom binary output port `write!' " + "returned a incorrect integer"); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_custom_binary_output_port, + "make-custom-binary-output-port", 5, 0, 0, + (SCM id, SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary output port whose output is drained " + "by invoking @var{write_proc} and passing it a bytevector, an " + "index where octets should be written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_output_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, write_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (3, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (4, set_position_proc); + + if (!scm_is_false (close_proc)) + SCM_VALIDATE_PROC (5, close_proc); + + return (make_cbop (write_proc, get_position_proc, set_position_proc, + close_proc)); +} +#undef FUNC_NAME + + +/* Instantiate the custom binary output port type. */ +static inline void +initialize_custom_binary_output_ports (void) +{ + custom_binary_output_port_type = + scm_make_port_type ("r6rs-custom-binary-output-port", + NULL, cbop_write); + + scm_set_port_mark (custom_binary_output_port_type, cbp_mark); + scm_set_port_seek (custom_binary_output_port_type, cbp_seek); + scm_set_port_close (custom_binary_output_port_type, cbp_close); +} + + +/* Initialization. */ + +void +scm_init_r6rs_ports (void) +{ +#include "r6rs-ports.x" + + initialize_bytevector_input_ports (); + initialize_custom_binary_input_ports (); + initialize_bytevector_output_ports (); + initialize_custom_binary_output_ports (); +} diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h new file mode 100644 index 000000000..e29d96200 --- /dev/null +++ b/libguile/r6rs-ports.h @@ -0,0 +1,43 @@ +#ifndef SCM_R6RS_PORTS_H +#define SCM_R6RS_PORTS_H + +/* Copyright (C) 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + + + +#include "libguile/__scm.h" + +/* R6RS I/O Ports. */ + +SCM_API SCM scm_eof_object (void); +SCM_API SCM scm_open_bytevector_input_port (SCM, SCM); +SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_u8 (SCM); +SCM_API SCM scm_lookahead_u8 (SCM); +SCM_API SCM scm_get_bytevector_n (SCM, SCM); +SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_bytevector_some (SCM); +SCM_API SCM scm_get_bytevector_all (SCM); +SCM_API SCM scm_put_u8 (SCM, SCM); +SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); +SCM_API SCM scm_open_bytevector_output_port (SCM); +SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM); + +SCM_API void scm_init_r6rs_ports (void); + +#endif /* SCM_R6RS_PORTS_H */ diff --git a/libguile/validate.h b/libguile/validate.h index e05b7dd83..c362c02f3 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -3,7 +3,7 @@ #ifndef SCM_VALIDATE_H #define SCM_VALIDATE_H -/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -150,6 +150,9 @@ cvar = scm_to_bool (flag); \ } while (0) +#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \ + SCM_VALIDATE_SMOB ((_pos), (_obj), bytevector) + #define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character") #define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \ diff --git a/module/Makefile.am b/module/Makefile.am index 95dc75ac2..d149bb64a 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -31,7 +31,7 @@ modpath = # putting these core modules first. SOURCES = \ - ice-9/psyntax-pp.scm \ + ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ \ @@ -53,6 +53,7 @@ SOURCES = \ \ $(ICE_9_SOURCES) \ $(SRFI_SOURCES) \ + $(RNRS_SOURCES) \ $(OOP_SOURCES) \ \ $(SCRIPTS_SOURCES) @@ -209,6 +210,10 @@ SRFI_SOURCES = \ srfi/srfi-69.scm \ srfi/srfi-88.scm +RNRS_SOURCES = \ + rnrs/bytevector.scm \ + rnrs/io/ports.scm + EXTRA_DIST += scripts/ChangeLog-2008 EXTRA_DIST += scripts/README diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm new file mode 100644 index 000000000..793cbc020 --- /dev/null +++ b/module/rnrs/bytevector.scm @@ -0,0 +1,84 @@ +;;;; bytevector.scm --- R6RS bytevector API + +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès + +;;; Commentary: +;;; +;;; A "bytevector" is a raw bit string. This module provides procedures to +;;; manipulate bytevectors and interpret their contents in a number of ways: +;;; bytevector contents can be accessed as signed or unsigned integer of +;;; various sizes and endianness, as IEEE-754 floating point numbers, or as +;;; strings. It is a useful tool to decode binary data. +;;; +;;; Code: + +(define-module (rnrs bytevector) + :export-syntax (endianness) + :export (native-endianness bytevector? + make-bytevector bytevector-length bytevector=? bytevector-fill! + bytevector-copy! bytevector-copy bytevector-u8-ref + bytevector-s8-ref + bytevector-u8-set! bytevector-s8-set! bytevector->u8-list + u8-list->bytevector + bytevector-uint-ref bytevector-uint-set! + bytevector-sint-ref bytevector-sint-set! + bytevector->sint-list bytevector->uint-list + uint-list->bytevector sint-list->bytevector + + bytevector-u16-ref bytevector-s16-ref + bytevector-u16-set! bytevector-s16-set! + bytevector-u16-native-ref bytevector-s16-native-ref + bytevector-u16-native-set! bytevector-s16-native-set! + + bytevector-u32-ref bytevector-s32-ref + bytevector-u32-set! bytevector-s32-set! + bytevector-u32-native-ref bytevector-s32-native-ref + bytevector-u32-native-set! bytevector-s32-native-set! + + bytevector-u64-ref bytevector-s64-ref + bytevector-u64-set! bytevector-s64-set! + bytevector-u64-native-ref bytevector-s64-native-ref + bytevector-u64-native-set! bytevector-s64-native-set! + + bytevector-ieee-single-ref + bytevector-ieee-single-set! + bytevector-ieee-single-native-ref + bytevector-ieee-single-native-set! + + bytevector-ieee-double-ref + bytevector-ieee-double-set! + bytevector-ieee-double-native-ref + bytevector-ieee-double-native-set! + + string->utf8 string->utf16 string->utf32 + utf8->string utf16->string utf32->string)) + + +(load-extension "libguile" "scm_init_bytevectors") + +(define-macro (endianness sym) + (if (memq sym '(big little)) + `(quote ,sym) + (error "unsupported endianness" sym))) + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; bytevector.scm ends here diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm new file mode 100644 index 000000000..73843ee55 --- /dev/null +++ b/module/rnrs/io/ports.scm @@ -0,0 +1,111 @@ +;;;; ports.scm --- R6RS port API + +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès + +;;; Commentary: +;;; +;;; The I/O port API of the R6RS is provided by this module. In many areas +;;; it complements or refines Guile's own historical port API. For instance, +;;; it allows for binary I/O with bytevectors. +;;; +;;; Code: + +(define-module (rnrs io ports) + :re-export (eof-object? port? input-port? output-port?) + :export (eof-object + + ;; input & output ports + port-transcoder binary-port? transcoded-port + port-position set-port-position! + port-has-port-position? port-has-set-port-position!? + call-with-port + + ;; input ports + open-bytevector-input-port + make-custom-binary-input-port + + ;; binary input + get-u8 lookahead-u8 + get-bytevector-n get-bytevector-n! + get-bytevector-some get-bytevector-all + + ;; output ports + open-bytevector-output-port + make-custom-binary-output-port + + ;; binary output + put-u8 put-bytevector)) + +(load-extension "libguile" "scm_init_r6rs_ports") + + + +;;; +;;; Input and output ports. +;;; + +(define (port-transcoder port) + (error "port transcoders are not supported" port)) + +(define (binary-port? port) + ;; So far, we don't support transcoders other than the binary transcoder. + #t) + +(define (transcoded-port port) + (error "port transcoders are not supported" port)) + +(define (port-position port) + "Return the offset (an integer) indicating where the next octet will be +read from/written to in @var{port}." + + ;; FIXME: We should raise an `&assertion' error when not supported. + (seek port 0 SEEK_CUR)) + +(define (set-port-position! port offset) + "Set the position where the next octet will be read from/written to +@var{port}." + + ;; FIXME: We should raise an `&assertion' error when not supported. + (seek port offset SEEK_SET)) + +(define (port-has-port-position? port) + "Return @code{#t} is @var{port} supports @code{port-position}." + (and (false-if-exception (port-position port)) #t)) + +(define (port-has-set-port-position!? port) + "Return @code{#t} is @var{port} supports @code{set-port-position!}." + (and (false-if-exception (set-port-position! port (port-position port))) + #t)) + +(define (call-with-port port proc) + "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of +@var{proc}. Return the return values of @var{proc}." + (dynamic-wind + (lambda () + #t) + (lambda () + (proc port)) + (lambda () + (close-port port)))) + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; ports.scm ends here diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3854d4ab1..0b986d4a2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \ tests/arbiters.test \ tests/asm-to-bytecode.test \ tests/bit-operations.test \ + tests/bytevectors.test \ tests/c-api.test \ tests/chars.test \ tests/common-list.test \ @@ -62,6 +63,7 @@ SCM_TESTS = tests/alist.test \ tests/q.test \ tests/r4rs.test \ tests/r5rs_pitfall.test \ + tests/r6rs-ports.test \ tests/ramap.test \ tests/reader.test \ tests/receive.test \ diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test new file mode 100644 index 000000000..b2ae65c1f --- /dev/null +++ b/test-suite/tests/bytevectors.test @@ -0,0 +1,531 @@ +;;;; bytevectors.test --- Exercise the R6RS bytevector API. +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-bytevector) + :use-module (test-suite lib) + :use-module (rnrs bytevector)) + +;;; Some of the tests in here are examples taken from the R6RS Standard +;;; Libraries document. + + +(with-test-prefix "2.2 General Operations" + + (pass-if "native-endianness" + (not (not (memq (native-endianness) '(big little))))) + + (pass-if "make-bytevector" + (and (bytevector? (make-bytevector 20)) + (bytevector? (make-bytevector 20 3)))) + + (pass-if "bytevector-length" + (= (bytevector-length (make-bytevector 20)) 20)) + + (pass-if "bytevector=?" + (and (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 7)) + (not (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 0)))))) + + +(with-test-prefix "2.3 Operations on Bytes and Octets" + + (pass-if "bytevector-{u8,s8}-ref" + (equal? '(-127 129 -1 255) + (let ((b1 (make-bytevector 16 -127)) + (b2 (make-bytevector 16 255))) + (list (bytevector-s8-ref b1 0) + (bytevector-u8-ref b1 0) + (bytevector-s8-ref b2 0) + (bytevector-u8-ref b2 0))))) + + (pass-if "bytevector-{u8,s8}-set!" + (equal? '(-126 130 -10 246) + (let ((b (make-bytevector 16 -127))) + + (bytevector-s8-set! b 0 -126) + (bytevector-u8-set! b 1 246) + + (list (bytevector-s8-ref b 0) + (bytevector-u8-ref b 0) + (bytevector-s8-ref b 1) + (bytevector-u8-ref b 1))))) + + (pass-if "bytevector->u8-list" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list + (let ((b (make-bytevector 6))) + (for-each (lambda (i v) + (bytevector-u8-set! b i v)) + (iota 6) + lst) + b))))) + + (pass-if "u8-list->bytevector" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list (u8-list->bytevector lst))))) + + (pass-if "bytevector-uint-{ref,set!} [small]" + (let ((b (make-bytevector 15))) + (bytevector-uint-set! b 0 #x1234 + (endianness little) 2) + (equal? (bytevector-uint-ref b 0 (endianness big) 2) + #x3412))) + + (pass-if "bytevector-uint-set! [large]" + (let ((b (make-bytevector 16))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector->u8-list b) + '(253 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 255)))) + + (pass-if "bytevector-uint-{ref,set!} [large]" + (let ((b (make-bytevector 120))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector-uint-ref b 0 (endianness little) 16) + #xfffffffffffffffffffffffffffffffd))) + + (pass-if "bytevector-sint-ref [small]" + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (equal? (bytevector-sint-ref b 0 (endianness big) 2) + (bytevector-sint-ref b 1 (endianness little) 2) + -16))) + + (pass-if "bytevector-sint-ref [large]" + (let ((b (make-bytevector 50))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector-sint-ref b 0 (endianness little) 16) + -3))) + + (pass-if "bytevector-sint-set! [small]" + (let ((b (make-bytevector 3))) + (bytevector-sint-set! b 0 -16 (endianness big) 2) + (bytevector-sint-set! b 1 -16 (endianness little) 2) + (equal? (bytevector->u8-list b) + '(#xff #xf0 #xff))))) + + +(with-test-prefix "2.4 Operations on Integers of Arbitrary Size" + + (pass-if "bytevector->sint-list" + (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (equal? (bytevector->sint-list b (endianness little) 2) + '(513 -253 513 513)))) + + (pass-if "bytevector->uint-list" + (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1)))) + (equal? (bytevector->uint-list b (endianness big) 2) + '(513 65283 513 513)))) + + (pass-if "bytevector->uint-list [empty]" + (let ((b (make-bytevector 0))) + (null? (bytevector->uint-list b (endianness big) 2)))) + + (pass-if-exception "bytevector->sint-list [out-of-range]" + exception:out-of-range + (bytevector->sint-list (make-bytevector 6) (endianness little) 8)) + + (pass-if "bytevector->sint-list [off-by-one]" + (equal? (bytevector->sint-list (make-bytevector 31 #xff) + (endianness little) 8) + '(-1 -1 -1))) + + (pass-if "{sint,uint}-list->bytevector" + (let ((b1 (sint-list->bytevector '(513 -253 513 513) + (endianness little) 2)) + (b2 (uint-list->bytevector '(513 65283 513 513) + (endianness little) 2)) + (b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (and (bytevector=? b1 b2) + (bytevector=? b2 b3)))) + + (pass-if "sint-list->bytevector [limits]" + (bytevector=? (sint-list->bytevector '(-32768 32767) + (endianness big) 2) + (let ((bv (make-bytevector 4))) + (bytevector-u8-set! bv 0 #x80) + (bytevector-u8-set! bv 1 #x00) + (bytevector-u8-set! bv 2 #x7f) + (bytevector-u8-set! bv 3 #xff) + bv))) + + (pass-if-exception "sint-list->bytevector [out-of-range]" + exception:out-of-range + (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big) + 2)) + + (pass-if-exception "uint-list->bytevector [out-of-range]" + exception:out-of-range + (uint-list->bytevector '(0 -1) (endianness big) 2))) + + +(with-test-prefix "2.5 Operations on 16-Bit Integers" + + (pass-if "bytevector-u16-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u16-ref b 14 (endianness little)) + #xfdff) + (equal? (bytevector-u16-ref b 14 (endianness big)) + #xfffd)))) + + (pass-if "bytevector-s16-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s16-ref b 14 (endianness little)) + -513) + (equal? (bytevector-s16-ref b 14 (endianness big)) + -3)))) + + (pass-if "bytevector-s16-ref [unaligned]" + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -16))) + + (pass-if "bytevector-{u16,s16}-ref" + (let ((b (make-bytevector 2))) + (bytevector-u16-set! b 0 44444 (endianness little)) + (and (equal? (bytevector-u16-ref b 0 (endianness little)) + 44444) + (equal? (bytevector-s16-ref b 0 (endianness little)) + (- 44444 65536))))) + + (pass-if "bytevector-native-{u16,s16}-{ref,set!}" + (let ((b (make-bytevector 2))) + (bytevector-u16-native-set! b 0 44444) + (and (equal? (bytevector-u16-native-ref b 0) + 44444) + (equal? (bytevector-s16-native-ref b 0) + (- 44444 65536))))) + + (pass-if "bytevector-s16-{ref,set!} [unaligned]" + (let ((b (make-bytevector 3))) + (bytevector-s16-set! b 1 -77 (endianness little)) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -77)))) + + +(with-test-prefix "2.6 Operations on 32-bit Integers" + + (pass-if "bytevector-u32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u32-ref b 12 (endianness little)) + #xfdffffff) + (equal? (bytevector-u32-ref b 12 (endianness big)) + #xfffffffd)))) + + (pass-if "bytevector-s32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s32-ref b 12 (endianness little)) + -33554433) + (equal? (bytevector-s32-ref b 12 (endianness big)) + -3)))) + + (pass-if "bytevector-{u32,s32}-ref" + (let ((b (make-bytevector 4))) + (bytevector-u32-set! b 0 2222222222 (endianness little)) + (and (equal? (bytevector-u32-ref b 0 (endianness little)) + 2222222222) + (equal? (bytevector-s32-ref b 0 (endianness little)) + (- 2222222222 (expt 2 32)))))) + + (pass-if "bytevector-{u32,s32}-native-{ref,set!}" + (let ((b (make-bytevector 4))) + (bytevector-u32-native-set! b 0 2222222222) + (and (equal? (bytevector-u32-native-ref b 0) + 2222222222) + (equal? (bytevector-s32-native-ref b 0) + (- 2222222222 (expt 2 32))))))) + + +(with-test-prefix "2.7 Operations on 64-bit Integers" + + (pass-if "bytevector-u64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u64-ref b 8 (endianness little)) + #xfdffffffffffffff) + (equal? (bytevector-u64-ref b 8 (endianness big)) + #xfffffffffffffffd)))) + + (pass-if "bytevector-s64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s64-ref b 8 (endianness little)) + -144115188075855873) + (equal? (bytevector-s64-ref b 8 (endianness big)) + -3)))) + + (pass-if "bytevector-{u64,s64}-ref" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-set! b 0 big (endianness little)) + (and (equal? (bytevector-u64-ref b 0 (endianness little)) + big) + (equal? (bytevector-s64-ref b 0 (endianness little)) + (- big (expt 2 64)))))) + + (pass-if "bytevector-{u64,s64}-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-native-set! b 0 big) + (and (equal? (bytevector-u64-native-ref b 0) + big) + (equal? (bytevector-s64-native-ref b 0) + (- big (expt 2 64)))))) + + (pass-if "ref/set! with zero" + (let ((b (make-bytevector 8))) + (bytevector-s64-set! b 0 -1 (endianness big)) + (bytevector-u64-set! b 0 0 (endianness big)) + (= 0 (bytevector-u64-ref b 0 (endianness big)))))) + + +(with-test-prefix "2.8 Operations on IEEE-754 Representations" + + (pass-if "bytevector-ieee-single-native-{ref,set!}" + (let ((b (make-bytevector 4)) + (number 3.00)) + (bytevector-ieee-single-native-set! b 0 number) + (equal? (bytevector-ieee-single-native-ref b 0) + number))) + + (pass-if "bytevector-ieee-single-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-single-set! b 0 number (endianness little)) + (bytevector-ieee-single-set! b 4 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 0 (endianness little)) + (bytevector-ieee-single-ref b 4 (endianness big))))) + + (pass-if "bytevector-ieee-single-{ref,set!} [unaligned]" + (let ((b (make-bytevector 9)) + (number 3.14)) + (bytevector-ieee-single-set! b 1 number (endianness little)) + (bytevector-ieee-single-set! b 5 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 1 (endianness little)) + (bytevector-ieee-single-ref b 5 (endianness big))))) + + (pass-if "bytevector-ieee-double-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-double-native-set! b 0 number) + (equal? (bytevector-ieee-double-native-ref b 0) + number))) + + (pass-if "bytevector-ieee-double-{ref,set!}" + (let ((b (make-bytevector 16)) + (number 3.14)) + (bytevector-ieee-double-set! b 0 number (endianness little)) + (bytevector-ieee-double-set! b 8 number (endianness big)) + (equal? (bytevector-ieee-double-ref b 0 (endianness little)) + (bytevector-ieee-double-ref b 8 (endianness big)))))) + + +(define (with-locale locale thunk) + ;; Run THUNK under LOCALE. + (let ((original-locale (setlocale LC_ALL))) + (catch 'system-error + (lambda () + (setlocale LC_ALL locale)) + (lambda (key . args) + (throw 'unresolved))) + + (dynamic-wind + (lambda () + #t) + thunk + (lambda () + (setlocale LC_ALL original-locale))))) + +(define (with-latin1-locale thunk) + ;; Try out several ISO-8859-1 locales and run THUNK under the one that + ;; works (if any). + (define %locales + (map (lambda (name) + (string-append name ".ISO-8859-1")) + '("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))) + + (let loop ((locales %locales)) + (if (null? locales) + (throw 'unresolved) + (catch 'unresolved + (lambda () + (with-locale (car locales) thunk)) + (lambda (key . args) + (loop (cdr locales))))))) + + +;; Default to the C locale for the following tests. +(setlocale LC_ALL "C") + + +(with-test-prefix "2.9 Operations on Strings" + + (pass-if "string->utf8" + (let* ((str "hello, world") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (string-length str)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (pass-if "string->utf8 [latin-1]" + (with-latin1-locale + (lambda () + (let* ((str "hé, ça va bien ?") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (+ 2 (string-length str)))))))) + + (pass-if "string->utf16" + (let* ((str "hello, world") + (utf16 (string->utf16 str))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness big) 2)))))) + + (pass-if "string->utf16 [little]" + (let* ((str "hello, world") + (utf16 (string->utf16 str (endianness little)))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness little) 2)))))) + + + (pass-if "string->utf32" + (let* ((str "hello, world") + (utf32 (string->utf32 str))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness big) 4)))))) + + (pass-if "string->utf32 [little]" + (let* ((str "hello, world") + (utf32 (string->utf32 str (endianness little)))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness little) 4)))))) + + (pass-if "utf8->string" + (let* ((utf8 (u8-list->bytevector (map char->integer + (string->list "hello, world")))) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (bytevector-length utf8)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (pass-if "utf8->string [latin-1]" + (with-latin1-locale + (lambda () + (let* ((utf8 (string->utf8 "hé, ça va bien ?")) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (- (bytevector-length utf8) 2))))))) + + (pass-if "utf16->string" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 2)) + (str (utf16->string utf16))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness big) + 2)))))) + + (pass-if "utf16->string [little]" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 2)) + (str (utf16->string utf16 (endianness little)))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness little) + 2)))))) + (pass-if "utf32->string" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 4)) + (str (utf32->string utf32))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness big) + 4)))))) + + (pass-if "utf32->string [little]" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 4)) + (str (utf32->string utf32 (endianness little)))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness little) + 4))))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test new file mode 100644 index 000000000..204f37144 --- /dev/null +++ b/test-suite/tests/r6rs-ports.test @@ -0,0 +1,455 @@ +;;;; r6rs-ports.test --- Exercise the R6RS I/O port API. +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-io-ports) + :use-module (test-suite lib) + :use-module (srfi srfi-1) + :use-module (srfi srfi-11) + :use-module (rnrs io ports) + :use-module (rnrs bytevector)) + +;;; All these tests assume Guile 1.8's port system, where characters are +;;; treated as octets. + + +(with-test-prefix "7.2.5 End-of-File Object" + + (pass-if "eof-object" + (and (eqv? (eof-object) (eof-object)) + (eq? (eof-object) (eof-object))))) + + +(with-test-prefix "7.2.8 Binary Input" + + (pass-if "get-u8" + (let ((port (open-input-string "A"))) + (and (= (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "lookahead-u8" + (let ((port (open-input-string "A"))) + (and (= (char->integer #\A) (lookahead-u8 port)) + (not (eof-object? port)) + (= (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "get-bytevector-n [short]" + (let* ((port (open-input-string "GNU Guile")) + (bv (get-bytevector-n port 4))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-n [long]" + (let* ((port (open-input-string "GNU Guile")) + (bv (get-bytevector-n port 256))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU Guile")))))) + + (pass-if-exception "get-bytevector-n with closed port" + exception:wrong-type-arg + + (let ((port (%make-void-port "r"))) + + (close-port port) + (get-bytevector-n port 3))) + + (pass-if "get-bytevector-n! [short]" + (let* ((port (open-input-string "GNU Guile")) + (bv (make-bytevector 4)) + (read (get-bytevector-n! port bv 0 4))) + (and (equal? read 4) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-n! [long]" + (let* ((str "GNU Guile") + (port (open-input-string str)) + (bv (make-bytevector 256)) + (read (get-bytevector-n! port bv 0 256))) + (and (equal? read (string-length str)) + (equal? (map (lambda (i) + (bytevector-u8-ref bv i)) + (iota read)) + (map char->integer (string->list str)))))) + + (pass-if "get-bytevector-some [simple]" + (let* ((str "GNU Guile") + (port (open-input-string str)) + (bv (get-bytevector-some port))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list str)))))) + + (pass-if "get-bytevector-some [only-some]" + (let* ((str "GNU Guile") + (index 0) + (port (make-soft-port + (vector #f #f #f + (lambda () + (if (>= index (string-length str)) + (eof-object) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + c))) + (lambda () #t) + (lambda () + ;; Number of readily available octets: falls to + ;; zero after 4 octets have been read. + (- 4 (modulo index 5)))) + "r")) + (bv (get-bytevector-some port))) + (and (bytevector? bv) + (= index 4) + (= (bytevector-length bv) index) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-all" + (let* ((str "GNU Guile") + (index 0) + (port (make-soft-port + (vector #f #f #f + (lambda () + (if (>= index (string-length str)) + (eof-object) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + c))) + (lambda () #t) + (let ((cont? #f)) + (lambda () + ;; Number of readily available octets: falls to + ;; zero after 4 octets have been read and then + ;; starts again. + (let ((a (if cont? + (- (string-length str) index) + (- 4 (modulo index 5))))) + (if (= 0 a) (set! cont? #t)) + a)))) + "r")) + (bv (get-bytevector-all port))) + (and (bytevector? bv) + (= index (string-length str)) + (= (bytevector-length bv) (string-length str)) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list str))))))) + + +(define (make-soft-output-port) + (let* ((bv (make-bytevector 1024)) + (read-index 0) + (write-index 0) + (write-char (lambda (chr) + (bytevector-u8-set! bv write-index + (char->integer chr)) + (set! write-index (+ 1 write-index))))) + (make-soft-port + (vector write-char + (lambda (str) ;; write-string + (for-each write-char (string->list str))) + (lambda () #t) ;; flush-output + (lambda () ;; read-char + (if (>= read-index (bytevector-length bv)) + (eof-object) + (let ((c (bytevector-u8-ref bv read-index))) + (set! read-index (+ read-index 1)) + (integer->char c)))) + (lambda () #t)) ;; close-port + "rw"))) + +(with-test-prefix "7.2.11 Binary Output" + + (pass-if "put-u8" + (let ((port (make-soft-output-port))) + (put-u8 port 77) + (equal? (get-u8 port) 77))) + + (pass-if "put-bytevector [2 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256))) + (put-bytevector port bv) + (equal? (bytevector->u8-list bv) + (bytevector->u8-list + (get-bytevector-n port (bytevector-length bv)))))) + + (pass-if "put-bytevector [3 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256)) + (start 10)) + (put-bytevector port bv start) + (equal? (drop (bytevector->u8-list bv) start) + (bytevector->u8-list + (get-bytevector-n port (- (bytevector-length bv) start)))))) + + (pass-if "put-bytevector [4 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256)) + (start 10) + (count 77)) + (put-bytevector port bv start count) + (equal? (take (drop (bytevector->u8-list bv) start) count) + (bytevector->u8-list + (get-bytevector-n port count))))) + + (pass-if-exception "put-bytevector with closed port" + exception:wrong-type-arg + + (let* ((bv (make-bytevector 4)) + (port (%make-void-port "w"))) + + (close-port port) + (put-bytevector port bv)))) + + +(with-test-prefix "7.2.7 Input Ports" + + ;; This section appears here so that it can use the binary input + ;; primitives. + + (pass-if "open-bytevector-input-port [1 arg]" + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv)) + (read-to-string + (lambda (port) + (let loop ((chr (read-char port)) + (result '())) + (if (eof-object? chr) + (apply string (reverse! result)) + (loop (read-char port) + (cons chr result))))))) + + (equal? (read-to-string port) str))) + + (pass-if-exception "bytevector-input-port is read-only" + exception:wrong-type-arg + + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv #f))) + + (write "hello" port))) + + (pass-if "bytevector input port supports seeking" + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv #f))) + + (and (port-has-port-position? port) + (= 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (= 6 (port-position port))) + (bytevector=? (get-bytevector-all port) + (u8-list->bytevector + (map char->integer (string->list "Port!"))))))) + + (pass-if-exception "make-custom-binary-input-port [wrong-num-args]" + exception:wrong-num-args + + ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully + ;; optional. + (make-custom-binary-input-port "port" (lambda args #t))) + + (pass-if "make-custom-binary-input-port" + (let* ((source (make-bytevector 7777)) + (read! (let ((pos 0) + (len (bytevector-length source))) + (lambda (bv start count) + (let ((amount (min count (- len pos)))) + (if (> amount 0) + (bytevector-copy! source pos + bv start amount)) + (set! pos (+ pos amount)) + amount)))) + (port (make-custom-binary-input-port "the port" read! + #f #f #f))) + + (bytevector=? (get-bytevector-all port) source))) + + (pass-if "custom binary input port does not support `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input-port "the port" read! + #f #f #f))) + (not (or (port-has-port-position? port) + (port-has-set-port-position!? port))))) + + (pass-if "custom binary input port supports `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (get-pos (lambda () + (port-position source))) + (set-pos! (lambda (pos) + (set-port-position! source pos))) + (port (make-custom-binary-input-port "the port" read! + get-pos set-pos! #f))) + + (and (port-has-port-position? port) + (= 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (= 6 (port-position port))) + (bytevector=? (get-bytevector-all port) + (u8-list->bytevector + (map char->integer (string->list "Port!"))))))) + + (pass-if "custom binary input port `close-proc' is called" + (let* ((closed? #f) + (read! (lambda (bv start count) 0)) + (get-pos (lambda () 0)) + (set-pos! (lambda (pos) #f)) + (close! (lambda () (set! closed? #t))) + (port (make-custom-binary-input-port "the port" read! + get-pos set-pos! + close!))) + + (close-port port) + closed?))) + + +(with-test-prefix "8.2.10 Output ports" + + (pass-if "open-bytevector-output-port" + (let-values (((port get-content) + (open-bytevector-output-port #f))) + (let ((source (make-bytevector 7777))) + (put-bytevector port source) + (and (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "open-bytevector-output-port [put-u8]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (put-u8 port 77) + (and (bytevector=? (get-content) (make-bytevector 1 77)) + (bytevector=? (get-content) (make-bytevector 0))))) + + (pass-if "open-bytevector-output-port [display]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (display "hello" port) + (and (bytevector=? (get-content) (string->utf8 "hello")) + (bytevector=? (get-content) (make-bytevector 0))))) + + (pass-if "bytevector output port supports `port-position'" + (let-values (((port get-content) + (open-bytevector-output-port))) + (let ((source (make-bytevector 7777)) + (overwrite (make-bytevector 33))) + (and (port-has-port-position? port) + (port-has-set-port-position!? port) + (begin + (put-bytevector port source) + (= (bytevector-length source) + (port-position port))) + (begin + (set-port-position! port 10) + (= 10 (port-position port))) + (begin + (put-bytevector port overwrite) + (bytevector-copy! overwrite 0 source 10 + (bytevector-length overwrite)) + (= (port-position port) + (+ 10 (bytevector-length overwrite)))) + (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "make-custom-binary-output" + (let ((port (make-custom-binary-output-port "cbop" + (lambda (x y z) 0) + #f #f #f))) + (and (output-port? port) + (binary-port? port) + (not (port-has-port-position? port)) + (not (port-has-set-port-position!? port))))) + + (pass-if "make-custom-binary-output-port [partial writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (bytevector-u8-set! sink sink-pos u8) + (set! sink-pos (+ 1 sink-pos)) + 1)))) + (port (make-custom-binary-output-port "cbop" write! + #f #f #f))) + (put-bytevector port source) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if "make-custom-binary-output-port [full writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (begin + (bytevector-copy! bv start + sink sink-pos + count) + (set! sink-pos (+ sink-pos count)) + count)))) + (port (make-custom-binary-output-port "cbop" write! + #f #f #f))) + (put-bytevector port source) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: -- cgit v1.2.3