* module/Makefile.am: Add tree-il sources.
* module/ice-9/compile-psyntax.scm: Adjust for sc-expand producing
tree-il in compile mode.
* module/ice-9/psyntax.scm: Switch from expand-support to tree-il for
generating output in compile mode. Completely generate tree-il -- the
output wasn't Scheme before, but now it's completely not Scheme.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/scheme/compile-ghil.scm: Strip structures using
tree-il, not expand-support.
* module/language/tree-il.scm:
* module/language/tree-il/spec.scm
* module/language/tree-il/compile-glil.scm: New language. It will compile
to GLIL, though it doesn't yet.
# 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 \
\
+ language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \
\
$(SCHEME_LANG_SOURCES) \
+ $(TREE_IL_LANG_SOURCES) \
$(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
language/scheme/compile-ghil.scm language/scheme/spec.scm \
language/scheme/inline.scm
+TREE_IL_LANG_SOURCES = \
+ language/tree-il/spec.scm language/tree-il/compile-glil.scm
+
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm
-(use-modules (ice-9 expand-support))
+(use-modules (language tree-il))
(let ((source (list-ref (command-line) 1))
(target (list-ref (command-line) 2)))
(let ((in (open-input-file source))
(close-port out)
(close-port in))
(begin
- (write (strip-expansion-structures
+ (write (tree-il->scheme
(sc-expand x 'c '(compile load eval)))
out)
(newline out)
-(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) (let andmap58 ((first59 first56)) (let ((x60 (car first59)) (first61 (cdr first59))) (if (null? first61) (f57 x60) (and (f57 x60) (andmap58 first61))))) (let andmap62 ((first63 first56) (rest64 rest55)) (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)))))))))) (letrec ((lambda-var-list155 (lambda (vars330) (let lvl331 ((vars332 vars330) (ls333 (quote ())) (w334 (quote (())))) (cond ((pair? vars332) (lvl331 (cdr vars332) (cons (wrap134 (car vars332) w334 #f) ls333) w334)) ((id?106 vars332) (cons (wrap134 vars332 w334 #f) ls333)) ((null? vars332) ls333) ((syntax-object?90 vars332) (lvl331 (syntax-object-expression91 vars332) ls333 (join-wraps125 w334 (syntax-object-wrap92 vars332)))) ((annotation? vars332) (lvl331 (annotation-expression vars332) ls333 w334)) (else (cons vars332 ls333)))))) (gen-var154 (lambda (id335) (let ((id336 (if (syntax-object?90 id335) (syntax-object-expression91 id335) id335))) (if (annotation? id336) (build-annotated79 (annotation-source id336) (gensym (symbol->string (annotation-expression id336)))) (build-annotated79 #f (gensym (symbol->string id336))))))) (strip153 (lambda (x337 w338) (if (memq (quote top) (wrap-marks109 w338)) (if (or (annotation? x337) (and (pair? x337) (annotation? (car x337)))) (strip-annotation152 x337 #f) x337) (let f339 ((x340 x337)) (cond ((syntax-object?90 x340) (strip153 (syntax-object-expression91 x340) (syntax-object-wrap92 x340))) ((pair? x340) (let ((a341 (f339 (car x340))) (d342 (f339 (cdr x340)))) (if (and (eq? a341 (car x340)) (eq? d342 (cdr x340))) x340 (cons a341 d342)))) ((vector? x340) (let ((old343 (vector->list x340))) (let ((new344 (map f339 old343))) (if (and-map*17 eq? old343 new344) x340 (list->vector new344))))) (else x340)))))) (strip-annotation152 (lambda (x345 parent346) (cond ((pair? x345) (let ((new347 (cons #f #f))) (begin (if parent346 (set-annotation-stripped! parent346 new347)) (set-car! new347 (strip-annotation152 (car x345) #f)) (set-cdr! new347 (strip-annotation152 (cdr x345) #f)) new347))) ((annotation? x345) (or (annotation-stripped x345) (strip-annotation152 (annotation-expression x345) x345))) ((vector? x345) (let ((new348 (make-vector (vector-length x345)))) (begin (if parent346 (set-annotation-stripped! parent346 new348)) (let loop349 ((i350 (- (vector-length x345) 1))) (unless (fx<74 i350 0) (vector-set! new348 i350 (strip-annotation152 (vector-ref x345 i350) #f)) (loop349 (fx-72 i350 1)))) new348))) (else x345)))) (ellipsis?151 (lambda (x351) (and (nonsymbol-id?105 x351) (free-id=?129 x351 (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 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-void150 (lambda () (build-annotated79 #f (cons (build-annotated79 #f (quote if)) (quote (#f #f)))))) (eval-local-transformer149 (lambda (expanded352 mod353) (let ((p354 (local-eval-hook76 expanded352 mod353))) (if (procedure? p354) p354 (syntax-violation #f "nonprocedure transformer" p354))))) (chi-local-syntax148 (lambda (rec?355 e356 r357 w358 s359 mod360 k361) ((lambda (tmp362) ((lambda (tmp363) (if tmp363 (apply (lambda (_364 id365 val366 e1367 e2368) (let ((ids369 id365)) (if (not (valid-bound-ids?131 ids369)) (syntax-violation #f "duplicate bound keyword" e356) (let ((labels371 (gen-labels112 ids369))) (let ((new-w372 (make-binding-wrap123 ids369 labels371 w358))) (k361 (cons e1367 e2368) (extend-env100 labels371 (let ((w374 (if rec?355 new-w372 w358)) (trans-r375 (macros-only-env102 r357))) (map (lambda (x376) (cons (quote macro) (eval-local-transformer149 (chi142 x376 trans-r375 w374 mod360) mod360))) val366)) r357) new-w372 s359 mod360)))))) tmp363) ((lambda (_378) (syntax-violation #f "bad local syntax definition" (source-wrap135 e356 w358 s359 mod360))) tmp362))) ($sc-dispatch tmp362 (quote (any #(each (any any)) any . each-any))))) e356))) (chi-lambda-clause147 (lambda (e379 docstring380 c381 r382 w383 mod384 k385) ((lambda (tmp386) ((lambda (tmp387) (if (if tmp387 (apply (lambda (args388 doc389 e1390 e2391) (and (string? (syntax->datum doc389)) (not docstring380))) tmp387) #f) (apply (lambda (args392 doc393 e1394 e2395) (chi-lambda-clause147 e379 doc393 (cons args392 (cons e1394 e2395)) r382 w383 mod384 k385)) tmp387) ((lambda (tmp397) (if tmp397 (apply (lambda (id398 e1399 e2400) (let ((ids401 id398)) (if (not (valid-bound-ids?131 ids401)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels403 (gen-labels112 ids401)) (new-vars404 (map gen-var154 ids401))) (k385 new-vars404 docstring380 (chi-body146 (cons e1399 e2400) e379 (extend-var-env101 labels403 new-vars404 r382) (make-binding-wrap123 ids401 labels403 w383) mod384)))))) tmp397) ((lambda (tmp406) (if tmp406 (apply (lambda (ids407 e1408 e2409) (let ((old-ids410 (lambda-var-list155 ids407))) (if (not (valid-bound-ids?131 old-ids410)) (syntax-violation (quote lambda) "invalid parameter list" e379) (let ((labels411 (gen-labels112 old-ids410)) (new-vars412 (map gen-var154 old-ids410))) (k385 (let f413 ((ls1414 (cdr new-vars412)) (ls2415 (car new-vars412))) (if (null? ls1414) ls2415 (f413 (cdr ls1414) (cons (car ls1414) ls2415)))) docstring380 (chi-body146 (cons e1408 e2409) e379 (extend-var-env101 labels411 new-vars412 r382) (make-binding-wrap123 old-ids410 labels411 w383) mod384)))))) tmp406) ((lambda (_417) (syntax-violation (quote lambda) "bad lambda" e379)) tmp386))) ($sc-dispatch tmp386 (quote (any any . each-any)))))) ($sc-dispatch tmp386 (quote (each-any any . each-any)))))) ($sc-dispatch tmp386 (quote (any any any . each-any))))) c381))) (chi-body146 (lambda (body418 outer-form419 r420 w421 mod422) (let ((r423 (cons (quote ("placeholder" placeholder)) r420))) (let ((ribcage424 (make-ribcage113 (quote ()) (quote ()) (quote ())))) (let ((w425 (make-wrap108 (wrap-marks109 w421) (cons ribcage424 (wrap-subst110 w421))))) (let parse426 ((body427 (map (lambda (x433) (cons r423 (wrap134 x433 w425 mod422))) body418)) (ids428 (quote ())) (labels429 (quote ())) (vars430 (quote ())) (vals431 (quote ())) (bindings432 (quote ()))) (if (null? body427) (syntax-violation #f "no expressions in body" outer-form419) (let ((e434 (cdar body427)) (er435 (caar body427))) (call-with-values (lambda () (syntax-type140 e434 er435 (quote (())) #f ribcage424 mod422)) (lambda (type436 value437 e438 w439 s440 mod441) (let ((t442 type436)) (if (memv t442 (quote (define-form))) (let ((id443 (wrap134 value437 w439 mod441)) (label444 (gen-label111))) (let ((var445 (gen-var154 id443))) (begin (extend-ribcage!122 ribcage424 id443 label444) (parse426 (cdr body427) (cons id443 ids428) (cons label444 labels429) (cons var445 vars430) (cons (cons er435 (wrap134 e438 w439 mod441)) vals431) (cons (cons (quote lexical) var445) bindings432))))) (if (memv t442 (quote (define-syntax-form))) (let ((id446 (wrap134 value437 w439 mod441)) (label447 (gen-label111))) (begin (extend-ribcage!122 ribcage424 id446 label447) (parse426 (cdr body427) (cons id446 ids428) (cons label447 labels429) vars430 vals431 (cons (cons (quote macro) (cons er435 (wrap134 e438 w439 mod441))) bindings432)))) (if (memv t442 (quote (begin-form))) ((lambda (tmp448) ((lambda (tmp449) (if tmp449 (apply (lambda (_450 e1451) (parse426 (let f452 ((forms453 e1451)) (if (null? forms453) (cdr body427) (cons (cons er435 (wrap134 (car forms453) w439 mod441)) (f452 (cdr forms453))))) ids428 labels429 vars430 vals431 bindings432)) tmp449) (syntax-violation #f "source expression failed to match any pattern" tmp448))) ($sc-dispatch tmp448 (quote (any . each-any))))) e438) (if (memv t442 (quote (local-syntax-form))) (chi-local-syntax148 value437 e438 er435 w439 s440 mod441 (lambda (forms455 er456 w457 s458 mod459) (parse426 (let f460 ((forms461 forms455)) (if (null? forms461) (cdr body427) (cons (cons er456 (wrap134 (car forms461) w457 mod459)) (f460 (cdr forms461))))) ids428 labels429 vars430 vals431 bindings432))) (if (null? ids428) (build-sequence85 #f (map (lambda (x462) (chi142 (cdr x462) (car x462) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))) (begin (if (not (valid-bound-ids?131 ids428)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form419)) (let loop463 ((bs464 bindings432) (er-cache465 #f) (r-cache466 #f)) (if (not (null? bs464)) (let ((b467 (car bs464))) (if (eq? (car b467) (quote macro)) (let ((er468 (cadr b467))) (let ((r-cache469 (if (eq? er468 er-cache465) r-cache466 (macros-only-env102 er468)))) (begin (set-cdr! b467 (eval-local-transformer149 (chi142 (cddr b467) r-cache469 (quote (())) mod441) mod441)) (loop463 (cdr bs464) er468 r-cache469)))) (loop463 (cdr bs464) er-cache465 r-cache466))))) (set-cdr! r423 (extend-env100 labels429 bindings432 (cdr r423))) (build-letrec88 #f vars430 (map (lambda (x470) (chi142 (cdr x470) (car x470) (quote (())) mod441)) vals431) (build-sequence85 #f (map (lambda (x471) (chi142 (cdr x471) (car x471) (quote (())) mod441)) (cons (cons er435 (source-wrap135 e438 w439 s440 mod441)) (cdr body427)))))))))))))))))))))) (chi-macro145 (lambda (p472 e473 r474 w475 rib476 mod477) (letrec ((rebuild-macro-output478 (lambda (x479 m480) (cond ((pair? x479) (cons (rebuild-macro-output478 (car x479) m480) (rebuild-macro-output478 (cdr x479) m480))) ((syntax-object?90 x479) (let ((w481 (syntax-object-wrap92 x479))) (let ((ms482 (wrap-marks109 w481)) (s483 (wrap-subst110 w481))) (if (and (pair? ms482) (eq? (car ms482) #f)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cdr ms482) (if rib476 (cons rib476 (cdr s483)) (cdr s483))) (syntax-object-module93 x479)) (make-syntax-object89 (syntax-object-expression91 x479) (make-wrap108 (cons m480 ms482) (if rib476 (cons rib476 (cons (quote shift) s483)) (cons (quote shift) s483))) (let ((pmod484 (procedure-module p472))) (if pmod484 (cons (quote hygiene) (module-name pmod484)) (quote (hygiene guile))))))))) ((vector? x479) (let ((n485 (vector-length x479))) (let ((v486 (make-vector n485))) (let doloop487 ((i488 0)) (if (fx=73 i488 n485) v486 (begin (vector-set! v486 i488 (rebuild-macro-output478 (vector-ref x479 i488) m480)) (doloop487 (fx+71 i488 1)))))))) ((symbol? x479) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap135 e473 w475 s mod477) x479)) (else x479))))) (rebuild-macro-output478 (p472 (wrap134 e473 (anti-mark121 w475) mod477)) (string #\m))))) (chi-application144 (lambda (x489 e490 r491 w492 s493 mod494) ((lambda (tmp495) ((lambda (tmp496) (if tmp496 (apply (lambda (e0497 e1498) (build-annotated79 s493 (cons x489 (map (lambda (e499) (chi142 e499 r491 w492 mod494)) e1498)))) tmp496) (syntax-violation #f "source expression failed to match any pattern" tmp495))) ($sc-dispatch tmp495 (quote (any . each-any))))) e490))) (chi-expr143 (lambda (type501 value502 e503 r504 w505 s506 mod507) (let ((t508 type501)) (if (memv t508 (quote (lexical))) (build-lexical-reference80 (quote value) s506 e503 value502) (if (memv t508 (quote (core external-macro))) (value502 e503 r504 w505 s506 mod507) (if (memv t508 (quote (module-ref))) (call-with-values (lambda () (value502 e503)) (lambda (id509 mod510) (build-global-reference82 s506 id509 mod510))) (if (memv t508 (quote (lexical-call))) (chi-application144 (build-lexical-reference80 (quote fun) (source-annotation97 (car e503)) (car e503) value502) e503 r504 w505 s506 mod507) (if (memv t508 (quote (global-call))) (chi-application144 (build-global-reference82 (source-annotation97 (car e503)) value502 (if (syntax-object?90 (car e503)) (syntax-object-module93 (car e503)) mod507)) e503 r504 w505 s506 mod507) (if (memv t508 (quote (constant))) (build-data84 s506 (strip153 (source-wrap135 e503 w505 s506 mod507) (quote (())))) (if (memv t508 (quote (global))) (build-global-reference82 s506 value502 mod507) (if (memv t508 (quote (call))) (chi-application144 (chi142 (car e503) r504 w505 mod507) e503 r504 w505 s506 mod507) (if (memv t508 (quote (begin-form))) ((lambda (tmp511) ((lambda (tmp512) (if tmp512 (apply (lambda (_513 e1514 e2515) (chi-sequence136 (cons e1514 e2515) r504 w505 s506 mod507)) tmp512) (syntax-violation #f "source expression failed to match any pattern" tmp511))) ($sc-dispatch tmp511 (quote (any any . each-any))))) e503) (if (memv t508 (quote (local-syntax-form))) (chi-local-syntax148 value502 e503 r504 w505 s506 mod507 chi-sequence136) (if (memv t508 (quote (eval-when-form))) ((lambda (tmp517) ((lambda (tmp518) (if tmp518 (apply (lambda (_519 x520 e1521 e2522) (let ((when-list523 (chi-when-list139 e503 x520 w505))) (if (memq (quote eval) when-list523) (chi-sequence136 (cons e1521 e2522) r504 w505 s506 mod507) (chi-void150)))) tmp518) (syntax-violation #f "source expression failed to match any pattern" tmp517))) ($sc-dispatch tmp517 (quote (any each-any any . each-any))))) e503) (if (memv t508 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e503 (wrap134 value502 w505 mod507)) (if (memv t508 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap135 e503 w505 s506 mod507)) (if (memv t508 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap135 e503 w505 s506 mod507)) (syntax-violation #f "unexpected syntax" (source-wrap135 e503 w505 s506 mod507))))))))))))))))))) (chi142 (lambda (e526 r527 w528 mod529) (call-with-values (lambda () (syntax-type140 e526 r527 w528 #f #f mod529)) (lambda (type530 value531 e532 w533 s534 mod535) (chi-expr143 type530 value531 e532 r527 w533 s534 mod535))))) (chi-top141 (lambda (e536 r537 w538 m539 esew540 mod541) (call-with-values (lambda () (syntax-type140 e536 r537 w538 #f #f mod541)) (lambda (type549 value550 e551 w552 s553 mod554) (let ((t555 type549)) (if (memv t555 (quote (begin-form))) ((lambda (tmp556) ((lambda (tmp557) (if tmp557 (apply (lambda (_558) (chi-void150)) tmp557) ((lambda (tmp559) (if tmp559 (apply (lambda (_560 e1561 e2562) (chi-top-sequence137 (cons e1561 e2562) r537 w552 s553 m539 esew540 mod554)) tmp559) (syntax-violation #f "source expression failed to match any pattern" tmp556))) ($sc-dispatch tmp556 (quote (any any . each-any)))))) ($sc-dispatch tmp556 (quote (any))))) e551) (if (memv t555 (quote (local-syntax-form))) (chi-local-syntax148 value550 e551 r537 w552 s553 mod554 (lambda (body564 r565 w566 s567 mod568) (chi-top-sequence137 body564 r565 w566 s567 m539 esew540 mod568))) (if (memv t555 (quote (eval-when-form))) ((lambda (tmp569) ((lambda (tmp570) (if tmp570 (apply (lambda (_571 x572 e1573 e2574) (let ((when-list575 (chi-when-list139 e551 x572 w552)) (body576 (cons e1573 e2574))) (cond ((eq? m539 (quote e)) (if (memq (quote eval) when-list575) (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) (chi-void150))) ((memq (quote load) when-list575) (if (or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (chi-top-sequence137 body576 r537 w552 s553 (quote c&e) (quote (compile load)) mod554) (if (memq m539 (quote (c c&e))) (chi-top-sequence137 body576 r537 w552 s553 (quote c) (quote (load)) mod554) (chi-void150)))) ((or (memq (quote compile) when-list575) (and (eq? m539 (quote c&e)) (memq (quote eval) when-list575))) (top-level-eval-hook75 (chi-top-sequence137 body576 r537 w552 s553 (quote e) (quote (eval)) mod554) mod554) (chi-void150)) (else (chi-void150))))) tmp570) (syntax-violation #f "source expression failed to match any pattern" tmp569))) ($sc-dispatch tmp569 (quote (any each-any any . each-any))))) e551) (if (memv t555 (quote (define-syntax-form))) (let ((n579 (id-var-name128 value550 w552)) (r580 (macros-only-env102 r537))) (let ((t581 m539)) (if (memv t581 (quote (c))) (if (memq (quote compile) esew540) (let ((e582 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e582 mod554) (if (memq (quote load) esew540) e582 (chi-void150)))) (if (memq (quote load) esew540) (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) (chi-void150))) (if (memv t581 (quote (c&e))) (let ((e583 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)))) (begin (top-level-eval-hook75 e583 mod554) e583)) (begin (if (memq (quote eval) esew540) (top-level-eval-hook75 (chi-install-global138 n579 (chi142 e551 r580 w552 mod554)) mod554)) (chi-void150)))))) (if (memv t555 (quote (define-form))) (let ((n584 (id-var-name128 value550 w552))) (let ((type585 (binding-type98 (lookup103 n584 r537 mod554)))) (let ((t586 type585)) (if (memv t586 (quote (global core macro module-ref))) (let ((x587 (build-annotated79 s553 (list (quote define) n584 (chi142 e551 r537 w552 mod554))))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x587 mod554)) x587)) (if (memv t586 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e551 (wrap134 value550 w552 mod554)) (syntax-violation #f "cannot define keyword at top level" e551 (wrap134 value550 w552 mod554))))))) (let ((x588 (chi-expr143 type549 value550 e551 r537 w552 s553 mod554))) (begin (if (eq? m539 (quote c&e)) (top-level-eval-hook75 x588 mod554)) x588)))))))))))) (syntax-type140 (lambda (e589 r590 w591 s592 rib593 mod594) (cond ((symbol? e589) (let ((n595 (id-var-name128 e589 w591))) (let ((b596 (lookup103 n595 r590 mod594))) (let ((type597 (binding-type98 b596))) (let ((t598 type597)) (if (memv t598 (quote (lexical))) (values type597 (binding-value99 b596) e589 w591 s592 mod594) (if (memv t598 (quote (global))) (values type597 n595 e589 w591 s592 mod594) (if (memv t598 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b596) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (values type597 (binding-value99 b596) e589 w591 s592 mod594))))))))) ((pair? e589) (let ((first599 (car e589))) (if (id?106 first599) (let ((n600 (id-var-name128 first599 w591))) (let ((b601 (lookup103 n600 r590 (or (and (syntax-object?90 first599) (syntax-object-module93 first599)) mod594)))) (let ((type602 (binding-type98 b601))) (let ((t603 type602)) (if (memv t603 (quote (lexical))) (values (quote lexical-call) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (global))) (values (quote global-call) n600 e589 w591 s592 mod594) (if (memv t603 (quote (macro))) (syntax-type140 (chi-macro145 (binding-value99 b601) e589 r590 w591 rib593 mod594) r590 (quote (())) s592 rib593 mod594) (if (memv t603 (quote (core external-macro module-ref))) (values type602 (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value99 b601) e589 w591 s592 mod594) (if (memv t603 (quote (begin))) (values (quote begin-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (eval-when))) (values (quote eval-when-form) #f e589 w591 s592 mod594) (if (memv t603 (quote (define))) ((lambda (tmp604) ((lambda (tmp605) (if (if tmp605 (apply (lambda (_606 name607 val608) (id?106 name607)) tmp605) #f) (apply (lambda (_609 name610 val611) (values (quote define-form) name610 val611 w591 s592 mod594)) tmp605) ((lambda (tmp612) (if (if tmp612 (apply (lambda (_613 name614 args615 e1616 e2617) (and (id?106 name614) (valid-bound-ids?131 (lambda-var-list155 args615)))) tmp612) #f) (apply (lambda (_618 name619 args620 e1621 e2622) (values (quote define-form) (wrap134 name619 w591 mod594) (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 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))) (wrap134 (cons args620 (cons e1621 e2622)) w591 mod594)) (quote (())) s592 mod594)) tmp612) ((lambda (tmp624) (if (if tmp624 (apply (lambda (_625 name626) (id?106 name626)) tmp624) #f) (apply (lambda (_627 name628) (values (quote define-form) (wrap134 name628 w591 mod594) (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 build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated 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 build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated 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 build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated 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 (())) s592 mod594)) tmp624) (syntax-violation #f "source expression failed to match any pattern" tmp604))) ($sc-dispatch tmp604 (quote (any any)))))) ($sc-dispatch tmp604 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp604 (quote (any any any))))) e589) (if (memv t603 (quote (define-syntax))) ((lambda (tmp629) ((lambda (tmp630) (if (if tmp630 (apply (lambda (_631 name632 val633) (id?106 name632)) tmp630) #f) (apply (lambda (_634 name635 val636) (values (quote define-syntax-form) name635 val636 w591 s592 mod594)) tmp630) (syntax-violation #f "source expression failed to match any pattern" tmp629))) ($sc-dispatch tmp629 (quote (any any any))))) e589) (values (quote call) #f e589 w591 s592 mod594)))))))))))))) (values (quote call) #f e589 w591 s592 mod594)))) ((syntax-object?90 e589) (syntax-type140 (syntax-object-expression91 e589) r590 (join-wraps125 w591 (syntax-object-wrap92 e589)) #f rib593 (or (syntax-object-module93 e589) mod594))) ((annotation? e589) (syntax-type140 (annotation-expression e589) r590 w591 (annotation-source e589) rib593 mod594)) ((self-evaluating? e589) (values (quote constant) #f e589 w591 s592 mod594)) (else (values (quote other) #f e589 w591 s592 mod594))))) (chi-when-list139 (lambda (e637 when-list638 w639) (let f640 ((when-list641 when-list638) (situations642 (quote ()))) (if (null? when-list641) situations642 (f640 (cdr when-list641) (cons (let ((x643 (car when-list641))) (cond ((free-id=?129 x643 (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 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=?129 x643 (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 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=?129 x643 (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 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" e637 (wrap134 x643 w639 #f))))) situations642)))))) (chi-install-global138 (lambda (name644 e645) (build-annotated79 #f (list (quote define) name644 (if (let ((v646 (module-variable (current-module) name644))) (and v646 (variable-bound? v646) (macro? (variable-ref v646)) (not (eq? (macro-type (variable-ref v646)) (quote syncase-macro))))) (build-annotated79 #f (list (build-annotated79 #f (quote make-extended-syncase-macro)) (build-annotated79 #f (list (build-annotated79 #f (quote module-ref)) (build-annotated79 #f (quote (current-module))) (build-data84 #f name644))) (build-data84 #f (quote macro)) e645)) (build-annotated79 #f (list (build-annotated79 #f (quote make-syncase-macro)) (build-data84 #f (quote macro)) e645))))))) (chi-top-sequence137 (lambda (body647 r648 w649 s650 m651 esew652 mod653) (build-sequence85 s650 (let dobody654 ((body655 body647) (r656 r648) (w657 w649) (m658 m651) (esew659 esew652) (mod660 mod653)) (if (null? body655) (quote ()) (let ((first661 (chi-top141 (car body655) r656 w657 m658 esew659 mod660))) (cons first661 (dobody654 (cdr body655) r656 w657 m658 esew659 mod660)))))))) (chi-sequence136 (lambda (body662 r663 w664 s665 mod666) (build-sequence85 s665 (let dobody667 ((body668 body662) (r669 r663) (w670 w664) (mod671 mod666)) (if (null? body668) (quote ()) (let ((first672 (chi142 (car body668) r669 w670 mod671))) (cons first672 (dobody667 (cdr body668) r669 w670 mod671)))))))) (source-wrap135 (lambda (x673 w674 s675 defmod676) (wrap134 (if s675 (make-annotation x673 s675 #f) x673) w674 defmod676))) (wrap134 (lambda (x677 w678 defmod679) (cond ((and (null? (wrap-marks109 w678)) (null? (wrap-subst110 w678))) x677) ((syntax-object?90 x677) (make-syntax-object89 (syntax-object-expression91 x677) (join-wraps125 w678 (syntax-object-wrap92 x677)) (syntax-object-module93 x677))) ((null? x677) x677) (else (make-syntax-object89 x677 w678 defmod679))))) (bound-id-member?133 (lambda (x680 list681) (and (not (null? list681)) (or (bound-id=?130 x680 (car list681)) (bound-id-member?133 x680 (cdr list681)))))) (distinct-bound-ids?132 (lambda (ids682) (let distinct?683 ((ids684 ids682)) (or (null? ids684) (and (not (bound-id-member?133 (car ids684) (cdr ids684))) (distinct?683 (cdr ids684))))))) (valid-bound-ids?131 (lambda (ids685) (and (let all-ids?686 ((ids687 ids685)) (or (null? ids687) (and (id?106 (car ids687)) (all-ids?686 (cdr ids687))))) (distinct-bound-ids?132 ids685)))) (bound-id=?130 (lambda (i688 j689) (if (and (syntax-object?90 i688) (syntax-object?90 j689)) (and (eq? (let ((e690 (syntax-object-expression91 i688))) (if (annotation? e690) (annotation-expression e690) e690)) (let ((e691 (syntax-object-expression91 j689))) (if (annotation? e691) (annotation-expression e691) e691))) (same-marks?127 (wrap-marks109 (syntax-object-wrap92 i688)) (wrap-marks109 (syntax-object-wrap92 j689)))) (eq? (let ((e692 i688)) (if (annotation? e692) (annotation-expression e692) e692)) (let ((e693 j689)) (if (annotation? e693) (annotation-expression e693) e693)))))) (free-id=?129 (lambda (i694 j695) (and (eq? (let ((x696 i694)) (let ((e697 (if (syntax-object?90 x696) (syntax-object-expression91 x696) x696))) (if (annotation? e697) (annotation-expression e697) e697))) (let ((x698 j695)) (let ((e699 (if (syntax-object?90 x698) (syntax-object-expression91 x698) x698))) (if (annotation? e699) (annotation-expression e699) e699)))) (eq? (id-var-name128 i694 (quote (()))) (id-var-name128 j695 (quote (()))))))) (id-var-name128 (lambda (id700 w701) (letrec ((search-vector-rib704 (lambda (sym710 subst711 marks712 symnames713 ribcage714) (let ((n715 (vector-length symnames713))) (let f716 ((i717 0)) (cond ((fx=73 i717 n715) (search702 sym710 (cdr subst711) marks712)) ((and (eq? (vector-ref symnames713 i717) sym710) (same-marks?127 marks712 (vector-ref (ribcage-marks116 ribcage714) i717))) (values (vector-ref (ribcage-labels117 ribcage714) i717) marks712)) (else (f716 (fx+71 i717 1)))))))) (search-list-rib703 (lambda (sym718 subst719 marks720 symnames721 ribcage722) (let f723 ((symnames724 symnames721) (i725 0)) (cond ((null? symnames724) (search702 sym718 (cdr subst719) marks720)) ((and (eq? (car symnames724) sym718) (same-marks?127 marks720 (list-ref (ribcage-marks116 ribcage722) i725))) (values (list-ref (ribcage-labels117 ribcage722) i725) marks720)) (else (f723 (cdr symnames724) (fx+71 i725 1))))))) (search702 (lambda (sym726 subst727 marks728) (if (null? subst727) (values #f marks728) (let ((fst729 (car subst727))) (if (eq? fst729 (quote shift)) (search702 sym726 (cdr subst727) (cdr marks728)) (let ((symnames730 (ribcage-symnames115 fst729))) (if (vector? symnames730) (search-vector-rib704 sym726 subst727 marks728 symnames730 fst729) (search-list-rib703 sym726 subst727 marks728 symnames730 fst729))))))))) (cond ((symbol? id700) (or (call-with-values (lambda () (search702 id700 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x732 . ignore731) x732)) id700)) ((syntax-object?90 id700) (let ((id733 (let ((e735 (syntax-object-expression91 id700))) (if (annotation? e735) (annotation-expression e735) e735))) (w1734 (syntax-object-wrap92 id700))) (let ((marks736 (join-marks126 (wrap-marks109 w701) (wrap-marks109 w1734)))) (call-with-values (lambda () (search702 id733 (wrap-subst110 w701) marks736)) (lambda (new-id737 marks738) (or new-id737 (call-with-values (lambda () (search702 id733 (wrap-subst110 w1734) marks738)) (lambda (x740 . ignore739) x740)) id733)))))) ((annotation? id700) (let ((id741 (let ((e742 id700)) (if (annotation? e742) (annotation-expression e742) e742)))) (or (call-with-values (lambda () (search702 id741 (wrap-subst110 w701) (wrap-marks109 w701))) (lambda (x744 . ignore743) x744)) id741))) (else (syntax-violation (quote id-var-name) "invalid id" id700)))))) (same-marks?127 (lambda (x745 y746) (or (eq? x745 y746) (and (not (null? x745)) (not (null? y746)) (eq? (car x745) (car y746)) (same-marks?127 (cdr x745) (cdr y746)))))) (join-marks126 (lambda (m1747 m2748) (smart-append124 m1747 m2748))) (join-wraps125 (lambda (w1749 w2750) (let ((m1751 (wrap-marks109 w1749)) (s1752 (wrap-subst110 w1749))) (if (null? m1751) (if (null? s1752) w2750 (make-wrap108 (wrap-marks109 w2750) (smart-append124 s1752 (wrap-subst110 w2750)))) (make-wrap108 (smart-append124 m1751 (wrap-marks109 w2750)) (smart-append124 s1752 (wrap-subst110 w2750))))))) (smart-append124 (lambda (m1753 m2754) (if (null? m2754) m1753 (append m1753 m2754)))) (make-binding-wrap123 (lambda (ids755 labels756 w757) (if (null? ids755) w757 (make-wrap108 (wrap-marks109 w757) (cons (let ((labelvec758 (list->vector labels756))) (let ((n759 (vector-length labelvec758))) (let ((symnamevec760 (make-vector n759)) (marksvec761 (make-vector n759))) (begin (let f762 ((ids763 ids755) (i764 0)) (if (not (null? ids763)) (call-with-values (lambda () (id-sym-name&marks107 (car ids763) w757)) (lambda (symname765 marks766) (begin (vector-set! symnamevec760 i764 symname765) (vector-set! marksvec761 i764 marks766) (f762 (cdr ids763) (fx+71 i764 1))))))) (make-ribcage113 symnamevec760 marksvec761 labelvec758))))) (wrap-subst110 w757)))))) (extend-ribcage!122 (lambda (ribcage767 id768 label769) (begin (set-ribcage-symnames!118 ribcage767 (cons (let ((e770 (syntax-object-expression91 id768))) (if (annotation? e770) (annotation-expression e770) e770)) (ribcage-symnames115 ribcage767))) (set-ribcage-marks!119 ribcage767 (cons (wrap-marks109 (syntax-object-wrap92 id768)) (ribcage-marks116 ribcage767))) (set-ribcage-labels!120 ribcage767 (cons label769 (ribcage-labels117 ribcage767)))))) (anti-mark121 (lambda (w771) (make-wrap108 (cons #f (wrap-marks109 w771)) (cons (quote shift) (wrap-subst110 w771))))) (set-ribcage-labels!120 (lambda (x772 update773) (vector-set! x772 3 update773))) (set-ribcage-marks!119 (lambda (x774 update775) (vector-set! x774 2 update775))) (set-ribcage-symnames!118 (lambda (x776 update777) (vector-set! x776 1 update777))) (ribcage-labels117 (lambda (x778) (vector-ref x778 3))) (ribcage-marks116 (lambda (x779) (vector-ref x779 2))) (ribcage-symnames115 (lambda (x780) (vector-ref x780 1))) (ribcage?114 (lambda (x781) (and (vector? x781) (= (vector-length x781) 4) (eq? (vector-ref x781 0) (quote ribcage))))) (make-ribcage113 (lambda (symnames782 marks783 labels784) (vector (quote ribcage) symnames782 marks783 labels784))) (gen-labels112 (lambda (ls785) (if (null? ls785) (quote ()) (cons (gen-label111) (gen-labels112 (cdr ls785)))))) (gen-label111 (lambda () (string #\i))) (wrap-subst110 cdr) (wrap-marks109 car) (make-wrap108 cons) (id-sym-name&marks107 (lambda (x786 w787) (if (syntax-object?90 x786) (values (let ((e788 (syntax-object-expression91 x786))) (if (annotation? e788) (annotation-expression e788) e788)) (join-marks126 (wrap-marks109 w787) (wrap-marks109 (syntax-object-wrap92 x786)))) (values (let ((e789 x786)) (if (annotation? e789) (annotation-expression e789) e789)) (wrap-marks109 w787))))) (id?106 (lambda (x790) (cond ((symbol? x790) #t) ((syntax-object?90 x790) (symbol? (let ((e791 (syntax-object-expression91 x790))) (if (annotation? e791) (annotation-expression e791) e791)))) ((annotation? x790) (symbol? (annotation-expression x790))) (else #f)))) (nonsymbol-id?105 (lambda (x792) (and (syntax-object?90 x792) (symbol? (let ((e793 (syntax-object-expression91 x792))) (if (annotation? e793) (annotation-expression e793) e793)))))) (global-extend104 (lambda (type794 sym795 val796) (put-global-definition-hook77 sym795 type794 val796))) (lookup103 (lambda (x797 r798 mod799) (cond ((assq x797 r798) => cdr) ((symbol? x797) (or (get-global-definition-hook78 x797 mod799) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env102 (lambda (r800) (if (null? r800) (quote ()) (let ((a801 (car r800))) (if (eq? (cadr a801) (quote macro)) (cons a801 (macros-only-env102 (cdr r800))) (macros-only-env102 (cdr r800))))))) (extend-var-env101 (lambda (labels802 vars803 r804) (if (null? labels802) r804 (extend-var-env101 (cdr labels802) (cdr vars803) (cons (cons (car labels802) (cons (quote lexical) (car vars803))) r804))))) (extend-env100 (lambda (labels805 bindings806 r807) (if (null? labels805) r807 (extend-env100 (cdr labels805) (cdr bindings806) (cons (cons (car labels805) (car bindings806)) r807))))) (binding-value99 cdr) (binding-type98 car) (source-annotation97 (lambda (x808) (cond ((annotation? x808) (annotation-source x808)) ((syntax-object?90 x808) (source-annotation97 (syntax-object-expression91 x808))) (else #f)))) (set-syntax-object-module!96 (lambda (x809 update810) (vector-set! x809 3 update810))) (set-syntax-object-wrap!95 (lambda (x811 update812) (vector-set! x811 2 update812))) (set-syntax-object-expression!94 (lambda (x813 update814) (vector-set! x813 1 update814))) (syntax-object-module93 (lambda (x815) (vector-ref x815 3))) (syntax-object-wrap92 (lambda (x816) (vector-ref x816 2))) (syntax-object-expression91 (lambda (x817) (vector-ref x817 1))) (syntax-object?90 (lambda (x818) (and (vector? x818) (= (vector-length x818) 4) (eq? (vector-ref x818 0) (quote syntax-object))))) (make-syntax-object89 (lambda (expression819 wrap820 module821) (vector (quote syntax-object) expression819 wrap820 module821))) (build-letrec88 (lambda (src822 vars823 val-exps824 body-exp825) (if (null? vars823) (build-annotated79 src822 body-exp825) (build-annotated79 src822 (list (quote letrec) (map list vars823 val-exps824) body-exp825))))) (build-named-let87 (lambda (src826 vars827 val-exps828 body-exp829) (if (null? vars827) (build-annotated79 src826 body-exp829) (build-annotated79 src826 (list (quote let) (car vars827) (map list (cdr vars827) val-exps828) body-exp829))))) (build-let86 (lambda (src830 vars831 val-exps832 body-exp833) (if (null? vars831) (build-annotated79 src830 body-exp833) (build-annotated79 src830 (list (quote let) (map list vars831 val-exps832) body-exp833))))) (build-sequence85 (lambda (src834 exps835) (if (null? (cdr exps835)) (build-annotated79 src834 (car exps835)) (build-annotated79 src834 (cons (quote begin) exps835))))) (build-data84 (lambda (src836 exp837) (if (and (self-evaluating? exp837) (not (vector? exp837))) (build-annotated79 src836 exp837) (build-annotated79 src836 (list (quote quote) exp837))))) (build-global-assignment83 (lambda (source838 var839 exp840 mod841) (let ((ref842 (build-global-reference82 source838 var839 mod841))) (build-annotated79 source838 (list (quote set!) ref842 exp840))))) (build-global-reference82 (lambda (source843 var844 mod845) (build-annotated79 source843 (if (not mod845) var844 (let ((make-module-ref846 (let ((t849 (fluid-ref *mode*70))) (if (memv t849 (quote (c))) (@ (ice-9 expand-support) make-module-ref) (lambda (s mod850 var851 public?852) (list (if public?852 (quote @) (quote @@)) mod850 var851))))) (kind847 (car mod845)) (mod848 (cdr mod845))) (let ((t853 kind847)) (if (memv t853 (quote (public))) (make-module-ref846 #f mod848 var844 #t) (if (memv t853 (quote (private))) (if (not (equal? mod848 (module-name (current-module)))) (make-module-ref846 #f mod848 var844 #f) var844) (if (memv t853 (quote (bare))) var844 (if (memv t853 (quote (hygiene))) (if (and (not (equal? mod848 (module-name (current-module)))) (module-variable (resolve-module mod848) var844)) (make-module-ref846 #f mod848 var844 #f) var844) (syntax-violation #f "bad module kind" var844 mod848))))))))))) (build-lexical-assignment81 (lambda (source854 name855 var856 exp857) (build-annotated79 source854 (list (quote set!) (build-lexical-reference80 (quote set) #f name855 var856) exp857)))) (build-lexical-reference80 (lambda (type858 source859 name860 var861) (build-annotated79 source859 (let ((t862 (fluid-ref *mode*70))) (if (memv t862 (quote (c))) ((@ (ice-9 expand-support) make-lexical) #f name860 var861) var861))))) (build-annotated79 (lambda (src863 exp864) (if (and src863 (not (annotation? exp864))) (make-annotation exp864 src863 #t) exp864))) (get-global-definition-hook78 (lambda (symbol865 module866) (begin (if (and (not module866) (current-module)) (warn "module system is booted, we should have a module" symbol865)) (let ((v867 (module-variable (if module866 (resolve-module (cdr module866)) (current-module)) symbol865))) (and v867 (variable-bound? v867) (let ((val868 (variable-ref v867))) (and (macro? val868) (syncase-macro-type val868) (cons (syncase-macro-type val868) (syncase-macro-binding val868))))))))) (put-global-definition-hook77 (lambda (symbol869 type870 val871) (let ((existing872 (let ((v873 (module-variable (current-module) symbol869))) (and v873 (variable-bound? v873) (let ((val874 (variable-ref v873))) (and (macro? val874) (not (syncase-macro-type val874)) val874)))))) (module-define! (current-module) symbol869 (if existing872 (make-extended-syncase-macro existing872 type870 val871) (make-syncase-macro type870 val871)))))) (local-eval-hook76 (lambda (x875 mod876) (primitive-eval (list noexpand69 (let ((t877 (fluid-ref *mode*70))) (if (memv t877 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x875) x875)))))) (top-level-eval-hook75 (lambda (x878 mod879) (primitive-eval (list noexpand69 (let ((t880 (fluid-ref *mode*70))) (if (memv t880 (quote (c))) ((@ (ice-9 expand-support) strip-expansion-structures) x878) x878)))))) (fx<74 <) (fx=73 =) (fx-72 -) (fx+71 +) (*mode*70 (make-fluid)) (noexpand69 "noexpand")) (begin (global-extend104 (quote local-syntax) (quote letrec-syntax) #t) (global-extend104 (quote local-syntax) (quote let-syntax) #f) (global-extend104 (quote core) (quote fluid-let-syntax) (lambda (e881 r882 w883 s884 mod885) ((lambda (tmp886) ((lambda (tmp887) (if (if tmp887 (apply (lambda (_888 var889 val890 e1891 e2892) (valid-bound-ids?131 var889)) tmp887) #f) (apply (lambda (_894 var895 val896 e1897 e2898) (let ((names899 (map (lambda (x900) (id-var-name128 x900 w883)) var895))) (begin (for-each (lambda (id902 n903) (let ((t904 (binding-type98 (lookup103 n903 r882 mod885)))) (if (memv t904 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e881 (source-wrap135 id902 w883 s884 mod885))))) var895 names899) (chi-body146 (cons e1897 e2898) (source-wrap135 e881 w883 s884 mod885) (extend-env100 names899 (let ((trans-r907 (macros-only-env102 r882))) (map (lambda (x908) (cons (quote macro) (eval-local-transformer149 (chi142 x908 trans-r907 w883 mod885) mod885))) val896)) r882) w883 mod885)))) tmp887) ((lambda (_910) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap135 e881 w883 s884 mod885))) tmp886))) ($sc-dispatch tmp886 (quote (any #(each (any any)) any . each-any))))) e881))) (global-extend104 (quote core) (quote quote) (lambda (e911 r912 w913 s914 mod915) ((lambda (tmp916) ((lambda (tmp917) (if tmp917 (apply (lambda (_918 e919) (build-data84 s914 (strip153 e919 w913))) tmp917) ((lambda (_920) (syntax-violation (quote quote) "bad syntax" (source-wrap135 e911 w913 s914 mod915))) tmp916))) ($sc-dispatch tmp916 (quote (any any))))) e911))) (global-extend104 (quote core) (quote syntax) (letrec ((regen928 (lambda (x929) (let ((t930 (car x929))) (if (memv t930 (quote (ref))) (build-lexical-reference80 (quote value) #f (cadr x929) (cadr x929)) (if (memv t930 (quote (primitive))) (build-annotated79 #f (cadr x929)) (if (memv t930 (quote (quote))) (build-data84 #f (cadr x929)) (if (memv t930 (quote (lambda))) (build-annotated79 #f (list (quote lambda) (cadr x929) (regen928 (caddr x929)))) (if (memv t930 (quote (map))) (let ((ls931 (map regen928 (cdr x929)))) (build-annotated79 #f (cons (if (fx=73 (length ls931) 2) (build-annotated79 #f (quote map)) (build-annotated79 #f (quote map))) ls931))) (build-annotated79 #f (cons (build-annotated79 #f (car x929)) (map regen928 (cdr x929)))))))))))) (gen-vector927 (lambda (x932) (cond ((eq? (car x932) (quote list)) (cons (quote vector) (cdr x932))) ((eq? (car x932) (quote quote)) (list (quote quote) (list->vector (cadr x932)))) (else (list (quote list->vector) x932))))) (gen-append926 (lambda (x933 y934) (if (equal? y934 (quote (quote ()))) x933 (list (quote append) x933 y934)))) (gen-cons925 (lambda (x935 y936) (let ((t937 (car y936))) (if (memv t937 (quote (quote))) (if (eq? (car x935) (quote quote)) (list (quote quote) (cons (cadr x935) (cadr y936))) (if (eq? (cadr y936) (quote ())) (list (quote list) x935) (list (quote cons) x935 y936))) (if (memv t937 (quote (list))) (cons (quote list) (cons x935 (cdr y936))) (list (quote cons) x935 y936)))))) (gen-map924 (lambda (e938 map-env939) (let ((formals940 (map cdr map-env939)) (actuals941 (map (lambda (x942) (list (quote ref) (car x942))) map-env939))) (cond ((eq? (car e938) (quote ref)) (car actuals941)) ((and-map (lambda (x943) (and (eq? (car x943) (quote ref)) (memq (cadr x943) formals940))) (cdr e938)) (cons (quote map) (cons (list (quote primitive) (car e938)) (map (let ((r944 (map cons formals940 actuals941))) (lambda (x945) (cdr (assq (cadr x945) r944)))) (cdr e938))))) (else (cons (quote map) (cons (list (quote lambda) formals940 e938) actuals941))))))) (gen-mappend923 (lambda (e946 map-env947) (list (quote apply) (quote (primitive append)) (gen-map924 e946 map-env947)))) (gen-ref922 (lambda (src948 var949 level950 maps951) (if (fx=73 level950 0) (values var949 maps951) (if (null? maps951) (syntax-violation (quote syntax) "missing ellipsis" src948) (call-with-values (lambda () (gen-ref922 src948 var949 (fx-72 level950 1) (cdr maps951))) (lambda (outer-var952 outer-maps953) (let ((b954 (assq outer-var952 (car maps951)))) (if b954 (values (cdr b954) maps951) (let ((inner-var955 (gen-var154 (quote tmp)))) (values inner-var955 (cons (cons (cons outer-var952 inner-var955) (car maps951)) outer-maps953))))))))))) (gen-syntax921 (lambda (src956 e957 r958 maps959 ellipsis?960 mod961) (if (id?106 e957) (let ((label962 (id-var-name128 e957 (quote (()))))) (let ((b963 (lookup103 label962 r958 mod961))) (if (eq? (binding-type98 b963) (quote syntax)) (call-with-values (lambda () (let ((var.lev964 (binding-value99 b963))) (gen-ref922 src956 (car var.lev964) (cdr var.lev964) maps959))) (lambda (var965 maps966) (values (list (quote ref) var965) maps966))) (if (ellipsis?960 e957) (syntax-violation (quote syntax) "misplaced ellipsis" src956) (values (list (quote quote) e957) maps959))))) ((lambda (tmp967) ((lambda (tmp968) (if (if tmp968 (apply (lambda (dots969 e970) (ellipsis?960 dots969)) tmp968) #f) (apply (lambda (dots971 e972) (gen-syntax921 src956 e972 r958 maps959 (lambda (x973) #f) mod961)) tmp968) ((lambda (tmp974) (if (if tmp974 (apply (lambda (x975 dots976 y977) (ellipsis?960 dots976)) tmp974) #f) (apply (lambda (x978 dots979 y980) (let f981 ((y982 y980) (k983 (lambda (maps984) (call-with-values (lambda () (gen-syntax921 src956 x978 r958 (cons (quote ()) maps984) ellipsis?960 mod961)) (lambda (x985 maps986) (if (null? (car maps986)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-map924 x985 (car maps986)) (cdr maps986)))))))) ((lambda (tmp987) ((lambda (tmp988) (if (if tmp988 (apply (lambda (dots989 y990) (ellipsis?960 dots989)) tmp988) #f) (apply (lambda (dots991 y992) (f981 y992 (lambda (maps993) (call-with-values (lambda () (k983 (cons (quote ()) maps993))) (lambda (x994 maps995) (if (null? (car maps995)) (syntax-violation (quote syntax) "extra ellipsis" src956) (values (gen-mappend923 x994 (car maps995)) (cdr maps995)))))))) tmp988) ((lambda (_996) (call-with-values (lambda () (gen-syntax921 src956 y982 r958 maps959 ellipsis?960 mod961)) (lambda (y997 maps998) (call-with-values (lambda () (k983 maps998)) (lambda (x999 maps1000) (values (gen-append926 x999 y997) maps1000)))))) tmp987))) ($sc-dispatch tmp987 (quote (any . any))))) y982))) tmp974) ((lambda (tmp1001) (if tmp1001 (apply (lambda (x1002 y1003) (call-with-values (lambda () (gen-syntax921 src956 x1002 r958 maps959 ellipsis?960 mod961)) (lambda (x1004 maps1005) (call-with-values (lambda () (gen-syntax921 src956 y1003 r958 maps1005 ellipsis?960 mod961)) (lambda (y1006 maps1007) (values (gen-cons925 x1004 y1006) maps1007)))))) tmp1001) ((lambda (tmp1008) (if tmp1008 (apply (lambda (e11009 e21010) (call-with-values (lambda () (gen-syntax921 src956 (cons e11009 e21010) r958 maps959 ellipsis?960 mod961)) (lambda (e1012 maps1013) (values (gen-vector927 e1012) maps1013)))) tmp1008) ((lambda (_1014) (values (list (quote quote) e957) maps959)) tmp967))) ($sc-dispatch tmp967 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp967 (quote (any . any)))))) ($sc-dispatch tmp967 (quote (any any . any)))))) ($sc-dispatch tmp967 (quote (any any))))) e957))))) (lambda (e1015 r1016 w1017 s1018 mod1019) (let ((e1020 (source-wrap135 e1015 w1017 s1018 mod1019))) ((lambda (tmp1021) ((lambda (tmp1022) (if tmp1022 (apply (lambda (_1023 x1024) (call-with-values (lambda () (gen-syntax921 e1020 x1024 r1016 (quote ()) ellipsis?151 mod1019)) (lambda (e1025 maps1026) (regen928 e1025)))) tmp1022) ((lambda (_1027) (syntax-violation (quote syntax) "bad `syntax' form" e1020)) tmp1021))) ($sc-dispatch tmp1021 (quote (any any))))) e1020))))) (global-extend104 (quote core) (quote lambda) (lambda (e1028 r1029 w1030 s1031 mod1032) ((lambda (tmp1033) ((lambda (tmp1034) (if tmp1034 (apply (lambda (_1035 c1036) (chi-lambda-clause147 (source-wrap135 e1028 w1030 s1031 mod1032) #f c1036 r1029 w1030 mod1032 (lambda (vars1037 docstring1038 body1039) (build-annotated79 s1031 (cons (quote lambda) (cons vars1037 (append (if docstring1038 (list docstring1038) (quote ())) (list body1039)))))))) tmp1034) (syntax-violation #f "source expression failed to match any pattern" tmp1033))) ($sc-dispatch tmp1033 (quote (any . any))))) e1028))) (global-extend104 (quote core) (quote let) (letrec ((chi-let1040 (lambda (e1041 r1042 w1043 s1044 mod1045 constructor1046 ids1047 vals1048 exps1049) (if (not (valid-bound-ids?131 ids1047)) (syntax-violation (quote let) "duplicate bound variable" e1041) (let ((labels1050 (gen-labels112 ids1047)) (new-vars1051 (map gen-var154 ids1047))) (let ((nw1052 (make-binding-wrap123 ids1047 labels1050 w1043)) (nr1053 (extend-var-env101 labels1050 new-vars1051 r1042))) (constructor1046 s1044 new-vars1051 (map (lambda (x1054) (chi142 x1054 r1042 w1043 mod1045)) vals1048) (chi-body146 exps1049 (source-wrap135 e1041 nw1052 s1044 mod1045) nr1053 nw1052 mod1045)))))))) (lambda (e1055 r1056 w1057 s1058 mod1059) ((lambda (tmp1060) ((lambda (tmp1061) (if tmp1061 (apply (lambda (_1062 id1063 val1064 e11065 e21066) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-let86 id1063 val1064 (cons e11065 e21066))) tmp1061) ((lambda (tmp1070) (if (if tmp1070 (apply (lambda (_1071 f1072 id1073 val1074 e11075 e21076) (id?106 f1072)) tmp1070) #f) (apply (lambda (_1077 f1078 id1079 val1080 e11081 e21082) (chi-let1040 e1055 r1056 w1057 s1058 mod1059 build-named-let87 (cons f1078 id1079) val1080 (cons e11081 e21082))) tmp1070) ((lambda (_1086) (syntax-violation (quote let) "bad let" (source-wrap135 e1055 w1057 s1058 mod1059))) tmp1060))) ($sc-dispatch tmp1060 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1060 (quote (any #(each (any any)) any . each-any))))) e1055)))) (global-extend104 (quote core) (quote letrec) (lambda (e1087 r1088 w1089 s1090 mod1091) ((lambda (tmp1092) ((lambda (tmp1093) (if tmp1093 (apply (lambda (_1094 id1095 val1096 e11097 e21098) (let ((ids1099 id1095)) (if (not (valid-bound-ids?131 ids1099)) (syntax-violation (quote letrec) "duplicate bound variable" e1087) (let ((labels1101 (gen-labels112 ids1099)) (new-vars1102 (map gen-var154 ids1099))) (let ((w1103 (make-binding-wrap123 ids1099 labels1101 w1089)) (r1104 (extend-var-env101 labels1101 new-vars1102 r1088))) (build-letrec88 s1090 new-vars1102 (map (lambda (x1105) (chi142 x1105 r1104 w1103 mod1091)) val1096) (chi-body146 (cons e11097 e21098) (source-wrap135 e1087 w1103 s1090 mod1091) r1104 w1103 mod1091))))))) tmp1093) ((lambda (_1108) (syntax-violation (quote letrec) "bad letrec" (source-wrap135 e1087 w1089 s1090 mod1091))) tmp1092))) ($sc-dispatch tmp1092 (quote (any #(each (any any)) any . each-any))))) e1087))) (global-extend104 (quote core) (quote set!) (lambda (e1109 r1110 w1111 s1112 mod1113) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (_1116 id1117 val1118) (id?106 id1117)) tmp1115) #f) (apply (lambda (_1119 id1120 val1121) (let ((val1122 (chi142 val1121 r1110 w1111 mod1113)) (n1123 (id-var-name128 id1120 w1111))) (let ((b1124 (lookup103 n1123 r1110 mod1113))) (let ((t1125 (binding-type98 b1124))) (if (memv t1125 (quote (lexical))) (build-lexical-assignment81 s1112 (syntax->datum id1120) (binding-value99 b1124) val1122) (if (memv t1125 (quote (global))) (build-global-assignment83 s1112 n1123 val1122 mod1113) (if (memv t1125 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap134 id1120 w1111 mod1113)) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))))))))) tmp1115) ((lambda (tmp1126) (if tmp1126 (apply (lambda (_1127 head1128 tail1129 val1130) (call-with-values (lambda () (syntax-type140 head1128 r1110 (quote (())) #f #f mod1113)) (lambda (type1131 value1132 ee1133 ww1134 ss1135 modmod1136) (let ((t1137 type1131)) (if (memv t1137 (quote (module-ref))) (let ((val1138 (chi142 val1130 r1110 w1111 mod1113))) (call-with-values (lambda () (value1132 (cons head1128 tail1129))) (lambda (id1140 mod1141) (build-global-assignment83 s1112 id1140 val1138 mod1141)))) (build-annotated79 s1112 (cons (chi142 (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 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))) head1128) r1110 w1111 mod1113) (map (lambda (e1142) (chi142 e1142 r1110 w1111 mod1113)) (append tail1129 (list val1130)))))))))) tmp1126) ((lambda (_1144) (syntax-violation (quote set!) "bad set!" (source-wrap135 e1109 w1111 s1112 mod1113))) tmp1114))) ($sc-dispatch tmp1114 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1114 (quote (any any any))))) e1109))) (global-extend104 (quote module-ref) (quote @) (lambda (e1145) ((lambda (tmp1146) ((lambda (tmp1147) (if (if tmp1147 (apply (lambda (_1148 mod1149 id1150) (and (and-map id?106 mod1149) (id?106 id1150))) tmp1147) #f) (apply (lambda (_1152 mod1153 id1154) (values (syntax->datum id1154) (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 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))) mod1153)))) tmp1147) (syntax-violation #f "source expression failed to match any pattern" tmp1146))) ($sc-dispatch tmp1146 (quote (any each-any any))))) e1145))) (global-extend104 (quote module-ref) (quote @@) (lambda (e1156) ((lambda (tmp1157) ((lambda (tmp1158) (if (if tmp1158 (apply (lambda (_1159 mod1160 id1161) (and (and-map id?106 mod1160) (id?106 id1161))) tmp1158) #f) (apply (lambda (_1163 mod1164 id1165) (values (syntax->datum id1165) (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 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))) mod1164)))) tmp1158) (syntax-violation #f "source expression failed to match any pattern" tmp1157))) ($sc-dispatch tmp1157 (quote (any each-any any))))) e1156))) (global-extend104 (quote begin) (quote begin) (quote ())) (global-extend104 (quote define) (quote define) (quote ())) (global-extend104 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend104 (quote eval-when) (quote eval-when) (quote ())) (global-extend104 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1170 (lambda (x1171 keys1172 clauses1173 r1174 mod1175) (if (null? clauses1173) (build-annotated79 #f (list (build-annotated79 #f (quote syntax-violation)) #f "source expression failed to match any pattern" x1171)) ((lambda (tmp1176) ((lambda (tmp1177) (if tmp1177 (apply (lambda (pat1178 exp1179) (if (and (id?106 pat1178) (and-map (lambda (x1180) (not (free-id=?129 pat1178 x1180))) (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 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))) keys1172))) (let ((labels1181 (list (gen-label111))) (var1182 (gen-var154 pat1178))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list var1182) (chi142 exp1179 (extend-env100 labels1181 (list (cons (quote syntax) (cons var1182 0))) r1174) (make-binding-wrap123 (list pat1178) labels1181 (quote (()))) mod1175))) x1171))) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1178 #t exp1179 mod1175))) tmp1177) ((lambda (tmp1183) (if tmp1183 (apply (lambda (pat1184 fender1185 exp1186) (gen-clause1169 x1171 keys1172 (cdr clauses1173) r1174 pat1184 fender1185 exp1186 mod1175)) tmp1183) ((lambda (_1187) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1173))) tmp1176))) ($sc-dispatch tmp1176 (quote (any any any)))))) ($sc-dispatch tmp1176 (quote (any any))))) (car clauses1173))))) (gen-clause1169 (lambda (x1188 keys1189 clauses1190 r1191 pat1192 fender1193 exp1194 mod1195) (call-with-values (lambda () (convert-pattern1167 pat1192 keys1189)) (lambda (p1196 pvars1197) (cond ((not (distinct-bound-ids?132 (map car pvars1197))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1192)) ((not (and-map (lambda (x1198) (not (ellipsis?151 (car x1198)))) pvars1197)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1192)) (else (let ((y1199 (gen-var154 (quote tmp)))) (build-annotated79 #f (list (build-annotated79 #f (list (quote lambda) (list y1199) (let ((y1200 (build-lexical-reference80 (quote value) #f (quote tmp) y1199))) (build-annotated79 #f (list (quote if) ((lambda (tmp1201) ((lambda (tmp1202) (if tmp1202 (apply (lambda () y1200) tmp1202) ((lambda (_1203) (build-annotated79 #f (list (quote if) y1200 (build-dispatch-call1168 pvars1197 fender1193 y1200 r1191 mod1195) (build-data84 #f #f)))) tmp1201))) ($sc-dispatch tmp1201 (quote #(atom #t))))) fender1193) (build-dispatch-call1168 pvars1197 exp1194 y1200 r1191 mod1195) (gen-syntax-case1170 x1188 keys1189 clauses1190 r1191 mod1195)))))) (if (eq? p1196 (quote any)) (build-annotated79 #f (list (build-annotated79 #f (quote list)) x1188)) (build-annotated79 #f (list (build-annotated79 #f (quote $sc-dispatch)) x1188 (build-data84 #f p1196))))))))))))) (build-dispatch-call1168 (lambda (pvars1204 exp1205 y1206 r1207 mod1208) (let ((ids1209 (map car pvars1204)) (levels1210 (map cdr pvars1204))) (let ((labels1211 (gen-labels112 ids1209)) (new-vars1212 (map gen-var154 ids1209))) (build-annotated79 #f (list (build-annotated79 #f (quote apply)) (build-annotated79 #f (list (quote lambda) new-vars1212 (chi142 exp1205 (extend-env100 labels1211 (map (lambda (var1213 level1214) (cons (quote syntax) (cons var1213 level1214))) new-vars1212 (map cdr pvars1204)) r1207) (make-binding-wrap123 ids1209 labels1211 (quote (()))) mod1208))) y1206)))))) (convert-pattern1167 (lambda (pattern1215 keys1216) (let cvt1217 ((p1218 pattern1215) (n1219 0) (ids1220 (quote ()))) (if (id?106 p1218) (if (bound-id-member?133 p1218 keys1216) (values (vector (quote free-id) p1218) ids1220) (values (quote any) (cons (cons p1218 n1219) ids1220))) ((lambda (tmp1221) ((lambda (tmp1222) (if (if tmp1222 (apply (lambda (x1223 dots1224) (ellipsis?151 dots1224)) tmp1222) #f) (apply (lambda (x1225 dots1226) (call-with-values (lambda () (cvt1217 x1225 (fx+71 n1219 1) ids1220)) (lambda (p1227 ids1228) (values (if (eq? p1227 (quote any)) (quote each-any) (vector (quote each) p1227)) ids1228)))) tmp1222) ((lambda (tmp1229) (if tmp1229 (apply (lambda (x1230 y1231) (call-with-values (lambda () (cvt1217 y1231 n1219 ids1220)) (lambda (y1232 ids1233) (call-with-values (lambda () (cvt1217 x1230 n1219 ids1233)) (lambda (x1234 ids1235) (values (cons x1234 y1232) ids1235)))))) tmp1229) ((lambda (tmp1236) (if tmp1236 (apply (lambda () (values (quote ()) ids1220)) tmp1236) ((lambda (tmp1237) (if tmp1237 (apply (lambda (x1238) (call-with-values (lambda () (cvt1217 x1238 n1219 ids1220)) (lambda (p1240 ids1241) (values (vector (quote vector) p1240) ids1241)))) tmp1237) ((lambda (x1242) (values (vector (quote atom) (strip153 p1218 (quote (())))) ids1220)) tmp1221))) ($sc-dispatch tmp1221 (quote #(vector each-any)))))) ($sc-dispatch tmp1221 (quote ()))))) ($sc-dispatch tmp1221 (quote (any . any)))))) ($sc-dispatch tmp1221 (quote (any any))))) p1218)))))) (lambda (e1243 r1244 w1245 s1246 mod1247) (let ((e1248 (source-wrap135 e1243 w1245 s1246 mod1247))) ((lambda (tmp1249) ((lambda (tmp1250) (if tmp1250 (apply (lambda (_1251 val1252 key1253 m1254) (if (and-map (lambda (x1255) (and (id?106 x1255) (not (ellipsis?151 x1255)))) key1253) (let ((x1257 (gen-var154 (quote tmp)))) (build-annotated79 s1246 (list (build-annotated79 #f (list (quote lambda) (list x1257) (gen-syntax-case1170 (build-lexical-reference80 (quote value) #f (quote tmp) x1257) key1253 m1254 r1244 mod1247))) (chi142 val1252 r1244 (quote (())) mod1247)))) (syntax-violation (quote syntax-case) "invalid literals list" e1248))) tmp1250) (syntax-violation #f "source expression failed to match any pattern" tmp1249))) ($sc-dispatch tmp1249 (quote (any any each-any . each-any))))) e1248))))) (set! sc-expand (lambda (x1261 . rest1260) (if (and (pair? x1261) (equal? (car x1261) noexpand69)) (cadr x1261) (let ((m1262 (if (null? rest1260) (quote e) (car rest1260))) (esew1263 (if (or (null? rest1260) (null? (cdr rest1260))) (quote (eval)) (cadr rest1260)))) (with-fluid* *mode*70 m1262 (lambda () (chi-top141 x1261 (quote ()) (quote ((top))) m1262 esew1263 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1264) (nonsymbol-id?105 x1264))) (set! datum->syntax (lambda (id1265 datum1266) (make-syntax-object89 datum1266 (syntax-object-wrap92 id1265) #f))) (set! syntax->datum (lambda (x1267) (strip153 x1267 (quote (()))))) (set! generate-temporaries (lambda (ls1268) (begin (let ((x1269 ls1268)) (if (not (list? x1269)) (syntax-violation (quote generate-temporaries) "invalid argument" x1269))) (map (lambda (x1270) (wrap134 (gensym) (quote ((top))) #f)) ls1268)))) (set! free-identifier=? (lambda (x1271 y1272) (begin (let ((x1273 x1271)) (if (not (nonsymbol-id?105 x1273)) (syntax-violation (quote free-identifier=?) "invalid argument" x1273))) (let ((x1274 y1272)) (if (not (nonsymbol-id?105 x1274)) (syntax-violation (quote free-identifier=?) "invalid argument" x1274))) (free-id=?129 x1271 y1272)))) (set! bound-identifier=? (lambda (x1275 y1276) (begin (let ((x1277 x1275)) (if (not (nonsymbol-id?105 x1277)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1277))) (let ((x1278 y1276)) (if (not (nonsymbol-id?105 x1278)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1278))) (bound-id=?130 x1275 y1276)))) (set! syntax-violation (lambda (who1282 message1281 form1280 . subform1279) (begin (let ((x1283 who1282)) (if (not ((lambda (x1284) (or (not x1284) (string? x1284) (symbol? x1284))) x1283)) (syntax-violation (quote syntax-violation) "invalid argument" x1283))) (let ((x1285 message1281)) (if (not (string? x1285)) (syntax-violation (quote syntax-violation) "invalid argument" x1285))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1282 "~a: " "") "~a " (if (null? subform1279) "in ~a" "in subform `~s' of `~s'")) (let ((tail1286 (cons message1281 (map (lambda (x1287) (strip153 x1287 (quote (())))) (append subform1279 (list form1280)))))) (if who1282 (cons who1282 tail1286) tail1286)) #f)))) (letrec ((match1292 (lambda (e1293 p1294 w1295 r1296 mod1297) (cond ((not r1296) #f) ((eq? p1294 (quote any)) (cons (wrap134 e1293 w1295 mod1297) r1296)) ((syntax-object?90 e1293) (match*1291 (let ((e1298 (syntax-object-expression91 e1293))) (if (annotation? e1298) (annotation-expression e1298) e1298)) p1294 (join-wraps125 w1295 (syntax-object-wrap92 e1293)) r1296 (syntax-object-module93 e1293))) (else (match*1291 (let ((e1299 e1293)) (if (annotation? e1299) (annotation-expression e1299) e1299)) p1294 w1295 r1296 mod1297))))) (match*1291 (lambda (e1300 p1301 w1302 r1303 mod1304) (cond ((null? p1301) (and (null? e1300) r1303)) ((pair? p1301) (and (pair? e1300) (match1292 (car e1300) (car p1301) w1302 (match1292 (cdr e1300) (cdr p1301) w1302 r1303 mod1304) mod1304))) ((eq? p1301 (quote each-any)) (let ((l1305 (match-each-any1289 e1300 w1302 mod1304))) (and l1305 (cons l1305 r1303)))) (else (let ((t1306 (vector-ref p1301 0))) (if (memv t1306 (quote (each))) (if (null? e1300) (match-empty1290 (vector-ref p1301 1) r1303) (let ((l1307 (match-each1288 e1300 (vector-ref p1301 1) w1302 mod1304))) (and l1307 (let collect1308 ((l1309 l1307)) (if (null? (car l1309)) r1303 (cons (map car l1309) (collect1308 (map cdr l1309)))))))) (if (memv t1306 (quote (free-id))) (and (id?106 e1300) (free-id=?129 (wrap134 e1300 w1302 mod1304) (vector-ref p1301 1)) r1303) (if (memv t1306 (quote (atom))) (and (equal? (vector-ref p1301 1) (strip153 e1300 w1302)) r1303) (if (memv t1306 (quote (vector))) (and (vector? e1300) (match1292 (vector->list e1300) (vector-ref p1301 1) w1302 r1303 mod1304))))))))))) (match-empty1290 (lambda (p1310 r1311) (cond ((null? p1310) r1311) ((eq? p1310 (quote any)) (cons (quote ()) r1311)) ((pair? p1310) (match-empty1290 (car p1310) (match-empty1290 (cdr p1310) r1311))) ((eq? p1310 (quote each-any)) (cons (quote ()) r1311)) (else (let ((t1312 (vector-ref p1310 0))) (if (memv t1312 (quote (each))) (match-empty1290 (vector-ref p1310 1) r1311) (if (memv t1312 (quote (free-id atom))) r1311 (if (memv t1312 (quote (vector))) (match-empty1290 (vector-ref p1310 1) r1311))))))))) (match-each-any1289 (lambda (e1313 w1314 mod1315) (cond ((annotation? e1313) (match-each-any1289 (annotation-expression e1313) w1314 mod1315)) ((pair? e1313) (let ((l1316 (match-each-any1289 (cdr e1313) w1314 mod1315))) (and l1316 (cons (wrap134 (car e1313) w1314 mod1315) l1316)))) ((null? e1313) (quote ())) ((syntax-object?90 e1313) (match-each-any1289 (syntax-object-expression91 e1313) (join-wraps125 w1314 (syntax-object-wrap92 e1313)) mod1315)) (else #f)))) (match-each1288 (lambda (e1317 p1318 w1319 mod1320) (cond ((annotation? e1317) (match-each1288 (annotation-expression e1317) p1318 w1319 mod1320)) ((pair? e1317) (let ((first1321 (match1292 (car e1317) p1318 w1319 (quote ()) mod1320))) (and first1321 (let ((rest1322 (match-each1288 (cdr e1317) p1318 w1319 mod1320))) (and rest1322 (cons first1321 rest1322)))))) ((null? e1317) (quote ())) ((syntax-object?90 e1317) (match-each1288 (syntax-object-expression91 e1317) p1318 (join-wraps125 w1319 (syntax-object-wrap92 e1317)) (syntax-object-module93 e1317))) (else #f))))) (set! $sc-dispatch (lambda (e1323 p1324) (cond ((eq? p1324 (quote any)) (list e1323)) ((syntax-object?90 e1323) (match*1291 (let ((e1325 (syntax-object-expression91 e1323))) (if (annotation? e1325) (annotation-expression e1325) e1325)) p1324 (syntax-object-wrap92 e1323) (quote ()) (syntax-object-module93 e1323))) (else (match*1291 (let ((e1326 e1323)) (if (annotation? e1326) (annotation-expression e1326) e1326)) p1324 (quote (())) (quote ()) #f)))))))))
-(define with-syntax (make-syncase-macro (quote macro) (lambda (x1327) ((lambda (tmp1328) ((lambda (tmp1329) (if tmp1329 (apply (lambda (_1330 e11331 e21332) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11331 e21332))) tmp1329) ((lambda (tmp1334) (if tmp1334 (apply (lambda (_1335 out1336 in1337 e11338 e21339) (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))) in1337 (quote ()) (list out1336 (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 e11338 e21339))))) tmp1334) ((lambda (tmp1341) (if tmp1341 (apply (lambda (_1342 out1343 in1344 e11345 e21346) (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))) in1344) (quote ()) (list out1343 (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 e11345 e21346))))) tmp1341) (syntax-violation #f "source expression failed to match any pattern" tmp1328))) ($sc-dispatch tmp1328 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1328 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1328 (quote (any () any . each-any))))) x1327))))
-(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1350) ((lambda (tmp1351) ((lambda (tmp1352) (if tmp1352 (apply (lambda (_1353 k1354 keyword1355 pattern1356 template1357) (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 k1354 (map (lambda (tmp1360 tmp1359) (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))) tmp1359) (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))) tmp1360))) template1357 pattern1356)))))) tmp1352) (syntax-violation #f "source expression failed to match any pattern" tmp1351))) ($sc-dispatch tmp1351 (quote (any each-any . #(each ((any . any) any))))))) x1350))))
-(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1361) ((lambda (tmp1362) ((lambda (tmp1363) (if (if tmp1363 (apply (lambda (let*1364 x1365 v1366 e11367 e21368) (and-map identifier? x1365)) tmp1363) #f) (apply (lambda (let*1370 x1371 v1372 e11373 e21374) (let f1375 ((bindings1376 (map list x1371 v1372))) (if (null? bindings1376) (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 e11373 e21374))) ((lambda (tmp1380) ((lambda (tmp1381) (if tmp1381 (apply (lambda (body1382 binding1383) (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 binding1383) body1382)) tmp1381) (syntax-violation #f "source expression failed to match any pattern" tmp1380))) ($sc-dispatch tmp1380 (quote (any any))))) (list (f1375 (cdr bindings1376)) (car bindings1376)))))) tmp1363) (syntax-violation #f "source expression failed to match any pattern" tmp1362))) ($sc-dispatch tmp1362 (quote (any #(each (any any)) any . each-any))))) x1361))))
-(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1384) ((lambda (tmp1385) ((lambda (tmp1386) (if tmp1386 (apply (lambda (_1387 var1388 init1389 step1390 e01391 e11392 c1393) ((lambda (tmp1394) ((lambda (tmp1395) (if tmp1395 (apply (lambda (step1396) ((lambda (tmp1397) ((lambda (tmp1398) (if tmp1398 (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 var1388 init1389) (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))) e01391) (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 c1393 (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))) step1396))))))) tmp1398) ((lambda (tmp1403) (if tmp1403 (apply (lambda (e11404 e21405) (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 var1388 init1389) (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))) e01391 (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 e11404 e21405)) (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 c1393 (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))) step1396))))))) tmp1403) (syntax-violation #f "source expression failed to match any pattern" tmp1397))) ($sc-dispatch tmp1397 (quote (any . each-any)))))) ($sc-dispatch tmp1397 (quote ())))) e11392)) tmp1395) (syntax-violation #f "source expression failed to match any pattern" tmp1394))) ($sc-dispatch tmp1394 (quote each-any)))) (map (lambda (v1412 s1413) ((lambda (tmp1414) ((lambda (tmp1415) (if tmp1415 (apply (lambda () v1412) tmp1415) ((lambda (tmp1416) (if tmp1416 (apply (lambda (e1417) e1417) tmp1416) ((lambda (_1418) (syntax-violation (quote do) "bad step expression" orig-x1384 s1413)) tmp1414))) ($sc-dispatch tmp1414 (quote (any)))))) ($sc-dispatch tmp1414 (quote ())))) s1413)) var1388 step1390))) tmp1386) (syntax-violation #f "source expression failed to match any pattern" tmp1385))) ($sc-dispatch tmp1385 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1384))))
-(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1421 (lambda (x1425 y1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (x1429 y1430) ((lambda (tmp1431) ((lambda (tmp1432) (if tmp1432 (apply (lambda (dy1433) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (dx1436) (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 dx1436 dy1433))) tmp1435) ((lambda (_1437) (if (null? dy1433) (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))) x1429) (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))) x1429 y1430))) tmp1434))) ($sc-dispatch tmp1434 (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))))) x1429)) tmp1432) ((lambda (tmp1438) (if tmp1438 (apply (lambda (stuff1439) (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 x1429 stuff1439))) tmp1438) ((lambda (else1440) (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))) x1429 y1430)) tmp1431))) ($sc-dispatch tmp1431 (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 tmp1431 (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))))) y1430)) tmp1428) (syntax-violation #f "source expression failed to match any pattern" tmp1427))) ($sc-dispatch tmp1427 (quote (any any))))) (list x1425 y1426)))) (quasiappend1422 (lambda (x1441 y1442) ((lambda (tmp1443) ((lambda (tmp1444) (if tmp1444 (apply (lambda (x1445 y1446) ((lambda (tmp1447) ((lambda (tmp1448) (if tmp1448 (apply (lambda () x1445) tmp1448) ((lambda (_1449) (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))) x1445 y1446)) tmp1447))) ($sc-dispatch tmp1447 (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))) ()))))) y1446)) tmp1444) (syntax-violation #f "source expression failed to match any pattern" tmp1443))) ($sc-dispatch tmp1443 (quote (any any))))) (list x1441 y1442)))) (quasivector1423 (lambda (x1450) ((lambda (tmp1451) ((lambda (x1452) ((lambda (tmp1453) ((lambda (tmp1454) (if tmp1454 (apply (lambda (x1455) (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 x1455))) tmp1454) ((lambda (tmp1457) (if tmp1457 (apply (lambda (x1458) (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))) x1458)) tmp1457) ((lambda (_1460) (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))) x1452)) tmp1453))) ($sc-dispatch tmp1453 (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 tmp1453 (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))))) x1452)) tmp1451)) x1450))) (quasi1424 (lambda (p1461 lev1462) ((lambda (tmp1463) ((lambda (tmp1464) (if tmp1464 (apply (lambda (p1465) (if (= lev1462 0) p1465 (quasicons1421 (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)))) (quasi1424 (list p1465) (- lev1462 1))))) tmp1464) ((lambda (tmp1466) (if tmp1466 (apply (lambda (p1467 q1468) (if (= lev1462 0) (quasiappend1422 p1467 (quasi1424 q1468 lev1462)) (quasicons1421 (quasicons1421 (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)))) (quasi1424 (list p1467) (- lev1462 1))) (quasi1424 q1468 lev1462)))) tmp1466) ((lambda (tmp1469) (if tmp1469 (apply (lambda (p1470) (quasicons1421 (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)))) (quasi1424 (list p1470) (+ lev1462 1)))) tmp1469) ((lambda (tmp1471) (if tmp1471 (apply (lambda (p1472 q1473) (quasicons1421 (quasi1424 p1472 lev1462) (quasi1424 q1473 lev1462))) tmp1471) ((lambda (tmp1474) (if tmp1474 (apply (lambda (x1475) (quasivector1423 (quasi1424 x1475 lev1462))) tmp1474) ((lambda (p1477) (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))) p1477)) tmp1463))) ($sc-dispatch tmp1463 (quote #(vector each-any)))))) ($sc-dispatch tmp1463 (quote (any . any)))))) ($sc-dispatch tmp1463 (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 tmp1463 (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 tmp1463 (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))))) p1461)))) (lambda (x1478) ((lambda (tmp1479) ((lambda (tmp1480) (if tmp1480 (apply (lambda (_1481 e1482) (quasi1424 e1482 0)) tmp1480) (syntax-violation #f "source expression failed to match any pattern" tmp1479))) ($sc-dispatch tmp1479 (quote (any any))))) x1478)))))
-(define include (make-syncase-macro (quote macro) (lambda (x1483) (letrec ((read-file1484 (lambda (fn1485 k1486) (let ((p1487 (open-input-file fn1485))) (let f1488 ((x1489 (read p1487))) (if (eof-object? x1489) (begin (close-input-port p1487) (quote ())) (cons (datum->syntax k1486 x1489) (f1488 (read p1487))))))))) ((lambda (tmp1490) ((lambda (tmp1491) (if tmp1491 (apply (lambda (k1492 filename1493) (let ((fn1494 (syntax->datum filename1493))) ((lambda (tmp1495) ((lambda (tmp1496) (if tmp1496 (apply (lambda (exp1497) (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))) exp1497)) tmp1496) (syntax-violation #f "source expression failed to match any pattern" tmp1495))) ($sc-dispatch tmp1495 (quote each-any)))) (read-file1484 fn1494 k1492)))) tmp1491) (syntax-violation #f "source expression failed to match any pattern" tmp1490))) ($sc-dispatch tmp1490 (quote (any any))))) x1483)))))
-(define unquote (make-syncase-macro (quote macro) (lambda (x1499) ((lambda (tmp1500) ((lambda (tmp1501) (if tmp1501 (apply (lambda (_1502 e1503) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1499)) tmp1501) (syntax-violation #f "source expression failed to match any pattern" tmp1500))) ($sc-dispatch tmp1500 (quote (any any))))) x1499))))
-(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 e1508) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1504)) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any any))))) x1504))))
-(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1509) ((lambda (tmp1510) ((lambda (tmp1511) (if tmp1511 (apply (lambda (_1512 e1513 m11514 m21515) ((lambda (tmp1516) ((lambda (body1517) (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))) e1513)) body1517)) tmp1516)) (let f1518 ((clause1519 m11514) (clauses1520 m21515)) (if (null? clauses1520) ((lambda (tmp1522) ((lambda (tmp1523) (if tmp1523 (apply (lambda (e11524 e21525) (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 e11524 e21525))) tmp1523) ((lambda (tmp1527) (if tmp1527 (apply (lambda (k1528 e11529 e21530) (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))) k1528)) (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 e11529 e21530)))) tmp1527) ((lambda (_1533) (syntax-violation (quote case) "bad clause" x1509 clause1519)) tmp1522))) ($sc-dispatch tmp1522 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1522 (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))))) clause1519) ((lambda (tmp1534) ((lambda (rest1535) ((lambda (tmp1536) ((lambda (tmp1537) (if tmp1537 (apply (lambda (k1538 e11539 e21540) (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))) k1538)) (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 e11539 e21540)) rest1535)) tmp1537) ((lambda (_1543) (syntax-violation (quote case) "bad clause" x1509 clause1519)) tmp1536))) ($sc-dispatch tmp1536 (quote (each-any any . each-any))))) clause1519)) tmp1534)) (f1518 (car clauses1520) (cdr clauses1520))))))) tmp1511) (syntax-violation #f "source expression failed to match any pattern" tmp1510))) ($sc-dispatch tmp1510 (quote (any any any . each-any))))) x1509))))
-(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1544) ((lambda (tmp1545) ((lambda (tmp1546) (if tmp1546 (apply (lambda (_1547 e1548) (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))) e1548)) (list (cons _1547 (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 e1548 (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)))))))))) tmp1546) (syntax-violation #f "source expression failed to match any pattern" tmp1545))) ($sc-dispatch tmp1545 (quote (any any))))) x1544))))
+(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
+(if #f #f)
+(letrec ((and-map*1697 (lambda (f1737 first1736 . rest1735) (or (null? first1736) (if (null? rest1735) (letrec ((andmap1738 (lambda (first1739) (let ((x1740 (car first1739)) (first1741 (cdr first1739))) (if (null? first1741) (f1737 x1740) (and (f1737 x1740) (andmap1738 first1741))))))) (andmap1738 first1736)) (letrec ((andmap1742 (lambda (first1743 rest1744) (let ((x1745 (car first1743)) (xr1746 (map car rest1744)) (first1747 (cdr first1743)) (rest1748 (map cdr rest1744))) (if (null? first1747) (apply f1737 (cons x1745 xr1746)) (and (apply f1737 (cons x1745 xr1746)) (andmap1742 first1747 rest1748))))))) (andmap1742 first1736 rest1735))))))) (letrec ((lambda-var-list1840 (lambda (vars1969) (letrec ((lvl1970 (lambda (vars1971 ls1972 w1973) (cond ((pair? vars1971) (lvl1970 (cdr vars1971) (cons (wrap1819 (car vars1971) w1973 (quote #f)) ls1972) w1973)) ((id?1791 vars1971) (cons (wrap1819 vars1971 w1973 (quote #f)) ls1972)) ((null? vars1971) ls1972) ((syntax-object?1775 vars1971) (lvl1970 (syntax-object-expression1776 vars1971) ls1972 (join-wraps1810 w1973 (syntax-object-wrap1777 vars1971)))) ((annotation? vars1971) (lvl1970 (annotation-expression vars1971) ls1972 w1973)) (else (cons vars1971 ls1972)))))) (lvl1970 vars1969 (quote ()) (quote (())))))) (gen-var1839 (lambda (id1974) (let ((id1975 (if (syntax-object?1775 id1974) (syntax-object-expression1776 id1974) id1974))) (if (annotation? id1975) (gensym (symbol->string (annotation-expression id1975))) (gensym (symbol->string id1975)))))) (strip1838 (lambda (x1976 w1977) (if (memq (quote top) (wrap-marks1794 w1977)) (if (or (annotation? x1976) (and (pair? x1976) (annotation? (car x1976)))) (strip-annotation1837 x1976 (quote #f)) x1976) (letrec ((f1978 (lambda (x1979) (cond ((syntax-object?1775 x1979) (strip1838 (syntax-object-expression1776 x1979) (syntax-object-wrap1777 x1979))) ((pair? x1979) (let ((a1980 (f1978 (car x1979))) (d1981 (f1978 (cdr x1979)))) (if (and (eq? a1980 (car x1979)) (eq? d1981 (cdr x1979))) x1979 (cons a1980 d1981)))) ((vector? x1979) (let ((old1982 (vector->list x1979))) (let ((new1983 (map f1978 old1982))) (if (and-map*1697 eq? old1982 new1983) x1979 (list->vector new1983))))) (else x1979))))) (f1978 x1976))))) (strip-annotation1837 (lambda (x1984 parent1985) (cond ((pair? x1984) (let ((new1986 (cons (quote #f) (quote #f)))) (begin (if parent1985 (set-annotation-stripped! parent1985 new1986)) (set-car! new1986 (strip-annotation1837 (car x1984) (quote #f))) (set-cdr! new1986 (strip-annotation1837 (cdr x1984) (quote #f))) new1986))) ((annotation? x1984) (or (annotation-stripped x1984) (strip-annotation1837 (annotation-expression x1984) x1984))) ((vector? x1984) (let ((new1987 (make-vector (vector-length x1984)))) (begin (if parent1985 (set-annotation-stripped! parent1985 new1987)) (letrec ((loop1988 (lambda (i1989) (unless (fx<1754 i1989 (quote 0)) (vector-set! new1987 i1989 (strip-annotation1837 (vector-ref x1984 i1989) (quote #f))) (loop1988 (fx-1752 i1989 (quote 1))))))) (loop1988 (- (vector-length x1984) (quote 1)))) new1987))) (else x1984)))) (ellipsis?1836 (lambda (x1990) (and (nonsymbol-id?1790 x1990) (free-id=?1814 x1990 (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-void1835 (lambda () (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote if)) (quote (#f #f))))) (eval-local-transformer1834 (lambda (expanded1991 mod1992) (let ((p1993 (local-eval-hook1756 expanded1991 mod1992))) (if (procedure? p1993) p1993 (syntax-violation (quote #f) (quote "nonprocedure transformer") p1993))))) (chi-local-syntax1833 (lambda (rec?1994 e1995 r1996 w1997 s1998 mod1999 k2000) ((lambda (tmp2001) ((lambda (tmp2002) (if tmp2002 (apply (lambda (_2003 id2004 val2005 e12006 e22007) (let ((ids2008 id2004)) (if (not (valid-bound-ids?1816 ids2008)) (syntax-violation (quote #f) (quote "duplicate bound keyword") e1995) (let ((labels2010 (gen-labels1797 ids2008))) (let ((new-w2011 (make-binding-wrap1808 ids2008 labels2010 w1997))) (k2000 (cons e12006 e22007) (extend-env1785 labels2010 (let ((w2013 (if rec?1994 new-w2011 w1997)) (trans-r2014 (macros-only-env1787 r1996))) (map (lambda (x2015) (cons (quote macro) (eval-local-transformer1834 (chi1827 x2015 trans-r2014 w2013 mod1999) mod1999))) val2005)) r1996) new-w2011 s1998 mod1999)))))) tmp2002) ((lambda (_2017) (syntax-violation (quote #f) (quote "bad local syntax definition") (source-wrap1820 e1995 w1997 s1998 mod1999))) tmp2001))) ($sc-dispatch tmp2001 (quote (any #(each (any any)) any . each-any))))) e1995))) (chi-lambda-clause1832 (lambda (e2018 docstring2019 c2020 r2021 w2022 mod2023 k2024) ((lambda (tmp2025) ((lambda (tmp2026) (if (if tmp2026 (apply (lambda (args2027 doc2028 e12029 e22030) (and (string? (syntax->datum doc2028)) (not docstring2019))) tmp2026) (quote #f)) (apply (lambda (args2031 doc2032 e12033 e22034) (chi-lambda-clause1832 e2018 doc2032 (cons args2031 (cons e12033 e22034)) r2021 w2022 mod2023 k2024)) tmp2026) ((lambda (tmp2036) (if tmp2036 (apply (lambda (id2037 e12038 e22039) (let ((ids2040 id2037)) (if (not (valid-bound-ids?1816 ids2040)) (syntax-violation (quote lambda) (quote "invalid parameter list") e2018) (let ((labels2042 (gen-labels1797 ids2040)) (new-vars2043 (map gen-var1839 ids2040))) (k2024 new-vars2043 docstring2019 (chi-body1831 (cons e12038 e22039) e2018 (extend-var-env1786 labels2042 new-vars2043 r2021) (make-binding-wrap1808 ids2040 labels2042 w2022) mod2023)))))) tmp2036) ((lambda (tmp2045) (if tmp2045 (apply (lambda (ids2046 e12047 e22048) (let ((old-ids2049 (lambda-var-list1840 ids2046))) (if (not (valid-bound-ids?1816 old-ids2049)) (syntax-violation (quote lambda) (quote "invalid parameter list") e2018) (let ((labels2050 (gen-labels1797 old-ids2049)) (new-vars2051 (map gen-var1839 old-ids2049))) (k2024 (letrec ((f2052 (lambda (ls12053 ls22054) (if (null? ls12053) ls22054 (f2052 (cdr ls12053) (cons (car ls12053) ls22054)))))) (f2052 (cdr new-vars2051) (car new-vars2051))) docstring2019 (chi-body1831 (cons e12047 e22048) e2018 (extend-var-env1786 labels2050 new-vars2051 r2021) (make-binding-wrap1808 old-ids2049 labels2050 w2022) mod2023)))))) tmp2045) ((lambda (_2056) (syntax-violation (quote lambda) (quote "bad lambda") e2018)) tmp2025))) ($sc-dispatch tmp2025 (quote (any any . each-any)))))) ($sc-dispatch tmp2025 (quote (each-any any . each-any)))))) ($sc-dispatch tmp2025 (quote (any any any . each-any))))) c2020))) (chi-body1831 (lambda (body2057 outer-form2058 r2059 w2060 mod2061) (let ((r2062 (cons (quote ("placeholder" placeholder)) r2059))) (let ((ribcage2063 (make-ribcage1798 (quote ()) (quote ()) (quote ())))) (let ((w2064 (make-wrap1793 (wrap-marks1794 w2060) (cons ribcage2063 (wrap-subst1795 w2060))))) (letrec ((parse2065 (lambda (body2066 ids2067 labels2068 vars2069 vals2070 bindings2071) (if (null? body2066) (syntax-violation (quote #f) (quote "no expressions in body") outer-form2058) (let ((e2073 (cdar body2066)) (er2074 (caar body2066))) (call-with-values (lambda () (syntax-type1825 e2073 er2074 (quote (())) (quote #f) ribcage2063 mod2061)) (lambda (type2075 value2076 e2077 w2078 s2079 mod2080) (let ((t2081 type2075)) (if (memv t2081 (quote (define-form))) (let ((id2082 (wrap1819 value2076 w2078 mod2080)) (label2083 (gen-label1796))) (let ((var2084 (gen-var1839 id2082))) (begin (extend-ribcage!1807 ribcage2063 id2082 label2083) (parse2065 (cdr body2066) (cons id2082 ids2067) (cons label2083 labels2068) (cons var2084 vars2069) (cons (cons er2074 (wrap1819 e2077 w2078 mod2080)) vals2070) (cons (cons (quote lexical) var2084) bindings2071))))) (if (memv t2081 (quote (define-syntax-form))) (let ((id2085 (wrap1819 value2076 w2078 mod2080)) (label2086 (gen-label1796))) (begin (extend-ribcage!1807 ribcage2063 id2085 label2086) (parse2065 (cdr body2066) (cons id2085 ids2067) (cons label2086 labels2068) vars2069 vals2070 (cons (cons (quote macro) (cons er2074 (wrap1819 e2077 w2078 mod2080))) bindings2071)))) (if (memv t2081 (quote (begin-form))) ((lambda (tmp2087) ((lambda (tmp2088) (if tmp2088 (apply (lambda (_2089 e12090) (parse2065 (letrec ((f2091 (lambda (forms2092) (if (null? forms2092) (cdr body2066) (cons (cons er2074 (wrap1819 (car forms2092) w2078 mod2080)) (f2091 (cdr forms2092))))))) (f2091 e12090)) ids2067 labels2068 vars2069 vals2070 bindings2071)) tmp2088) (syntax-violation #f "source expression failed to match any pattern" tmp2087))) ($sc-dispatch tmp2087 (quote (any . each-any))))) e2077) (if (memv t2081 (quote (local-syntax-form))) (chi-local-syntax1833 value2076 e2077 er2074 w2078 s2079 mod2080 (lambda (forms2094 er2095 w2096 s2097 mod2098) (parse2065 (letrec ((f2099 (lambda (forms2100) (if (null? forms2100) (cdr body2066) (cons (cons er2095 (wrap1819 (car forms2100) w2096 mod2098)) (f2099 (cdr forms2100))))))) (f2099 forms2094)) ids2067 labels2068 vars2069 vals2070 bindings2071))) (if (null? ids2067) (build-sequence1770 (quote #f) (map (lambda (x2101) (chi1827 (cdr x2101) (car x2101) (quote (())) mod2080)) (cons (cons er2074 (source-wrap1820 e2077 w2078 s2079 mod2080)) (cdr body2066)))) (begin (if (not (valid-bound-ids?1816 ids2067)) (syntax-violation (quote #f) (quote "invalid or duplicate identifier in definition") outer-form2058)) (letrec ((loop2102 (lambda (bs2103 er-cache2104 r-cache2105) (if (not (null? bs2103)) (let ((b2106 (car bs2103))) (if (eq? (car b2106) (quote macro)) (let ((er2107 (cadr b2106))) (let ((r-cache2108 (if (eq? er2107 er-cache2104) r-cache2105 (macros-only-env1787 er2107)))) (begin (set-cdr! b2106 (eval-local-transformer1834 (chi1827 (cddr b2106) r-cache2108 (quote (())) mod2080) mod2080)) (loop2102 (cdr bs2103) er2107 r-cache2108)))) (loop2102 (cdr bs2103) er-cache2104 r-cache2105))))))) (loop2102 bindings2071 (quote #f) (quote #f))) (set-cdr! r2062 (extend-env1785 labels2068 bindings2071 (cdr r2062))) (build-letrec1773 (quote #f) vars2069 (map (lambda (x2109) (chi1827 (cdr x2109) (car x2109) (quote (())) mod2080)) vals2070) (build-sequence1770 (quote #f) (map (lambda (x2110) (chi1827 (cdr x2110) (car x2110) (quote (())) mod2080)) (cons (cons er2074 (source-wrap1820 e2077 w2078 s2079 mod2080)) (cdr body2066))))))))))))))))))) (parse2065 (map (lambda (x2072) (cons r2062 (wrap1819 x2072 w2064 mod2061))) body2057) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro1830 (lambda (p2111 e2112 r2113 w2114 rib2115 mod2116) (letrec ((rebuild-macro-output2117 (lambda (x2118 m2119) (cond ((pair? x2118) (cons (rebuild-macro-output2117 (car x2118) m2119) (rebuild-macro-output2117 (cdr x2118) m2119))) ((syntax-object?1775 x2118) (let ((w2120 (syntax-object-wrap1777 x2118))) (let ((ms2121 (wrap-marks1794 w2120)) (s2122 (wrap-subst1795 w2120))) (if (and (pair? ms2121) (eq? (car ms2121) (quote #f))) (make-syntax-object1774 (syntax-object-expression1776 x2118) (make-wrap1793 (cdr ms2121) (if rib2115 (cons rib2115 (cdr s2122)) (cdr s2122))) (syntax-object-module1778 x2118)) (make-syntax-object1774 (syntax-object-expression1776 x2118) (make-wrap1793 (cons m2119 ms2121) (if rib2115 (cons rib2115 (cons (quote shift) s2122)) (cons (quote shift) s2122))) (let ((pmod2123 (procedure-module p2111))) (if pmod2123 (cons (quote hygiene) (module-name pmod2123)) (quote (hygiene guile))))))))) ((vector? x2118) (let ((n2124 (vector-length x2118))) (let ((v2125 (make-vector n2124))) (letrec ((doloop2126 (lambda (i2127) (if (fx=1753 i2127 n2124) v2125 (begin (vector-set! v2125 i2127 (rebuild-macro-output2117 (vector-ref x2118 i2127) m2119)) (doloop2126 (fx+1751 i2127 (quote 1)))))))) (doloop2126 (quote 0)))))) ((symbol? x2118) (syntax-violation (quote #f) (quote "encountered raw symbol in macro output") (source-wrap1820 e2112 w2114 s mod2116) x2118)) (else x2118))))) (rebuild-macro-output2117 (p2111 (wrap1819 e2112 (anti-mark1806 w2114) mod2116)) (string (quote #\m)))))) (chi-application1829 (lambda (x2128 e2129 r2130 w2131 s2132 mod2133) ((lambda (tmp2134) ((lambda (tmp2135) (if tmp2135 (apply (lambda (e02136 e12137) (build-application1759 s2132 x2128 (map (lambda (e2138) (chi1827 e2138 r2130 w2131 mod2133)) e12137))) tmp2135) (syntax-violation #f "source expression failed to match any pattern" tmp2134))) ($sc-dispatch tmp2134 (quote (any . each-any))))) e2129))) (chi-expr1828 (lambda (type2140 value2141 e2142 r2143 w2144 s2145 mod2146) (let ((t2147 type2140)) (if (memv t2147 (quote (lexical))) (build-lexical-reference1761 (quote value) s2145 e2142 value2141) (if (memv t2147 (quote (core external-macro))) (value2141 e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (module-ref))) (call-with-values (lambda () (value2141 e2142)) (lambda (id2148 mod2149) (build-global-reference1764 s2145 id2148 mod2149))) (if (memv t2147 (quote (lexical-call))) (chi-application1829 (build-lexical-reference1761 (quote fun) (source-annotation1782 (car e2142)) (car e2142) value2141) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (global-call))) (chi-application1829 (build-global-reference1764 (source-annotation1782 (car e2142)) value2141 (if (syntax-object?1775 (car e2142)) (syntax-object-module1778 (car e2142)) mod2146)) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (constant))) (build-data1769 s2145 (strip1838 (source-wrap1820 e2142 w2144 s2145 mod2146) (quote (())))) (if (memv t2147 (quote (global))) (build-global-reference1764 s2145 value2141 mod2146) (if (memv t2147 (quote (call))) (chi-application1829 (chi1827 (car e2142) r2143 w2144 mod2146) e2142 r2143 w2144 s2145 mod2146) (if (memv t2147 (quote (begin-form))) ((lambda (tmp2150) ((lambda (tmp2151) (if tmp2151 (apply (lambda (_2152 e12153 e22154) (chi-sequence1821 (cons e12153 e22154) r2143 w2144 s2145 mod2146)) tmp2151) (syntax-violation #f "source expression failed to match any pattern" tmp2150))) ($sc-dispatch tmp2150 (quote (any any . each-any))))) e2142) (if (memv t2147 (quote (local-syntax-form))) (chi-local-syntax1833 value2141 e2142 r2143 w2144 s2145 mod2146 chi-sequence1821) (if (memv t2147 (quote (eval-when-form))) ((lambda (tmp2156) ((lambda (tmp2157) (if tmp2157 (apply (lambda (_2158 x2159 e12160 e22161) (let ((when-list2162 (chi-when-list1824 e2142 x2159 w2144))) (if (memq (quote eval) when-list2162) (chi-sequence1821 (cons e12160 e22161) r2143 w2144 s2145 mod2146) (chi-void1835)))) tmp2157) (syntax-violation #f "source expression failed to match any pattern" tmp2156))) ($sc-dispatch tmp2156 (quote (any each-any any . each-any))))) e2142) (if (memv t2147 (quote (define-form define-syntax-form))) (syntax-violation (quote #f) (quote "definition in expression context") e2142 (wrap1819 value2141 w2144 mod2146)) (if (memv t2147 (quote (syntax))) (syntax-violation (quote #f) (quote "reference to pattern variable outside syntax form") (source-wrap1820 e2142 w2144 s2145 mod2146)) (if (memv t2147 (quote (displaced-lexical))) (syntax-violation (quote #f) (quote "reference to identifier outside its scope") (source-wrap1820 e2142 w2144 s2145 mod2146)) (syntax-violation (quote #f) (quote "unexpected syntax") (source-wrap1820 e2142 w2144 s2145 mod2146))))))))))))))))))) (chi1827 (lambda (e2165 r2166 w2167 mod2168) (call-with-values (lambda () (syntax-type1825 e2165 r2166 w2167 (quote #f) (quote #f) mod2168)) (lambda (type2169 value2170 e2171 w2172 s2173 mod2174) (chi-expr1828 type2169 value2170 e2171 r2166 w2172 s2173 mod2174))))) (chi-top1826 (lambda (e2175 r2176 w2177 m2178 esew2179 mod2180) (call-with-values (lambda () (syntax-type1825 e2175 r2176 w2177 (quote #f) (quote #f) mod2180)) (lambda (type2188 value2189 e2190 w2191 s2192 mod2193) (let ((t2194 type2188)) (if (memv t2194 (quote (begin-form))) ((lambda (tmp2195) ((lambda (tmp2196) (if tmp2196 (apply (lambda (_2197) (chi-void1835)) tmp2196) ((lambda (tmp2198) (if tmp2198 (apply (lambda (_2199 e12200 e22201) (chi-top-sequence1822 (cons e12200 e22201) r2176 w2191 s2192 m2178 esew2179 mod2193)) tmp2198) (syntax-violation #f "source expression failed to match any pattern" tmp2195))) ($sc-dispatch tmp2195 (quote (any any . each-any)))))) ($sc-dispatch tmp2195 (quote (any))))) e2190) (if (memv t2194 (quote (local-syntax-form))) (chi-local-syntax1833 value2189 e2190 r2176 w2191 s2192 mod2193 (lambda (body2203 r2204 w2205 s2206 mod2207) (chi-top-sequence1822 body2203 r2204 w2205 s2206 m2178 esew2179 mod2207))) (if (memv t2194 (quote (eval-when-form))) ((lambda (tmp2208) ((lambda (tmp2209) (if tmp2209 (apply (lambda (_2210 x2211 e12212 e22213) (let ((when-list2214 (chi-when-list1824 e2190 x2211 w2191)) (body2215 (cons e12212 e22213))) (cond ((eq? m2178 (quote e)) (if (memq (quote eval) when-list2214) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote e) (quote (eval)) mod2193) (chi-void1835))) ((memq (quote load) when-list2214) (if (or (memq (quote compile) when-list2214) (and (eq? m2178 (quote c&e)) (memq (quote eval) when-list2214))) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote c&e) (quote (compile load)) mod2193) (if (memq m2178 (quote (c c&e))) (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote c) (quote (load)) mod2193) (chi-void1835)))) ((or (memq (quote compile) when-list2214) (and (eq? m2178 (quote c&e)) (memq (quote eval) when-list2214))) (top-level-eval-hook1755 (chi-top-sequence1822 body2215 r2176 w2191 s2192 (quote e) (quote (eval)) mod2193) mod2193) (chi-void1835)) (else (chi-void1835))))) tmp2209) (syntax-violation #f "source expression failed to match any pattern" tmp2208))) ($sc-dispatch tmp2208 (quote (any each-any any . each-any))))) e2190) (if (memv t2194 (quote (define-syntax-form))) (let ((n2218 (id-var-name1813 value2189 w2191)) (r2219 (macros-only-env1787 r2176))) (let ((t2220 m2178)) (if (memv t2220 (quote (c))) (if (memq (quote compile) esew2179) (let ((e2221 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)))) (begin (top-level-eval-hook1755 e2221 mod2193) (if (memq (quote load) esew2179) e2221 (chi-void1835)))) (if (memq (quote load) esew2179) (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)) (chi-void1835))) (if (memv t2220 (quote (c&e))) (let ((e2222 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)))) (begin (top-level-eval-hook1755 e2222 mod2193) e2222)) (begin (if (memq (quote eval) esew2179) (top-level-eval-hook1755 (chi-install-global1823 n2218 (chi1827 e2190 r2219 w2191 mod2193)) mod2193)) (chi-void1835)))))) (if (memv t2194 (quote (define-form))) (let ((n2223 (id-var-name1813 value2189 w2191))) (let ((type2224 (binding-type1783 (lookup1788 n2223 r2176 mod2193)))) (let ((t2225 type2224)) (if (memv t2225 (quote (global core macro module-ref))) (let ((x2226 (build-global-definition1766 s2192 n2223 (chi1827 e2190 r2176 w2191 mod2193)))) (begin (if (eq? m2178 (quote c&e)) (top-level-eval-hook1755 x2226 mod2193)) x2226)) (if (memv t2225 (quote (displaced-lexical))) (syntax-violation (quote #f) (quote "identifier out of context") e2190 (wrap1819 value2189 w2191 mod2193)) (syntax-violation (quote #f) (quote "cannot define keyword at top level") e2190 (wrap1819 value2189 w2191 mod2193))))))) (let ((x2227 (chi-expr1828 type2188 value2189 e2190 r2176 w2191 s2192 mod2193))) (begin (if (eq? m2178 (quote c&e)) (top-level-eval-hook1755 x2227 mod2193)) x2227)))))))))))) (syntax-type1825 (lambda (e2228 r2229 w2230 s2231 rib2232 mod2233) (cond ((symbol? e2228) (let ((n2234 (id-var-name1813 e2228 w2230))) (let ((b2235 (lookup1788 n2234 r2229 mod2233))) (let ((type2236 (binding-type1783 b2235))) (let ((t2237 type2236)) (if (memv t2237 (quote (lexical))) (values type2236 (binding-value1784 b2235) e2228 w2230 s2231 mod2233) (if (memv t2237 (quote (global))) (values type2236 n2234 e2228 w2230 s2231 mod2233) (if (memv t2237 (quote (macro))) (syntax-type1825 (chi-macro1830 (binding-value1784 b2235) e2228 r2229 w2230 rib2232 mod2233) r2229 (quote (())) s2231 rib2232 mod2233) (values type2236 (binding-value1784 b2235) e2228 w2230 s2231 mod2233))))))))) ((pair? e2228) (let ((first2238 (car e2228))) (if (id?1791 first2238) (let ((n2239 (id-var-name1813 first2238 w2230))) (let ((b2240 (lookup1788 n2239 r2229 (or (and (syntax-object?1775 first2238) (syntax-object-module1778 first2238)) mod2233)))) (let ((type2241 (binding-type1783 b2240))) (let ((t2242 type2241)) (if (memv t2242 (quote (lexical))) (values (quote lexical-call) (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (global))) (values (quote global-call) n2239 e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (macro))) (syntax-type1825 (chi-macro1830 (binding-value1784 b2240) e2228 r2229 w2230 rib2232 mod2233) r2229 (quote (())) s2231 rib2232 mod2233) (if (memv t2242 (quote (core external-macro module-ref))) (values type2241 (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value1784 b2240) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (begin))) (values (quote begin-form) (quote #f) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e2228 w2230 s2231 mod2233) (if (memv t2242 (quote (define))) ((lambda (tmp2243) ((lambda (tmp2244) (if (if tmp2244 (apply (lambda (_2245 name2246 val2247) (id?1791 name2246)) tmp2244) (quote #f)) (apply (lambda (_2248 name2249 val2250) (values (quote define-form) name2249 val2250 w2230 s2231 mod2233)) tmp2244) ((lambda (tmp2251) (if (if tmp2251 (apply (lambda (_2252 name2253 args2254 e12255 e22256) (and (id?1791 name2253) (valid-bound-ids?1816 (lambda-var-list1840 args2254)))) tmp2251) (quote #f)) (apply (lambda (_2257 name2258 args2259 e12260 e22261) (values (quote define-form) (wrap1819 name2258 w2230 mod2233) (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))) (wrap1819 (cons args2259 (cons e12260 e22261)) w2230 mod2233)) (quote (())) s2231 mod2233)) tmp2251) ((lambda (tmp2263) (if (if tmp2263 (apply (lambda (_2264 name2265) (id?1791 name2265)) tmp2263) (quote #f)) (apply (lambda (_2266 name2267) (values (quote define-form) (wrap1819 name2267 w2230 mod2233) (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 (())) s2231 mod2233)) tmp2263) (syntax-violation #f "source expression failed to match any pattern" tmp2243))) ($sc-dispatch tmp2243 (quote (any any)))))) ($sc-dispatch tmp2243 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp2243 (quote (any any any))))) e2228) (if (memv t2242 (quote (define-syntax))) ((lambda (tmp2268) ((lambda (tmp2269) (if (if tmp2269 (apply (lambda (_2270 name2271 val2272) (id?1791 name2271)) tmp2269) (quote #f)) (apply (lambda (_2273 name2274 val2275) (values (quote define-syntax-form) name2274 val2275 w2230 s2231 mod2233)) tmp2269) (syntax-violation #f "source expression failed to match any pattern" tmp2268))) ($sc-dispatch tmp2268 (quote (any any any))))) e2228) (values (quote call) (quote #f) e2228 w2230 s2231 mod2233)))))))))))))) (values (quote call) (quote #f) e2228 w2230 s2231 mod2233)))) ((syntax-object?1775 e2228) (syntax-type1825 (syntax-object-expression1776 e2228) r2229 (join-wraps1810 w2230 (syntax-object-wrap1777 e2228)) (quote #f) rib2232 (or (syntax-object-module1778 e2228) mod2233))) ((annotation? e2228) (syntax-type1825 (annotation-expression e2228) r2229 w2230 (annotation-source e2228) rib2232 mod2233)) ((self-evaluating? e2228) (values (quote constant) (quote #f) e2228 w2230 s2231 mod2233)) (else (values (quote other) (quote #f) e2228 w2230 s2231 mod2233))))) (chi-when-list1824 (lambda (e2276 when-list2277 w2278) (letrec ((f2279 (lambda (when-list2280 situations2281) (if (null? when-list2280) situations2281 (f2279 (cdr when-list2280) (cons (let ((x2282 (car when-list2280))) (cond ((free-id=?1814 x2282 (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=?1814 x2282 (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=?1814 x2282 (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) (quote "invalid situation") e2276 (wrap1819 x2282 w2278 (quote #f)))))) situations2281)))))) (f2279 when-list2277 (quote ()))))) (chi-install-global1823 (lambda (name2283 e2284) (build-global-definition1766 (quote #f) name2283 (if (let ((v2285 (module-variable (current-module) name2283))) (and v2285 (variable-bound? v2285) (macro? (variable-ref v2285)) (not (eq? (macro-type (variable-ref v2285)) (quote syncase-macro))))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote make-extended-syncase-macro)) (list (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote module-ref)) (list (build-application1759 (quote #f) (quote current-module) (quote ())) (build-data1769 (quote #f) name2283))) (build-data1769 (quote #f) (quote macro)) e2284)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote make-syncase-macro)) (list (build-data1769 (quote #f) (quote macro)) e2284)))))) (chi-top-sequence1822 (lambda (body2286 r2287 w2288 s2289 m2290 esew2291 mod2292) (build-sequence1770 s2289 (letrec ((dobody2293 (lambda (body2294 r2295 w2296 m2297 esew2298 mod2299) (if (null? body2294) (quote ()) (let ((first2300 (chi-top1826 (car body2294) r2295 w2296 m2297 esew2298 mod2299))) (cons first2300 (dobody2293 (cdr body2294) r2295 w2296 m2297 esew2298 mod2299))))))) (dobody2293 body2286 r2287 w2288 m2290 esew2291 mod2292))))) (chi-sequence1821 (lambda (body2301 r2302 w2303 s2304 mod2305) (build-sequence1770 s2304 (letrec ((dobody2306 (lambda (body2307 r2308 w2309 mod2310) (if (null? body2307) (quote ()) (let ((first2311 (chi1827 (car body2307) r2308 w2309 mod2310))) (cons first2311 (dobody2306 (cdr body2307) r2308 w2309 mod2310))))))) (dobody2306 body2301 r2302 w2303 mod2305))))) (source-wrap1820 (lambda (x2312 w2313 s2314 defmod2315) (wrap1819 (if s2314 (make-annotation x2312 s2314 (quote #f)) x2312) w2313 defmod2315))) (wrap1819 (lambda (x2316 w2317 defmod2318) (cond ((and (null? (wrap-marks1794 w2317)) (null? (wrap-subst1795 w2317))) x2316) ((syntax-object?1775 x2316) (make-syntax-object1774 (syntax-object-expression1776 x2316) (join-wraps1810 w2317 (syntax-object-wrap1777 x2316)) (syntax-object-module1778 x2316))) ((null? x2316) x2316) (else (make-syntax-object1774 x2316 w2317 defmod2318))))) (bound-id-member?1818 (lambda (x2319 list2320) (and (not (null? list2320)) (or (bound-id=?1815 x2319 (car list2320)) (bound-id-member?1818 x2319 (cdr list2320)))))) (distinct-bound-ids?1817 (lambda (ids2321) (letrec ((distinct?2322 (lambda (ids2323) (or (null? ids2323) (and (not (bound-id-member?1818 (car ids2323) (cdr ids2323))) (distinct?2322 (cdr ids2323))))))) (distinct?2322 ids2321)))) (valid-bound-ids?1816 (lambda (ids2324) (and (letrec ((all-ids?2325 (lambda (ids2326) (or (null? ids2326) (and (id?1791 (car ids2326)) (all-ids?2325 (cdr ids2326))))))) (all-ids?2325 ids2324)) (distinct-bound-ids?1817 ids2324)))) (bound-id=?1815 (lambda (i2327 j2328) (if (and (syntax-object?1775 i2327) (syntax-object?1775 j2328)) (and (eq? (let ((e2329 (syntax-object-expression1776 i2327))) (if (annotation? e2329) (annotation-expression e2329) e2329)) (let ((e2330 (syntax-object-expression1776 j2328))) (if (annotation? e2330) (annotation-expression e2330) e2330))) (same-marks?1812 (wrap-marks1794 (syntax-object-wrap1777 i2327)) (wrap-marks1794 (syntax-object-wrap1777 j2328)))) (eq? (let ((e2331 i2327)) (if (annotation? e2331) (annotation-expression e2331) e2331)) (let ((e2332 j2328)) (if (annotation? e2332) (annotation-expression e2332) e2332)))))) (free-id=?1814 (lambda (i2333 j2334) (and (eq? (let ((x2335 i2333)) (let ((e2336 (if (syntax-object?1775 x2335) (syntax-object-expression1776 x2335) x2335))) (if (annotation? e2336) (annotation-expression e2336) e2336))) (let ((x2337 j2334)) (let ((e2338 (if (syntax-object?1775 x2337) (syntax-object-expression1776 x2337) x2337))) (if (annotation? e2338) (annotation-expression e2338) e2338)))) (eq? (id-var-name1813 i2333 (quote (()))) (id-var-name1813 j2334 (quote (()))))))) (id-var-name1813 (lambda (id2339 w2340) (letrec ((search-vector-rib2343 (lambda (sym2349 subst2350 marks2351 symnames2352 ribcage2353) (let ((n2354 (vector-length symnames2352))) (letrec ((f2355 (lambda (i2356) (cond ((fx=1753 i2356 n2354) (search2341 sym2349 (cdr subst2350) marks2351)) ((and (eq? (vector-ref symnames2352 i2356) sym2349) (same-marks?1812 marks2351 (vector-ref (ribcage-marks1801 ribcage2353) i2356))) (values (vector-ref (ribcage-labels1802 ribcage2353) i2356) marks2351)) (else (f2355 (fx+1751 i2356 (quote 1)))))))) (f2355 (quote 0)))))) (search-list-rib2342 (lambda (sym2357 subst2358 marks2359 symnames2360 ribcage2361) (letrec ((f2362 (lambda (symnames2363 i2364) (cond ((null? symnames2363) (search2341 sym2357 (cdr subst2358) marks2359)) ((and (eq? (car symnames2363) sym2357) (same-marks?1812 marks2359 (list-ref (ribcage-marks1801 ribcage2361) i2364))) (values (list-ref (ribcage-labels1802 ribcage2361) i2364) marks2359)) (else (f2362 (cdr symnames2363) (fx+1751 i2364 (quote 1)))))))) (f2362 symnames2360 (quote 0))))) (search2341 (lambda (sym2365 subst2366 marks2367) (if (null? subst2366) (values (quote #f) marks2367) (let ((fst2368 (car subst2366))) (if (eq? fst2368 (quote shift)) (search2341 sym2365 (cdr subst2366) (cdr marks2367)) (let ((symnames2369 (ribcage-symnames1800 fst2368))) (if (vector? symnames2369) (search-vector-rib2343 sym2365 subst2366 marks2367 symnames2369 fst2368) (search-list-rib2342 sym2365 subst2366 marks2367 symnames2369 fst2368))))))))) (cond ((symbol? id2339) (or (call-with-values (lambda () (search2341 id2339 (wrap-subst1795 w2340) (wrap-marks1794 w2340))) (lambda (x2371 . ignore2370) x2371)) id2339)) ((syntax-object?1775 id2339) (let ((id2372 (let ((e2374 (syntax-object-expression1776 id2339))) (if (annotation? e2374) (annotation-expression e2374) e2374))) (w12373 (syntax-object-wrap1777 id2339))) (let ((marks2375 (join-marks1811 (wrap-marks1794 w2340) (wrap-marks1794 w12373)))) (call-with-values (lambda () (search2341 id2372 (wrap-subst1795 w2340) marks2375)) (lambda (new-id2376 marks2377) (or new-id2376 (call-with-values (lambda () (search2341 id2372 (wrap-subst1795 w12373) marks2377)) (lambda (x2379 . ignore2378) x2379)) id2372)))))) ((annotation? id2339) (let ((id2380 (let ((e2381 id2339)) (if (annotation? e2381) (annotation-expression e2381) e2381)))) (or (call-with-values (lambda () (search2341 id2380 (wrap-subst1795 w2340) (wrap-marks1794 w2340))) (lambda (x2383 . ignore2382) x2383)) id2380))) (else (syntax-violation (quote id-var-name) (quote "invalid id") id2339)))))) (same-marks?1812 (lambda (x2384 y2385) (or (eq? x2384 y2385) (and (not (null? x2384)) (not (null? y2385)) (eq? (car x2384) (car y2385)) (same-marks?1812 (cdr x2384) (cdr y2385)))))) (join-marks1811 (lambda (m12386 m22387) (smart-append1809 m12386 m22387))) (join-wraps1810 (lambda (w12388 w22389) (let ((m12390 (wrap-marks1794 w12388)) (s12391 (wrap-subst1795 w12388))) (if (null? m12390) (if (null? s12391) w22389 (make-wrap1793 (wrap-marks1794 w22389) (smart-append1809 s12391 (wrap-subst1795 w22389)))) (make-wrap1793 (smart-append1809 m12390 (wrap-marks1794 w22389)) (smart-append1809 s12391 (wrap-subst1795 w22389))))))) (smart-append1809 (lambda (m12392 m22393) (if (null? m22393) m12392 (append m12392 m22393)))) (make-binding-wrap1808 (lambda (ids2394 labels2395 w2396) (if (null? ids2394) w2396 (make-wrap1793 (wrap-marks1794 w2396) (cons (let ((labelvec2397 (list->vector labels2395))) (let ((n2398 (vector-length labelvec2397))) (let ((symnamevec2399 (make-vector n2398)) (marksvec2400 (make-vector n2398))) (begin (letrec ((f2401 (lambda (ids2402 i2403) (if (not (null? ids2402)) (call-with-values (lambda () (id-sym-name&marks1792 (car ids2402) w2396)) (lambda (symname2404 marks2405) (begin (vector-set! symnamevec2399 i2403 symname2404) (vector-set! marksvec2400 i2403 marks2405) (f2401 (cdr ids2402) (fx+1751 i2403 (quote 1)))))))))) (f2401 ids2394 (quote 0))) (make-ribcage1798 symnamevec2399 marksvec2400 labelvec2397))))) (wrap-subst1795 w2396)))))) (extend-ribcage!1807 (lambda (ribcage2406 id2407 label2408) (begin (set-ribcage-symnames!1803 ribcage2406 (cons (let ((e2409 (syntax-object-expression1776 id2407))) (if (annotation? e2409) (annotation-expression e2409) e2409)) (ribcage-symnames1800 ribcage2406))) (set-ribcage-marks!1804 ribcage2406 (cons (wrap-marks1794 (syntax-object-wrap1777 id2407)) (ribcage-marks1801 ribcage2406))) (set-ribcage-labels!1805 ribcage2406 (cons label2408 (ribcage-labels1802 ribcage2406)))))) (anti-mark1806 (lambda (w2410) (make-wrap1793 (cons (quote #f) (wrap-marks1794 w2410)) (cons (quote shift) (wrap-subst1795 w2410))))) (set-ribcage-labels!1805 (lambda (x2411 update2412) (vector-set! x2411 (quote 3) update2412))) (set-ribcage-marks!1804 (lambda (x2413 update2414) (vector-set! x2413 (quote 2) update2414))) (set-ribcage-symnames!1803 (lambda (x2415 update2416) (vector-set! x2415 (quote 1) update2416))) (ribcage-labels1802 (lambda (x2417) (vector-ref x2417 (quote 3)))) (ribcage-marks1801 (lambda (x2418) (vector-ref x2418 (quote 2)))) (ribcage-symnames1800 (lambda (x2419) (vector-ref x2419 (quote 1)))) (ribcage?1799 (lambda (x2420) (and (vector? x2420) (= (vector-length x2420) (quote 4)) (eq? (vector-ref x2420 (quote 0)) (quote ribcage))))) (make-ribcage1798 (lambda (symnames2421 marks2422 labels2423) (vector (quote ribcage) symnames2421 marks2422 labels2423))) (gen-labels1797 (lambda (ls2424) (if (null? ls2424) (quote ()) (cons (gen-label1796) (gen-labels1797 (cdr ls2424)))))) (gen-label1796 (lambda () (string (quote #\i)))) (wrap-subst1795 cdr) (wrap-marks1794 car) (make-wrap1793 cons) (id-sym-name&marks1792 (lambda (x2425 w2426) (if (syntax-object?1775 x2425) (values (let ((e2427 (syntax-object-expression1776 x2425))) (if (annotation? e2427) (annotation-expression e2427) e2427)) (join-marks1811 (wrap-marks1794 w2426) (wrap-marks1794 (syntax-object-wrap1777 x2425)))) (values (let ((e2428 x2425)) (if (annotation? e2428) (annotation-expression e2428) e2428)) (wrap-marks1794 w2426))))) (id?1791 (lambda (x2429) (cond ((symbol? x2429) (quote #t)) ((syntax-object?1775 x2429) (symbol? (let ((e2430 (syntax-object-expression1776 x2429))) (if (annotation? e2430) (annotation-expression e2430) e2430)))) ((annotation? x2429) (symbol? (annotation-expression x2429))) (else (quote #f))))) (nonsymbol-id?1790 (lambda (x2431) (and (syntax-object?1775 x2431) (symbol? (let ((e2432 (syntax-object-expression1776 x2431))) (if (annotation? e2432) (annotation-expression e2432) e2432)))))) (global-extend1789 (lambda (type2433 sym2434 val2435) (put-global-definition-hook1757 sym2434 type2433 val2435))) (lookup1788 (lambda (x2436 r2437 mod2438) (cond ((assq x2436 r2437) => cdr) ((symbol? x2436) (or (get-global-definition-hook1758 x2436 mod2438) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env1787 (lambda (r2439) (if (null? r2439) (quote ()) (let ((a2440 (car r2439))) (if (eq? (cadr a2440) (quote macro)) (cons a2440 (macros-only-env1787 (cdr r2439))) (macros-only-env1787 (cdr r2439))))))) (extend-var-env1786 (lambda (labels2441 vars2442 r2443) (if (null? labels2441) r2443 (extend-var-env1786 (cdr labels2441) (cdr vars2442) (cons (cons (car labels2441) (cons (quote lexical) (car vars2442))) r2443))))) (extend-env1785 (lambda (labels2444 bindings2445 r2446) (if (null? labels2444) r2446 (extend-env1785 (cdr labels2444) (cdr bindings2445) (cons (cons (car labels2444) (car bindings2445)) r2446))))) (binding-value1784 cdr) (binding-type1783 car) (source-annotation1782 (lambda (x2447) (cond ((annotation? x2447) (annotation-source x2447)) ((syntax-object?1775 x2447) (source-annotation1782 (syntax-object-expression1776 x2447))) (else (quote #f))))) (set-syntax-object-module!1781 (lambda (x2448 update2449) (vector-set! x2448 (quote 3) update2449))) (set-syntax-object-wrap!1780 (lambda (x2450 update2451) (vector-set! x2450 (quote 2) update2451))) (set-syntax-object-expression!1779 (lambda (x2452 update2453) (vector-set! x2452 (quote 1) update2453))) (syntax-object-module1778 (lambda (x2454) (vector-ref x2454 (quote 3)))) (syntax-object-wrap1777 (lambda (x2455) (vector-ref x2455 (quote 2)))) (syntax-object-expression1776 (lambda (x2456) (vector-ref x2456 (quote 1)))) (syntax-object?1775 (lambda (x2457) (and (vector? x2457) (= (vector-length x2457) (quote 4)) (eq? (vector-ref x2457 (quote 0)) (quote syntax-object))))) (make-syntax-object1774 (lambda (expression2458 wrap2459 module2460) (vector (quote syntax-object) expression2458 wrap2459 module2460))) (build-letrec1773 (lambda (src2461 vars2462 val-exps2463 body-exp2464) (if (null? vars2462) body-exp2464 (let ((t2465 (fluid-ref *mode*1750))) (if (memv t2465 (quote (c))) ((@ (language tree-il) make-letrec) src2461 vars2462 val-exps2463 body-exp2464) (list (quote letrec) (map list vars2462 val-exps2463) body-exp2464)))))) (build-named-let1772 (lambda (src2466 vars2467 val-exps2468 body-exp2469) (let ((f2470 (car vars2467)) (vars2471 (cdr vars2467))) (let ((t2472 (fluid-ref *mode*1750))) (if (memv t2472 (quote (c))) ((@ (language tree-il) make-letrec) src2466 (list f2470) (list (build-lambda1767 src2466 vars2471 (quote #f) body-exp2469)) (build-application1759 src2466 (build-lexical-reference1761 (quote fun) src2466 f2470 f2470) val-exps2468)) (list (quote let) f2470 (map list vars2471 val-exps2468) body-exp2469)))))) (build-let1771 (lambda (src2473 vars2474 val-exps2475 body-exp2476) (if (null? vars2474) body-exp2476 (let ((t2477 (fluid-ref *mode*1750))) (if (memv t2477 (quote (c))) ((@ (language tree-il) make-let) src2473 vars2474 val-exps2475 body-exp2476) (list (quote let) (map list vars2474 val-exps2475) body-exp2476)))))) (build-sequence1770 (lambda (src2478 exps2479) (if (null? (cdr exps2479)) (car exps2479) (let ((t2480 (fluid-ref *mode*1750))) (if (memv t2480 (quote (c))) ((@ (language tree-il) make-sequence) src2478 exps2479) (cons (quote begin) exps2479)))))) (build-data1769 (lambda (src2481 exp2482) (let ((t2483 (fluid-ref *mode*1750))) (if (memv t2483 (quote (c))) ((@ (language tree-il) make-const) src2481 exp2482) (if (and (self-evaluating? exp2482) (not (vector? exp2482))) exp2482 (list (quote quote) exp2482)))))) (build-primref1768 (lambda (src2484 name2485) (let ((t2486 (fluid-ref *mode*1750))) (if (memv t2486 (quote (c))) ((@ (language tree-il) make-primitive-ref) src2484 name2485) (build-global-reference1764 src2484 name2485 (quote (hygiene guile))))))) (build-lambda1767 (lambda (src2487 vars2488 docstring2489 exp2490) (let ((t2491 (fluid-ref *mode*1750))) (if (memv t2491 (quote (c))) ((@ (language tree-il) make-lambda) src2487 vars2488 (if docstring2489 (list (cons (quote documentation) docstring2489)) (quote ())) exp2490) (cons (quote lambda) (cons vars2488 (append (if docstring2489 (list docstring2489) (quote ())) (list exp2490)))))))) (build-global-definition1766 (lambda (source2492 var2493 exp2494) (let ((t2495 (fluid-ref *mode*1750))) (if (memv t2495 (quote (c))) ((@ (language tree-il) make-toplevel-define) source2492 var2493 exp2494) (list (quote define) var2493 exp2494))))) (build-global-assignment1765 (lambda (source2496 var2497 exp2498 mod2499) (analyze-variable1763 mod2499 var2497 (lambda (mod2500 var2501 public?2502) (let ((t2503 (fluid-ref *mode*1750))) (if (memv t2503 (quote (c))) ((@ (language tree-il) make-module-set) source2496 mod2500 var2501 public?2502 exp2498) (list (quote set!) (list (if public?2502 (quote @) (quote @@)) mod2500 var2501) exp2498)))) (lambda (var2504) (let ((t2505 (fluid-ref *mode*1750))) (if (memv t2505 (quote (c))) ((@ (language tree-il) make-toplevel-set) source2496 var2504 exp2498) (list (quote set!) var2504 exp2498))))))) (build-global-reference1764 (lambda (source2506 var2507 mod2508) (analyze-variable1763 mod2508 var2507 (lambda (mod2509 var2510 public?2511) (let ((t2512 (fluid-ref *mode*1750))) (if (memv t2512 (quote (c))) ((@ (language tree-il) make-module-ref) source2506 mod2509 var2510 public?2511) (list (if public?2511 (quote @) (quote @@)) mod2509 var2510)))) (lambda (var2513) (let ((t2514 (fluid-ref *mode*1750))) (if (memv t2514 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source2506 var2513) var2513)))))) (analyze-variable1763 (lambda (mod2515 var2516 modref-cont2517 bare-cont2518) (if (not mod2515) (bare-cont2518 var2516) (let ((kind2519 (car mod2515)) (mod2520 (cdr mod2515))) (let ((t2521 kind2519)) (if (memv t2521 (quote (public))) (modref-cont2517 mod2520 var2516 (quote #t)) (if (memv t2521 (quote (private))) (if (not (equal? mod2520 (module-name (current-module)))) (modref-cont2517 mod2520 var2516 (quote #f)) (bare-cont2518 var2516)) (if (memv t2521 (quote (bare))) (bare-cont2518 var2516) (if (memv t2521 (quote (hygiene))) (if (and (not (equal? mod2520 (module-name (current-module)))) (module-variable (resolve-module mod2520) var2516)) (modref-cont2517 mod2520 var2516 (quote #f)) (bare-cont2518 var2516)) (syntax-violation (quote #f) (quote "bad module kind") var2516 mod2520)))))))))) (build-lexical-assignment1762 (lambda (source2522 name2523 var2524 exp2525) (let ((t2526 (fluid-ref *mode*1750))) (if (memv t2526 (quote (c))) ((@ (language tree-il) make-lexical-set) source2522 name2523 var2524 exp2525) (list (quote set!) var2524 exp2525))))) (build-lexical-reference1761 (lambda (type2527 source2528 name2529 var2530) (let ((t2531 (fluid-ref *mode*1750))) (if (memv t2531 (quote (c))) ((@ (language tree-il) make-lexical-ref) source2528 name2529 var2530) var2530)))) (build-conditional1760 (lambda (source2532 test-exp2533 then-exp2534 else-exp2535) (let ((t2536 (fluid-ref *mode*1750))) (if (memv t2536 (quote (c))) ((@ (language tree-il) make-conditional) source2532 test-exp2533 then-exp2534 else-exp2535) (list (quote if) test-exp2533 then-exp2534 else-exp2535))))) (build-application1759 (lambda (source2537 fun-exp2538 arg-exps2539) (let ((t2540 (fluid-ref *mode*1750))) (if (memv t2540 (quote (c))) ((@ (language tree-il) make-application) source2537 fun-exp2538 arg-exps2539) (cons fun-exp2538 arg-exps2539))))) (get-global-definition-hook1758 (lambda (symbol2541 module2542) (begin (if (and (not module2542) (current-module)) (warn (quote "module system is booted, we should have a module") symbol2541)) (let ((v2543 (module-variable (if module2542 (resolve-module (cdr module2542)) (current-module)) symbol2541))) (and v2543 (variable-bound? v2543) (let ((val2544 (variable-ref v2543))) (and (macro? val2544) (syncase-macro-type val2544) (cons (syncase-macro-type val2544) (syncase-macro-binding val2544))))))))) (put-global-definition-hook1757 (lambda (symbol2545 type2546 val2547) (let ((existing2548 (let ((v2549 (module-variable (current-module) symbol2545))) (and v2549 (variable-bound? v2549) (let ((val2550 (variable-ref v2549))) (and (macro? val2550) (not (syncase-macro-type val2550)) val2550)))))) (module-define! (current-module) symbol2545 (if existing2548 (make-extended-syncase-macro existing2548 type2546 val2547) (make-syncase-macro type2546 val2547)))))) (local-eval-hook1756 (lambda (x2551 mod2552) (primitive-eval (list noexpand1749 (let ((t2553 (fluid-ref *mode*1750))) (if (memv t2553 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2551) x2551)))))) (top-level-eval-hook1755 (lambda (x2554 mod2555) (primitive-eval (list noexpand1749 (let ((t2556 (fluid-ref *mode*1750))) (if (memv t2556 (quote (c))) ((@ (language tree-il) tree-il->scheme) x2554) x2554)))))) (fx<1754 <) (fx=1753 =) (fx-1752 -) (fx+1751 +) (*mode*1750 (make-fluid)) (noexpand1749 (quote "noexpand"))) (begin (global-extend1789 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend1789 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend1789 (quote core) (quote fluid-let-syntax) (lambda (e2557 r2558 w2559 s2560 mod2561) ((lambda (tmp2562) ((lambda (tmp2563) (if (if tmp2563 (apply (lambda (_2564 var2565 val2566 e12567 e22568) (valid-bound-ids?1816 var2565)) tmp2563) (quote #f)) (apply (lambda (_2570 var2571 val2572 e12573 e22574) (let ((names2575 (map (lambda (x2576) (id-var-name1813 x2576 w2559)) var2571))) (begin (for-each (lambda (id2578 n2579) (let ((t2580 (binding-type1783 (lookup1788 n2579 r2558 mod2561)))) (if (memv t2580 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) (quote "identifier out of context") e2557 (source-wrap1820 id2578 w2559 s2560 mod2561))))) var2571 names2575) (chi-body1831 (cons e12573 e22574) (source-wrap1820 e2557 w2559 s2560 mod2561) (extend-env1785 names2575 (let ((trans-r2583 (macros-only-env1787 r2558))) (map (lambda (x2584) (cons (quote macro) (eval-local-transformer1834 (chi1827 x2584 trans-r2583 w2559 mod2561) mod2561))) val2572)) r2558) w2559 mod2561)))) tmp2563) ((lambda (_2586) (syntax-violation (quote fluid-let-syntax) (quote "bad syntax") (source-wrap1820 e2557 w2559 s2560 mod2561))) tmp2562))) ($sc-dispatch tmp2562 (quote (any #(each (any any)) any . each-any))))) e2557))) (global-extend1789 (quote core) (quote quote) (lambda (e2587 r2588 w2589 s2590 mod2591) ((lambda (tmp2592) ((lambda (tmp2593) (if tmp2593 (apply (lambda (_2594 e2595) (build-data1769 s2590 (strip1838 e2595 w2589))) tmp2593) ((lambda (_2596) (syntax-violation (quote quote) (quote "bad syntax") (source-wrap1820 e2587 w2589 s2590 mod2591))) tmp2592))) ($sc-dispatch tmp2592 (quote (any any))))) e2587))) (global-extend1789 (quote core) (quote syntax) (letrec ((regen2604 (lambda (x2605) (let ((t2606 (car x2605))) (if (memv t2606 (quote (ref))) (build-lexical-reference1761 (quote value) (quote #f) (cadr x2605) (cadr x2605)) (if (memv t2606 (quote (primitive))) (build-primref1768 (quote #f) (cadr x2605)) (if (memv t2606 (quote (quote))) (build-data1769 (quote #f) (cadr x2605)) (if (memv t2606 (quote (lambda))) (build-lambda1767 (quote #f) (cadr x2605) (quote #f) (regen2604 (caddr x2605))) (if (memv t2606 (quote (map))) (let ((ls2607 (map regen2604 (cdr x2605)))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote map)) ls2607)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (car x2605)) (map regen2604 (cdr x2605))))))))))) (gen-vector2603 (lambda (x2608) (cond ((eq? (car x2608) (quote list)) (cons (quote vector) (cdr x2608))) ((eq? (car x2608) (quote quote)) (list (quote quote) (list->vector (cadr x2608)))) (else (list (quote list->vector) x2608))))) (gen-append2602 (lambda (x2609 y2610) (if (equal? y2610 (quote (quote ()))) x2609 (list (quote append) x2609 y2610)))) (gen-cons2601 (lambda (x2611 y2612) (let ((t2613 (car y2612))) (if (memv t2613 (quote (quote))) (if (eq? (car x2611) (quote quote)) (list (quote quote) (cons (cadr x2611) (cadr y2612))) (if (eq? (cadr y2612) (quote ())) (list (quote list) x2611) (list (quote cons) x2611 y2612))) (if (memv t2613 (quote (list))) (cons (quote list) (cons x2611 (cdr y2612))) (list (quote cons) x2611 y2612)))))) (gen-map2600 (lambda (e2614 map-env2615) (let ((formals2616 (map cdr map-env2615)) (actuals2617 (map (lambda (x2618) (list (quote ref) (car x2618))) map-env2615))) (cond ((eq? (car e2614) (quote ref)) (car actuals2617)) ((and-map (lambda (x2619) (and (eq? (car x2619) (quote ref)) (memq (cadr x2619) formals2616))) (cdr e2614)) (cons (quote map) (cons (list (quote primitive) (car e2614)) (map (let ((r2620 (map cons formals2616 actuals2617))) (lambda (x2621) (cdr (assq (cadr x2621) r2620)))) (cdr e2614))))) (else (cons (quote map) (cons (list (quote lambda) formals2616 e2614) actuals2617))))))) (gen-mappend2599 (lambda (e2622 map-env2623) (list (quote apply) (quote (primitive append)) (gen-map2600 e2622 map-env2623)))) (gen-ref2598 (lambda (src2624 var2625 level2626 maps2627) (if (fx=1753 level2626 (quote 0)) (values var2625 maps2627) (if (null? maps2627) (syntax-violation (quote syntax) (quote "missing ellipsis") src2624) (call-with-values (lambda () (gen-ref2598 src2624 var2625 (fx-1752 level2626 (quote 1)) (cdr maps2627))) (lambda (outer-var2628 outer-maps2629) (let ((b2630 (assq outer-var2628 (car maps2627)))) (if b2630 (values (cdr b2630) maps2627) (let ((inner-var2631 (gen-var1839 (quote tmp)))) (values inner-var2631 (cons (cons (cons outer-var2628 inner-var2631) (car maps2627)) outer-maps2629))))))))))) (gen-syntax2597 (lambda (src2632 e2633 r2634 maps2635 ellipsis?2636 mod2637) (if (id?1791 e2633) (let ((label2638 (id-var-name1813 e2633 (quote (()))))) (let ((b2639 (lookup1788 label2638 r2634 mod2637))) (if (eq? (binding-type1783 b2639) (quote syntax)) (call-with-values (lambda () (let ((var.lev2640 (binding-value1784 b2639))) (gen-ref2598 src2632 (car var.lev2640) (cdr var.lev2640) maps2635))) (lambda (var2641 maps2642) (values (list (quote ref) var2641) maps2642))) (if (ellipsis?2636 e2633) (syntax-violation (quote syntax) (quote "misplaced ellipsis") src2632) (values (list (quote quote) e2633) maps2635))))) ((lambda (tmp2643) ((lambda (tmp2644) (if (if tmp2644 (apply (lambda (dots2645 e2646) (ellipsis?2636 dots2645)) tmp2644) (quote #f)) (apply (lambda (dots2647 e2648) (gen-syntax2597 src2632 e2648 r2634 maps2635 (lambda (x2649) (quote #f)) mod2637)) tmp2644) ((lambda (tmp2650) (if (if tmp2650 (apply (lambda (x2651 dots2652 y2653) (ellipsis?2636 dots2652)) tmp2650) (quote #f)) (apply (lambda (x2654 dots2655 y2656) (letrec ((f2657 (lambda (y2658 k2659) ((lambda (tmp2663) ((lambda (tmp2664) (if (if tmp2664 (apply (lambda (dots2665 y2666) (ellipsis?2636 dots2665)) tmp2664) (quote #f)) (apply (lambda (dots2667 y2668) (f2657 y2668 (lambda (maps2669) (call-with-values (lambda () (k2659 (cons (quote ()) maps2669))) (lambda (x2670 maps2671) (if (null? (car maps2671)) (syntax-violation (quote syntax) (quote "extra ellipsis") src2632) (values (gen-mappend2599 x2670 (car maps2671)) (cdr maps2671)))))))) tmp2664) ((lambda (_2672) (call-with-values (lambda () (gen-syntax2597 src2632 y2658 r2634 maps2635 ellipsis?2636 mod2637)) (lambda (y2673 maps2674) (call-with-values (lambda () (k2659 maps2674)) (lambda (x2675 maps2676) (values (gen-append2602 x2675 y2673) maps2676)))))) tmp2663))) ($sc-dispatch tmp2663 (quote (any . any))))) y2658)))) (f2657 y2656 (lambda (maps2660) (call-with-values (lambda () (gen-syntax2597 src2632 x2654 r2634 (cons (quote ()) maps2660) ellipsis?2636 mod2637)) (lambda (x2661 maps2662) (if (null? (car maps2662)) (syntax-violation (quote syntax) (quote "extra ellipsis") src2632) (values (gen-map2600 x2661 (car maps2662)) (cdr maps2662))))))))) tmp2650) ((lambda (tmp2677) (if tmp2677 (apply (lambda (x2678 y2679) (call-with-values (lambda () (gen-syntax2597 src2632 x2678 r2634 maps2635 ellipsis?2636 mod2637)) (lambda (x2680 maps2681) (call-with-values (lambda () (gen-syntax2597 src2632 y2679 r2634 maps2681 ellipsis?2636 mod2637)) (lambda (y2682 maps2683) (values (gen-cons2601 x2680 y2682) maps2683)))))) tmp2677) ((lambda (tmp2684) (if tmp2684 (apply (lambda (e12685 e22686) (call-with-values (lambda () (gen-syntax2597 src2632 (cons e12685 e22686) r2634 maps2635 ellipsis?2636 mod2637)) (lambda (e2688 maps2689) (values (gen-vector2603 e2688) maps2689)))) tmp2684) ((lambda (_2690) (values (list (quote quote) e2633) maps2635)) tmp2643))) ($sc-dispatch tmp2643 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp2643 (quote (any . any)))))) ($sc-dispatch tmp2643 (quote (any any . any)))))) ($sc-dispatch tmp2643 (quote (any any))))) e2633))))) (lambda (e2691 r2692 w2693 s2694 mod2695) (let ((e2696 (source-wrap1820 e2691 w2693 s2694 mod2695))) ((lambda (tmp2697) ((lambda (tmp2698) (if tmp2698 (apply (lambda (_2699 x2700) (call-with-values (lambda () (gen-syntax2597 e2696 x2700 r2692 (quote ()) ellipsis?1836 mod2695)) (lambda (e2701 maps2702) (regen2604 e2701)))) tmp2698) ((lambda (_2703) (syntax-violation (quote syntax) (quote "bad `syntax' form") e2696)) tmp2697))) ($sc-dispatch tmp2697 (quote (any any))))) e2696))))) (global-extend1789 (quote core) (quote lambda) (lambda (e2704 r2705 w2706 s2707 mod2708) ((lambda (tmp2709) ((lambda (tmp2710) (if tmp2710 (apply (lambda (_2711 c2712) (chi-lambda-clause1832 (source-wrap1820 e2704 w2706 s2707 mod2708) (quote #f) c2712 r2705 w2706 mod2708 (lambda (vars2713 docstring2714 body2715) (build-lambda1767 s2707 vars2713 docstring2714 body2715)))) tmp2710) (syntax-violation #f "source expression failed to match any pattern" tmp2709))) ($sc-dispatch tmp2709 (quote (any . any))))) e2704))) (global-extend1789 (quote core) (quote let) (letrec ((chi-let2716 (lambda (e2717 r2718 w2719 s2720 mod2721 constructor2722 ids2723 vals2724 exps2725) (if (not (valid-bound-ids?1816 ids2723)) (syntax-violation (quote let) (quote "duplicate bound variable") e2717) (let ((labels2726 (gen-labels1797 ids2723)) (new-vars2727 (map gen-var1839 ids2723))) (let ((nw2728 (make-binding-wrap1808 ids2723 labels2726 w2719)) (nr2729 (extend-var-env1786 labels2726 new-vars2727 r2718))) (constructor2722 s2720 new-vars2727 (map (lambda (x2730) (chi1827 x2730 r2718 w2719 mod2721)) vals2724) (chi-body1831 exps2725 (source-wrap1820 e2717 nw2728 s2720 mod2721) nr2729 nw2728 mod2721)))))))) (lambda (e2731 r2732 w2733 s2734 mod2735) ((lambda (tmp2736) ((lambda (tmp2737) (if tmp2737 (apply (lambda (_2738 id2739 val2740 e12741 e22742) (chi-let2716 e2731 r2732 w2733 s2734 mod2735 build-let1771 id2739 val2740 (cons e12741 e22742))) tmp2737) ((lambda (tmp2746) (if (if tmp2746 (apply (lambda (_2747 f2748 id2749 val2750 e12751 e22752) (id?1791 f2748)) tmp2746) (quote #f)) (apply (lambda (_2753 f2754 id2755 val2756 e12757 e22758) (chi-let2716 e2731 r2732 w2733 s2734 mod2735 build-named-let1772 (cons f2754 id2755) val2756 (cons e12757 e22758))) tmp2746) ((lambda (_2762) (syntax-violation (quote let) (quote "bad let") (source-wrap1820 e2731 w2733 s2734 mod2735))) tmp2736))) ($sc-dispatch tmp2736 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2736 (quote (any #(each (any any)) any . each-any))))) e2731)))) (global-extend1789 (quote core) (quote letrec) (lambda (e2763 r2764 w2765 s2766 mod2767) ((lambda (tmp2768) ((lambda (tmp2769) (if tmp2769 (apply (lambda (_2770 id2771 val2772 e12773 e22774) (let ((ids2775 id2771)) (if (not (valid-bound-ids?1816 ids2775)) (syntax-violation (quote letrec) (quote "duplicate bound variable") e2763) (let ((labels2777 (gen-labels1797 ids2775)) (new-vars2778 (map gen-var1839 ids2775))) (let ((w2779 (make-binding-wrap1808 ids2775 labels2777 w2765)) (r2780 (extend-var-env1786 labels2777 new-vars2778 r2764))) (build-letrec1773 s2766 new-vars2778 (map (lambda (x2781) (chi1827 x2781 r2780 w2779 mod2767)) val2772) (chi-body1831 (cons e12773 e22774) (source-wrap1820 e2763 w2779 s2766 mod2767) r2780 w2779 mod2767))))))) tmp2769) ((lambda (_2784) (syntax-violation (quote letrec) (quote "bad letrec") (source-wrap1820 e2763 w2765 s2766 mod2767))) tmp2768))) ($sc-dispatch tmp2768 (quote (any #(each (any any)) any . each-any))))) e2763))) (global-extend1789 (quote core) (quote set!) (lambda (e2785 r2786 w2787 s2788 mod2789) ((lambda (tmp2790) ((lambda (tmp2791) (if (if tmp2791 (apply (lambda (_2792 id2793 val2794) (id?1791 id2793)) tmp2791) (quote #f)) (apply (lambda (_2795 id2796 val2797) (let ((val2798 (chi1827 val2797 r2786 w2787 mod2789)) (n2799 (id-var-name1813 id2796 w2787))) (let ((b2800 (lookup1788 n2799 r2786 mod2789))) (let ((t2801 (binding-type1783 b2800))) (if (memv t2801 (quote (lexical))) (build-lexical-assignment1762 s2788 (syntax->datum id2796) (binding-value1784 b2800) val2798) (if (memv t2801 (quote (global))) (build-global-assignment1765 s2788 n2799 val2798 mod2789) (if (memv t2801 (quote (displaced-lexical))) (syntax-violation (quote set!) (quote "identifier out of context") (wrap1819 id2796 w2787 mod2789)) (syntax-violation (quote set!) (quote "bad set!") (source-wrap1820 e2785 w2787 s2788 mod2789))))))))) tmp2791) ((lambda (tmp2802) (if tmp2802 (apply (lambda (_2803 head2804 tail2805 val2806) (call-with-values (lambda () (syntax-type1825 head2804 r2786 (quote (())) (quote #f) (quote #f) mod2789)) (lambda (type2807 value2808 ee2809 ww2810 ss2811 modmod2812) (let ((t2813 type2807)) (if (memv t2813 (quote (module-ref))) (let ((val2814 (chi1827 val2806 r2786 w2787 mod2789))) (call-with-values (lambda () (value2808 (cons head2804 tail2805))) (lambda (id2816 mod2817) (build-global-assignment1765 s2788 id2816 val2814 mod2817)))) (build-application1759 s2788 (chi1827 (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))) head2804) r2786 w2787 mod2789) (map (lambda (e2818) (chi1827 e2818 r2786 w2787 mod2789)) (append tail2805 (list val2806))))))))) tmp2802) ((lambda (_2820) (syntax-violation (quote set!) (quote "bad set!") (source-wrap1820 e2785 w2787 s2788 mod2789))) tmp2790))) ($sc-dispatch tmp2790 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp2790 (quote (any any any))))) e2785))) (global-extend1789 (quote module-ref) (quote @) (lambda (e2821) ((lambda (tmp2822) ((lambda (tmp2823) (if (if tmp2823 (apply (lambda (_2824 mod2825 id2826) (and (and-map id?1791 mod2825) (id?1791 id2826))) tmp2823) (quote #f)) (apply (lambda (_2828 mod2829 id2830) (values (syntax->datum id2830) (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))) mod2829)))) tmp2823) (syntax-violation #f "source expression failed to match any pattern" tmp2822))) ($sc-dispatch tmp2822 (quote (any each-any any))))) e2821))) (global-extend1789 (quote module-ref) (quote @@) (lambda (e2832) ((lambda (tmp2833) ((lambda (tmp2834) (if (if tmp2834 (apply (lambda (_2835 mod2836 id2837) (and (and-map id?1791 mod2836) (id?1791 id2837))) tmp2834) (quote #f)) (apply (lambda (_2839 mod2840 id2841) (values (syntax->datum id2841) (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))) mod2840)))) tmp2834) (syntax-violation #f "source expression failed to match any pattern" tmp2833))) ($sc-dispatch tmp2833 (quote (any each-any any))))) e2832))) (global-extend1789 (quote begin) (quote begin) (quote ())) (global-extend1789 (quote define) (quote define) (quote ())) (global-extend1789 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend1789 (quote eval-when) (quote eval-when) (quote ())) (global-extend1789 (quote core) (quote syntax-case) (letrec ((gen-syntax-case2846 (lambda (x2847 keys2848 clauses2849 r2850 mod2851) (if (null? clauses2849) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote syntax-violation)) (list (quote #f) (quote "source expression failed to match any pattern") x2847)) ((lambda (tmp2852) ((lambda (tmp2853) (if tmp2853 (apply (lambda (pat2854 exp2855) (if (and (id?1791 pat2854) (and-map (lambda (x2856) (not (free-id=?1814 pat2854 x2856))) (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))) keys2848))) (let ((labels2857 (list (gen-label1796))) (var2858 (gen-var1839 pat2854))) (build-application1759 (quote #f) (build-lambda1767 (quote #f) (list var2858) (quote #f) (chi1827 exp2855 (extend-env1785 labels2857 (list (cons (quote syntax) (cons var2858 (quote 0)))) r2850) (make-binding-wrap1808 (list pat2854) labels2857 (quote (()))) mod2851)) (list x2847))) (gen-clause2845 x2847 keys2848 (cdr clauses2849) r2850 pat2854 (quote #t) exp2855 mod2851))) tmp2853) ((lambda (tmp2859) (if tmp2859 (apply (lambda (pat2860 fender2861 exp2862) (gen-clause2845 x2847 keys2848 (cdr clauses2849) r2850 pat2860 fender2861 exp2862 mod2851)) tmp2859) ((lambda (_2863) (syntax-violation (quote syntax-case) (quote "invalid clause") (car clauses2849))) tmp2852))) ($sc-dispatch tmp2852 (quote (any any any)))))) ($sc-dispatch tmp2852 (quote (any any))))) (car clauses2849))))) (gen-clause2845 (lambda (x2864 keys2865 clauses2866 r2867 pat2868 fender2869 exp2870 mod2871) (call-with-values (lambda () (convert-pattern2843 pat2868 keys2865)) (lambda (p2872 pvars2873) (cond ((not (distinct-bound-ids?1817 (map car pvars2873))) (syntax-violation (quote syntax-case) (quote "duplicate pattern variable") pat2868)) ((not (and-map (lambda (x2874) (not (ellipsis?1836 (car x2874)))) pvars2873)) (syntax-violation (quote syntax-case) (quote "misplaced ellipsis") pat2868)) (else (let ((y2875 (gen-var1839 (quote tmp)))) (build-application1759 (quote #f) (build-lambda1767 (quote #f) (list y2875) (quote #f) (let ((y2876 (build-lexical-reference1761 (quote value) (quote #f) (quote tmp) y2875))) (build-conditional1760 (quote #f) ((lambda (tmp2877) ((lambda (tmp2878) (if tmp2878 (apply (lambda () y2876) tmp2878) ((lambda (_2879) (build-conditional1760 (quote #f) y2876 (build-dispatch-call2844 pvars2873 fender2869 y2876 r2867 mod2871) (build-data1769 (quote #f) (quote #f)))) tmp2877))) ($sc-dispatch tmp2877 (quote #(atom #t))))) fender2869) (build-dispatch-call2844 pvars2873 exp2870 y2876 r2867 mod2871) (gen-syntax-case2846 x2864 keys2865 clauses2866 r2867 mod2871)))) (list (if (eq? p2872 (quote any)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote list)) (list x2864)) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote $sc-dispatch)) (list x2864 (build-data1769 (quote #f) p2872))))))))))))) (build-dispatch-call2844 (lambda (pvars2880 exp2881 y2882 r2883 mod2884) (let ((ids2885 (map car pvars2880)) (levels2886 (map cdr pvars2880))) (let ((labels2887 (gen-labels1797 ids2885)) (new-vars2888 (map gen-var1839 ids2885))) (build-application1759 (quote #f) (build-primref1768 (quote #f) (quote apply)) (list (build-lambda1767 (quote #f) new-vars2888 (quote #f) (chi1827 exp2881 (extend-env1785 labels2887 (map (lambda (var2889 level2890) (cons (quote syntax) (cons var2889 level2890))) new-vars2888 (map cdr pvars2880)) r2883) (make-binding-wrap1808 ids2885 labels2887 (quote (()))) mod2884)) y2882)))))) (convert-pattern2843 (lambda (pattern2891 keys2892) (letrec ((cvt2893 (lambda (p2894 n2895 ids2896) (if (id?1791 p2894) (if (bound-id-member?1818 p2894 keys2892) (values (vector (quote free-id) p2894) ids2896) (values (quote any) (cons (cons p2894 n2895) ids2896))) ((lambda (tmp2897) ((lambda (tmp2898) (if (if tmp2898 (apply (lambda (x2899 dots2900) (ellipsis?1836 dots2900)) tmp2898) (quote #f)) (apply (lambda (x2901 dots2902) (call-with-values (lambda () (cvt2893 x2901 (fx+1751 n2895 (quote 1)) ids2896)) (lambda (p2903 ids2904) (values (if (eq? p2903 (quote any)) (quote each-any) (vector (quote each) p2903)) ids2904)))) tmp2898) ((lambda (tmp2905) (if tmp2905 (apply (lambda (x2906 y2907) (call-with-values (lambda () (cvt2893 y2907 n2895 ids2896)) (lambda (y2908 ids2909) (call-with-values (lambda () (cvt2893 x2906 n2895 ids2909)) (lambda (x2910 ids2911) (values (cons x2910 y2908) ids2911)))))) tmp2905) ((lambda (tmp2912) (if tmp2912 (apply (lambda () (values (quote ()) ids2896)) tmp2912) ((lambda (tmp2913) (if tmp2913 (apply (lambda (x2914) (call-with-values (lambda () (cvt2893 x2914 n2895 ids2896)) (lambda (p2916 ids2917) (values (vector (quote vector) p2916) ids2917)))) tmp2913) ((lambda (x2918) (values (vector (quote atom) (strip1838 p2894 (quote (())))) ids2896)) tmp2897))) ($sc-dispatch tmp2897 (quote #(vector each-any)))))) ($sc-dispatch tmp2897 (quote ()))))) ($sc-dispatch tmp2897 (quote (any . any)))))) ($sc-dispatch tmp2897 (quote (any any))))) p2894))))) (cvt2893 pattern2891 (quote 0) (quote ())))))) (lambda (e2919 r2920 w2921 s2922 mod2923) (let ((e2924 (source-wrap1820 e2919 w2921 s2922 mod2923))) ((lambda (tmp2925) ((lambda (tmp2926) (if tmp2926 (apply (lambda (_2927 val2928 key2929 m2930) (if (and-map (lambda (x2931) (and (id?1791 x2931) (not (ellipsis?1836 x2931)))) key2929) (let ((x2933 (gen-var1839 (quote tmp)))) (build-application1759 s2922 (build-lambda1767 (quote #f) (list x2933) (quote #f) (gen-syntax-case2846 (build-lexical-reference1761 (quote value) (quote #f) (quote tmp) x2933) key2929 m2930 r2920 mod2923)) (list (chi1827 val2928 r2920 (quote (())) mod2923)))) (syntax-violation (quote syntax-case) (quote "invalid literals list") e2924))) tmp2926) (syntax-violation #f "source expression failed to match any pattern" tmp2925))) ($sc-dispatch tmp2925 (quote (any any each-any . each-any))))) e2924))))) (set! sc-expand (lambda (x2937 . rest2936) (if (and (pair? x2937) (equal? (car x2937) noexpand1749)) (cadr x2937) (let ((m2938 (if (null? rest2936) (quote e) (car rest2936))) (esew2939 (if (or (null? rest2936) (null? (cdr rest2936))) (quote (eval)) (cadr rest2936)))) (with-fluid* *mode*1750 m2938 (lambda () (chi-top1826 x2937 (quote ()) (quote ((top))) m2938 esew2939 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x2940) (nonsymbol-id?1790 x2940))) (set! datum->syntax (lambda (id2941 datum2942) (make-syntax-object1774 datum2942 (syntax-object-wrap1777 id2941) (quote #f)))) (set! syntax->datum (lambda (x2943) (strip1838 x2943 (quote (()))))) (set! generate-temporaries (lambda (ls2944) (begin (let ((x2945 ls2944)) (if (not (list? x2945)) (syntax-violation (quote generate-temporaries) (quote "invalid argument") x2945))) (map (lambda (x2946) (wrap1819 (gensym) (quote ((top))) (quote #f))) ls2944)))) (set! free-identifier=? (lambda (x2947 y2948) (begin (let ((x2949 x2947)) (if (not (nonsymbol-id?1790 x2949)) (syntax-violation (quote free-identifier=?) (quote "invalid argument") x2949))) (let ((x2950 y2948)) (if (not (nonsymbol-id?1790 x2950)) (syntax-violation (quote free-identifier=?) (quote "invalid argument") x2950))) (free-id=?1814 x2947 y2948)))) (set! bound-identifier=? (lambda (x2951 y2952) (begin (let ((x2953 x2951)) (if (not (nonsymbol-id?1790 x2953)) (syntax-violation (quote bound-identifier=?) (quote "invalid argument") x2953))) (let ((x2954 y2952)) (if (not (nonsymbol-id?1790 x2954)) (syntax-violation (quote bound-identifier=?) (quote "invalid argument") x2954))) (bound-id=?1815 x2951 y2952)))) (set! syntax-violation (lambda (who2958 message2957 form2956 . subform2955) (begin (let ((x2959 who2958)) (if (not ((lambda (x2960) (or (not x2960) (string? x2960) (symbol? x2960))) x2959)) (syntax-violation (quote syntax-violation) (quote "invalid argument") x2959))) (let ((x2961 message2957)) (if (not (string? x2961)) (syntax-violation (quote syntax-violation) (quote "invalid argument") x2961))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who2958 (quote "~a: ") (quote "")) (quote "~a ") (if (null? subform2955) (quote "in ~a") (quote "in subform `~s' of `~s'"))) (let ((tail2962 (cons message2957 (map (lambda (x2963) (strip1838 x2963 (quote (())))) (append subform2955 (list form2956)))))) (if who2958 (cons who2958 tail2962) tail2962)) (quote #f))))) (letrec ((match2968 (lambda (e2969 p2970 w2971 r2972 mod2973) (cond ((not r2972) (quote #f)) ((eq? p2970 (quote any)) (cons (wrap1819 e2969 w2971 mod2973) r2972)) ((syntax-object?1775 e2969) (match*2967 (let ((e2974 (syntax-object-expression1776 e2969))) (if (annotation? e2974) (annotation-expression e2974) e2974)) p2970 (join-wraps1810 w2971 (syntax-object-wrap1777 e2969)) r2972 (syntax-object-module1778 e2969))) (else (match*2967 (let ((e2975 e2969)) (if (annotation? e2975) (annotation-expression e2975) e2975)) p2970 w2971 r2972 mod2973))))) (match*2967 (lambda (e2976 p2977 w2978 r2979 mod2980) (cond ((null? p2977) (and (null? e2976) r2979)) ((pair? p2977) (and (pair? e2976) (match2968 (car e2976) (car p2977) w2978 (match2968 (cdr e2976) (cdr p2977) w2978 r2979 mod2980) mod2980))) ((eq? p2977 (quote each-any)) (let ((l2981 (match-each-any2965 e2976 w2978 mod2980))) (and l2981 (cons l2981 r2979)))) (else (let ((t2982 (vector-ref p2977 (quote 0)))) (if (memv t2982 (quote (each))) (if (null? e2976) (match-empty2966 (vector-ref p2977 (quote 1)) r2979) (let ((l2983 (match-each2964 e2976 (vector-ref p2977 (quote 1)) w2978 mod2980))) (and l2983 (letrec ((collect2984 (lambda (l2985) (if (null? (car l2985)) r2979 (cons (map car l2985) (collect2984 (map cdr l2985))))))) (collect2984 l2983))))) (if (memv t2982 (quote (free-id))) (and (id?1791 e2976) (free-id=?1814 (wrap1819 e2976 w2978 mod2980) (vector-ref p2977 (quote 1))) r2979) (if (memv t2982 (quote (atom))) (and (equal? (vector-ref p2977 (quote 1)) (strip1838 e2976 w2978)) r2979) (if (memv t2982 (quote (vector))) (and (vector? e2976) (match2968 (vector->list e2976) (vector-ref p2977 (quote 1)) w2978 r2979 mod2980))))))))))) (match-empty2966 (lambda (p2986 r2987) (cond ((null? p2986) r2987) ((eq? p2986 (quote any)) (cons (quote ()) r2987)) ((pair? p2986) (match-empty2966 (car p2986) (match-empty2966 (cdr p2986) r2987))) ((eq? p2986 (quote each-any)) (cons (quote ()) r2987)) (else (let ((t2988 (vector-ref p2986 (quote 0)))) (if (memv t2988 (quote (each))) (match-empty2966 (vector-ref p2986 (quote 1)) r2987) (if (memv t2988 (quote (free-id atom))) r2987 (if (memv t2988 (quote (vector))) (match-empty2966 (vector-ref p2986 (quote 1)) r2987))))))))) (match-each-any2965 (lambda (e2989 w2990 mod2991) (cond ((annotation? e2989) (match-each-any2965 (annotation-expression e2989) w2990 mod2991)) ((pair? e2989) (let ((l2992 (match-each-any2965 (cdr e2989) w2990 mod2991))) (and l2992 (cons (wrap1819 (car e2989) w2990 mod2991) l2992)))) ((null? e2989) (quote ())) ((syntax-object?1775 e2989) (match-each-any2965 (syntax-object-expression1776 e2989) (join-wraps1810 w2990 (syntax-object-wrap1777 e2989)) mod2991)) (else (quote #f))))) (match-each2964 (lambda (e2993 p2994 w2995 mod2996) (cond ((annotation? e2993) (match-each2964 (annotation-expression e2993) p2994 w2995 mod2996)) ((pair? e2993) (let ((first2997 (match2968 (car e2993) p2994 w2995 (quote ()) mod2996))) (and first2997 (let ((rest2998 (match-each2964 (cdr e2993) p2994 w2995 mod2996))) (and rest2998 (cons first2997 rest2998)))))) ((null? e2993) (quote ())) ((syntax-object?1775 e2993) (match-each2964 (syntax-object-expression1776 e2993) p2994 (join-wraps1810 w2995 (syntax-object-wrap1777 e2993)) (syntax-object-module1778 e2993))) (else (quote #f)))))) (set! $sc-dispatch (lambda (e2999 p3000) (cond ((eq? p3000 (quote any)) (list e2999)) ((syntax-object?1775 e2999) (match*2967 (let ((e3001 (syntax-object-expression1776 e2999))) (if (annotation? e3001) (annotation-expression e3001) e3001)) p3000 (syntax-object-wrap1777 e2999) (quote ()) (syntax-object-module1778 e2999))) (else (match*2967 (let ((e3002 e2999)) (if (annotation? e3002) (annotation-expression e3002) e3002)) p3000 (quote (())) (quote ()) (quote #f))))))))))
+(define with-syntax (make-syncase-macro (quote macro) (lambda (x3003) ((lambda (tmp3004) ((lambda (tmp3005) (if tmp3005 (apply (lambda (_3006 e13007 e23008) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e13007 e23008))) tmp3005) ((lambda (tmp3010) (if tmp3010 (apply (lambda (_3011 out3012 in3013 e13014 e23015) (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))) in3013 (quote ()) (list out3012 (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 e13014 e23015))))) tmp3010) ((lambda (tmp3017) (if tmp3017 (apply (lambda (_3018 out3019 in3020 e13021 e23022) (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))) in3020) (quote ()) (list out3019 (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 e13021 e23022))))) tmp3017) (syntax-violation #f "source expression failed to match any pattern" tmp3004))) ($sc-dispatch tmp3004 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp3004 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp3004 (quote (any () any . each-any))))) x3003))))
+(define syntax-rules (make-syncase-macro (quote macro) (lambda (x3026) ((lambda (tmp3027) ((lambda (tmp3028) (if tmp3028 (apply (lambda (_3029 k3030 keyword3031 pattern3032 template3033) (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 k3030 (map (lambda (tmp3036 tmp3035) (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))) tmp3035) (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))) tmp3036))) template3033 pattern3032)))))) tmp3028) (syntax-violation #f "source expression failed to match any pattern" tmp3027))) ($sc-dispatch tmp3027 (quote (any each-any . #(each ((any . any) any))))))) x3026))))
+(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x3037) ((lambda (tmp3038) ((lambda (tmp3039) (if (if tmp3039 (apply (lambda (let*3040 x3041 v3042 e13043 e23044) (and-map identifier? x3041)) tmp3039) (quote #f)) (apply (lambda (let*3046 x3047 v3048 e13049 e23050) (letrec ((f3051 (lambda (bindings3052) (if (null? bindings3052) (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 e13049 e23050))) ((lambda (tmp3056) ((lambda (tmp3057) (if tmp3057 (apply (lambda (body3058 binding3059) (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 binding3059) body3058)) tmp3057) (syntax-violation #f "source expression failed to match any pattern" tmp3056))) ($sc-dispatch tmp3056 (quote (any any))))) (list (f3051 (cdr bindings3052)) (car bindings3052))))))) (f3051 (map list x3047 v3048)))) tmp3039) (syntax-violation #f "source expression failed to match any pattern" tmp3038))) ($sc-dispatch tmp3038 (quote (any #(each (any any)) any . each-any))))) x3037))))
+(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x3060) ((lambda (tmp3061) ((lambda (tmp3062) (if tmp3062 (apply (lambda (_3063 var3064 init3065 step3066 e03067 e13068 c3069) ((lambda (tmp3070) ((lambda (tmp3071) (if tmp3071 (apply (lambda (step3072) ((lambda (tmp3073) ((lambda (tmp3074) (if tmp3074 (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 var3064 init3065) (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))) e03067) (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 c3069 (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))) step3072))))))) tmp3074) ((lambda (tmp3079) (if tmp3079 (apply (lambda (e13080 e23081) (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 var3064 init3065) (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))) e03067 (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 e13080 e23081)) (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 c3069 (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))) step3072))))))) tmp3079) (syntax-violation #f "source expression failed to match any pattern" tmp3073))) ($sc-dispatch tmp3073 (quote (any . each-any)))))) ($sc-dispatch tmp3073 (quote ())))) e13068)) tmp3071) (syntax-violation #f "source expression failed to match any pattern" tmp3070))) ($sc-dispatch tmp3070 (quote each-any)))) (map (lambda (v3088 s3089) ((lambda (tmp3090) ((lambda (tmp3091) (if tmp3091 (apply (lambda () v3088) tmp3091) ((lambda (tmp3092) (if tmp3092 (apply (lambda (e3093) e3093) tmp3092) ((lambda (_3094) (syntax-violation (quote do) (quote "bad step expression") orig-x3060 s3089)) tmp3090))) ($sc-dispatch tmp3090 (quote (any)))))) ($sc-dispatch tmp3090 (quote ())))) s3089)) var3064 step3066))) tmp3062) (syntax-violation #f "source expression failed to match any pattern" tmp3061))) ($sc-dispatch tmp3061 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x3060))))
+(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons3097 (lambda (x3101 y3102) ((lambda (tmp3103) ((lambda (tmp3104) (if tmp3104 (apply (lambda (x3105 y3106) ((lambda (tmp3107) ((lambda (tmp3108) (if tmp3108 (apply (lambda (dy3109) ((lambda (tmp3110) ((lambda (tmp3111) (if tmp3111 (apply (lambda (dx3112) (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 dx3112 dy3109))) tmp3111) ((lambda (_3113) (if (null? dy3109) (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))) x3105) (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))) x3105 y3106))) tmp3110))) ($sc-dispatch tmp3110 (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))))) x3105)) tmp3108) ((lambda (tmp3114) (if tmp3114 (apply (lambda (stuff3115) (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 x3105 stuff3115))) tmp3114) ((lambda (else3116) (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))) x3105 y3106)) tmp3107))) ($sc-dispatch tmp3107 (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 tmp3107 (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))))) y3106)) tmp3104) (syntax-violation #f "source expression failed to match any pattern" tmp3103))) ($sc-dispatch tmp3103 (quote (any any))))) (list x3101 y3102)))) (quasiappend3098 (lambda (x3117 y3118) ((lambda (tmp3119) ((lambda (tmp3120) (if tmp3120 (apply (lambda (x3121 y3122) ((lambda (tmp3123) ((lambda (tmp3124) (if tmp3124 (apply (lambda () x3121) tmp3124) ((lambda (_3125) (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))) x3121 y3122)) tmp3123))) ($sc-dispatch tmp3123 (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))) ()))))) y3122)) tmp3120) (syntax-violation #f "source expression failed to match any pattern" tmp3119))) ($sc-dispatch tmp3119 (quote (any any))))) (list x3117 y3118)))) (quasivector3099 (lambda (x3126) ((lambda (tmp3127) ((lambda (x3128) ((lambda (tmp3129) ((lambda (tmp3130) (if tmp3130 (apply (lambda (x3131) (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 x3131))) tmp3130) ((lambda (tmp3133) (if tmp3133 (apply (lambda (x3134) (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))) x3134)) tmp3133) ((lambda (_3136) (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))) x3128)) tmp3129))) ($sc-dispatch tmp3129 (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 tmp3129 (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))))) x3128)) tmp3127)) x3126))) (quasi3100 (lambda (p3137 lev3138) ((lambda (tmp3139) ((lambda (tmp3140) (if tmp3140 (apply (lambda (p3141) (if (= lev3138 (quote 0)) p3141 (quasicons3097 (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)))) (quasi3100 (list p3141) (- lev3138 (quote 1)))))) tmp3140) ((lambda (tmp3142) (if tmp3142 (apply (lambda (p3143 q3144) (if (= lev3138 (quote 0)) (quasiappend3098 p3143 (quasi3100 q3144 lev3138)) (quasicons3097 (quasicons3097 (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)))) (quasi3100 (list p3143) (- lev3138 (quote 1)))) (quasi3100 q3144 lev3138)))) tmp3142) ((lambda (tmp3145) (if tmp3145 (apply (lambda (p3146) (quasicons3097 (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)))) (quasi3100 (list p3146) (+ lev3138 (quote 1))))) tmp3145) ((lambda (tmp3147) (if tmp3147 (apply (lambda (p3148 q3149) (quasicons3097 (quasi3100 p3148 lev3138) (quasi3100 q3149 lev3138))) tmp3147) ((lambda (tmp3150) (if tmp3150 (apply (lambda (x3151) (quasivector3099 (quasi3100 x3151 lev3138))) tmp3150) ((lambda (p3153) (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))) p3153)) tmp3139))) ($sc-dispatch tmp3139 (quote #(vector each-any)))))) ($sc-dispatch tmp3139 (quote (any . any)))))) ($sc-dispatch tmp3139 (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 tmp3139 (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 tmp3139 (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))))) p3137)))) (lambda (x3154) ((lambda (tmp3155) ((lambda (tmp3156) (if tmp3156 (apply (lambda (_3157 e3158) (quasi3100 e3158 (quote 0))) tmp3156) (syntax-violation #f "source expression failed to match any pattern" tmp3155))) ($sc-dispatch tmp3155 (quote (any any))))) x3154)))))
+(define include (make-syncase-macro (quote macro) (lambda (x3159) (letrec ((read-file3160 (lambda (fn3161 k3162) (let ((p3163 (open-input-file fn3161))) (letrec ((f3164 (lambda (x3165) (if (eof-object? x3165) (begin (close-input-port p3163) (quote ())) (cons (datum->syntax k3162 x3165) (f3164 (read p3163))))))) (f3164 (read p3163))))))) ((lambda (tmp3166) ((lambda (tmp3167) (if tmp3167 (apply (lambda (k3168 filename3169) (let ((fn3170 (syntax->datum filename3169))) ((lambda (tmp3171) ((lambda (tmp3172) (if tmp3172 (apply (lambda (exp3173) (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))) exp3173)) tmp3172) (syntax-violation #f "source expression failed to match any pattern" tmp3171))) ($sc-dispatch tmp3171 (quote each-any)))) (read-file3160 fn3170 k3168)))) tmp3167) (syntax-violation #f "source expression failed to match any pattern" tmp3166))) ($sc-dispatch tmp3166 (quote (any any))))) x3159)))))
+(define unquote (make-syncase-macro (quote macro) (lambda (x3175) ((lambda (tmp3176) ((lambda (tmp3177) (if tmp3177 (apply (lambda (_3178 e3179) (syntax-violation (quote unquote) (quote "expression not valid outside of quasiquote") x3175)) tmp3177) (syntax-violation #f "source expression failed to match any pattern" tmp3176))) ($sc-dispatch tmp3176 (quote (any any))))) x3175))))
+(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x3180) ((lambda (tmp3181) ((lambda (tmp3182) (if tmp3182 (apply (lambda (_3183 e3184) (syntax-violation (quote unquote-splicing) (quote "expression not valid outside of quasiquote") x3180)) tmp3182) (syntax-violation #f "source expression failed to match any pattern" tmp3181))) ($sc-dispatch tmp3181 (quote (any any))))) x3180))))
+(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x3185) ((lambda (tmp3186) ((lambda (tmp3187) (if tmp3187 (apply (lambda (_3188 e3189 m13190 m23191) ((lambda (tmp3192) ((lambda (body3193) (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))) e3189)) body3193)) tmp3192)) (letrec ((f3194 (lambda (clause3195 clauses3196) (if (null? clauses3196) ((lambda (tmp3198) ((lambda (tmp3199) (if tmp3199 (apply (lambda (e13200 e23201) (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 e13200 e23201))) tmp3199) ((lambda (tmp3203) (if tmp3203 (apply (lambda (k3204 e13205 e23206) (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))) k3204)) (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 e13205 e23206)))) tmp3203) ((lambda (_3209) (syntax-violation (quote case) (quote "bad clause") x3185 clause3195)) tmp3198))) ($sc-dispatch tmp3198 (quote (each-any any . each-any)))))) ($sc-dispatch tmp3198 (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))))) clause3195) ((lambda (tmp3210) ((lambda (rest3211) ((lambda (tmp3212) ((lambda (tmp3213) (if tmp3213 (apply (lambda (k3214 e13215 e23216) (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))) k3214)) (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 e13215 e23216)) rest3211)) tmp3213) ((lambda (_3219) (syntax-violation (quote case) (quote "bad clause") x3185 clause3195)) tmp3212))) ($sc-dispatch tmp3212 (quote (each-any any . each-any))))) clause3195)) tmp3210)) (f3194 (car clauses3196) (cdr clauses3196))))))) (f3194 m13190 m23191)))) tmp3187) (syntax-violation #f "source expression failed to match any pattern" tmp3186))) ($sc-dispatch tmp3186 (quote (any any any . each-any))))) x3185))))
+(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x3220) ((lambda (tmp3221) ((lambda (tmp3222) (if tmp3222 (apply (lambda (_3223 e3224) (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))) e3224)) (list (cons _3223 (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 e3224 (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)))))))))) tmp3222) (syntax-violation #f "source expression failed to match any pattern" tmp3221))) ($sc-dispatch tmp3221 (quote (any any))))) x3220))))
(primitive-eval
`(,noexpand
,(case (fluid-ref *mode*)
- ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x))
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
(else x))))))
(define local-eval-hook
(primitive-eval
`(,noexpand
,(case (fluid-ref *mode*)
- ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x))
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
(else x))))))
(define-syntax gensym-hook
;;; output constructors
-(define (build-annotated src exp)
- (if (and src (not (annotation? exp)))
- (make-annotation exp src #t)
- exp))
-
-(define-syntax build-application
- (syntax-rules ()
- ((_ source fun-exp arg-exps)
- (build-annotated source `(,fun-exp . ,arg-exps)))))
-
-(define-syntax build-conditional
- (syntax-rules ()
- ((_ source test-exp then-exp else-exp)
- (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
+(define build-application
+ (lambda (source fun-exp arg-exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
+ (else `(,fun-exp . ,arg-exps)))))
+
+(define build-conditional
+ (lambda (source test-exp then-exp else-exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-conditional)
+ source test-exp then-exp else-exp))
+ (else `(if ,test-exp ,then-exp ,else-exp)))))
(define build-lexical-reference
(lambda (type source name var)
- (build-annotated
- source
- (case (fluid-ref *mode*)
- ((c) ((@ (ice-9 expand-support) make-lexical) source name var))
- (else var)))))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-ref) source name var))
+ (else var))))
(define build-lexical-assignment
(lambda (source name var exp)
- (build-annotated
- source
- `(set! ,(build-lexical-reference 'set no-source name var)
- ,exp))))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
+ (else `(set! ,var ,exp)))))
;; Before modules are booted, we can't expand into data structures from
-;; (ice-9 expand-support) -- we need to give the evaluator the
+;; (language tree-il) -- we need to give the evaluator the
;; s-expressions that it understands natively. Actually the real truth
;; of the matter is that the evaluator doesn't understand expand-support
;; structures at all. So until we fix the evaluator, if ever, the
-;; conflation that we should use expand-support iff we are compiling
+;; conflation that we should use tree-il iff we are compiling
;; holds true.
;;
+(define (analyze-variable mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont var)
+ (let ((kind (car mod))
+ (mod (cdr mod)))
+ (case kind
+ ((public) (modref-cont mod var #t))
+ ((private) (if (not (equal? mod (module-name (current-module))))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ ((bare) (bare-cont var))
+ ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
+ (module-variable (resolve-module mod) var))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ (else (syntax-violation #f "bad module kind" var mod))))))
+
(define build-global-reference
(lambda (source var mod)
- (build-annotated
- source
- (if (not mod)
- var
- (let ((make-module-ref
- (case (fluid-ref *mode*)
- ((c) (@ (ice-9 expand-support) make-module-ref))
- (else (lambda (source mod var public?)
- (list (if public? '@ '@@) mod var)))))
- (kind (car mod))
- (mod (cdr mod)))
- (case kind
- ((public) (make-module-ref #f mod var #t))
- ((private) (if (not (equal? mod (module-name (current-module))))
- (make-module-ref #f mod var #f)
- var))
- ((bare) var)
- ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
- (module-variable (resolve-module mod) var))
- (make-module-ref #f mod var #f)
- var))
- (else (syntax-violation #f "bad module kind" var mod))))))))
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
+ (else (list (if public? '@ '@@) mod var))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+ (else var))))))
(define build-global-assignment
(lambda (source var exp mod)
- (let ((ref (build-global-reference source var mod)))
- (build-annotated
- source
- `(set! ,ref ,exp)))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ source var exp)
- (build-annotated source `(define ,var ,exp)))))
-
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ src vars docstring exp)
- (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
- ,exp)))
- ((_ src vars exp)
- (build-annotated src `(lambda ,vars ,exp)))))
-
-;; FIXME: wingo: add modules here somehow?
-(define-syntax build-primref
- (syntax-rules ()
- ((_ src name) (build-annotated src name))
- ((_ src level name) (build-annotated src name))))
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
+ (else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+ (else `(set! ,var ,exp)))))))
+
+(define build-global-definition
+ (lambda (source var exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-define) source var exp))
+ (else `(define ,var ,exp)))))
+
+(define build-lambda
+ (lambda (src vars docstring exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src vars
+ (if docstring `((documentation . ,docstring)) '())
+ exp))
+ (else `(lambda ,vars ,@(if docstring (list docstring) '())
+ ,exp)))))
+
+(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))))))
(define (build-data src exp)
- (if (and (self-evaluating? exp)
- (not (vector? exp)))
- (build-annotated src exp)
- (build-annotated src (list 'quote exp))))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-const) src exp))
+ (else (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))))
(define build-sequence
(lambda (src exps)
(if (null? (cdr exps))
- (build-annotated src (car exps))
- (build-annotated src `(begin ,@exps)))))
+ (car exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-sequence) src exps))
+ (else `(begin ,@exps))))))
(define build-let
(lambda (src vars val-exps body-exp)
(if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-let) src vars val-exps body-exp))
+ (else `(let ,(map list vars val-exps) ,body-exp))))))
(define build-named-let
(lambda (src vars val-exps body-exp)
- (if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src
- `(let ,(car vars)
- ,(map list (cdr vars) val-exps) ,body-exp)))))
+ (let ((f (car vars))
+ (vars (cdr vars)))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-letrec) src
+ (list f) (list (build-lambda src vars #f body-exp))
+ (build-application src (build-lexical-reference 'fun src f f)
+ val-exps)))
+ (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
(define build-letrec
(lambda (src vars val-exps body-exp)
(if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src
- `(letrec ,(map list vars val-exps) ,body-exp)))))
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-letrec) src vars val-exps body-exp))
+ (else `(letrec ,(map list vars val-exps) ,body-exp))))))
-;; FIXME: wingo: use make-lexical
+;; FIXME: wingo: use make-lexical ?
(define-syntax build-lexical-var
(syntax-rules ()
- ((_ src id) (build-annotated src (gensym (symbol->string id))))))
+ ((_ src id) (gensym (symbol->string id)))))
(define-structure (syntax-object expression wrap module))
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
+ ((lambda) (build-lambda no-source (cadr x) #f (regen (caddr x))))
((map) (let ((ls (map regen (cdr x))))
(build-application no-source
- (if (fx= (length ls) 2)
- (build-primref no-source 'map)
- ; really need to do our own checking here
- (build-primref no-source 2 'map)) ; require error check
+ ;; this check used to be here, not sure what for:
+ ;; (if (fx= (length ls) 2)
+ (build-primref no-source 'map)
ls)))
(else (build-application no-source
(build-primref no-source (car x))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
- (list (build-lambda no-source new-vars
+ (list (build-lambda no-source new-vars #f
(chi exp
(extend-env
labels
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
- (build-lambda no-source (list y)
+ (build-lambda no-source (list y) #f
(let ((y (build-lexical-reference 'value no-source
'tmp y)))
(build-conditional no-source
(let ((labels (list (gen-label)))
(var (gen-var (syntax pat))))
(build-application no-source
- (build-lambda no-source (list var)
+ (build-lambda no-source (list var) #f
(chi (syntax exp)
(extend-env labels
(list (make-binding 'syntax `(,var . 0)))
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
- (build-lambda no-source (list x)
+ (build-lambda no-source (list x) #f
(gen-syntax-case (build-lexical-reference 'value no-source
'tmp x)
(syntax (key ...)) (syntax (m ...))
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
- #:use-module (ice-9 expand-support)
+ #:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
- (let ((x (strip-expansion-structures
+ (let ((x (tree-il->scheme
(sc-expand x 'c '(compile load eval)))))
(let ((x (make-ghil-lambda env #f vars #f '()
(translate-1 env #f x)))
--- /dev/null
+;;;; 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
+;;;;
+\f
+
+(define-module (language tree-il)
+ #:use-module (system base pmatch)
+ #:use-module (system base syntax)
+ :export (tree-il-loc
+
+ <lexical> make-lexical
+ lexical-name lexical-gensym
+
+ <application> make-application application-loc application-proc application-args
+ <conditional> make-conditional conditional-loc conditional-test conditional-then conditional-else
+ <primitive-ref> make-primitive-ref primitive-ref-loc primitive-ref-name
+ <lexical-ref> make-lexical-ref lexical-ref-loc lexical-ref-name lexical-ref-gensym
+ <lexical-set> make-lexical-set lexical-set-loc lexical-set-name lexical-set-gensym lexical-set-exp
+ <module-ref> make-module-ref module-ref-loc module-ref-mod module-ref-name module-ref-public?
+ <module-set> make-module-set module-set-loc module-set-mod module-set-name module-set-public? module-set-exp
+ <toplevel-ref> make-toplevel-ref toplevel-ref-loc toplevel-ref-name
+ <toplevel-set> make-toplevel-set toplevel-set-loc toplevel-set-name toplevel-set-exp
+ <toplevel-define> make-toplevel-define toplevel-define-loc toplevel-define-name toplevel-define-exp
+ <lambda> make-lambda lambda-loc lambda-vars lambda-meta lambda-body
+ <const> make-const const-loc const-exp
+ <sequence> make-sequence sequence-loc sequence-exps
+ <let> make-let let-loc let-vars let-vals let-exp
+ <letrec> make-letrec letrec-loc letrec-vars letrec-vals letrec-exp
+
+ parse-tree-il
+ unparse-tree-il
+ tree-il->scheme))
+
+(define-type (<tree-il> #:common-slots (src))
+ (<application> proc args)
+ (<conditional> test then else)
+ (<primitive-ref> name)
+ (<lexical-ref> name gensym)
+ (<lexical-set> name gensym exp)
+ (<module-ref> mod name public?)
+ (<module-set> mod name public? exp)
+ (<toplevel-ref> name)
+ (<toplevel-set> name exp)
+ (<toplevel-define> name exp)
+ (<lambda> vars meta body)
+ (<const> exp)
+ (<sequence> exps)
+ (<let> vars vals exp)
+ (<letrec> vars vals exp))
+
+(define <lexical> <lexical-ref>)
+(define lexical? lexical-ref?)
+(define make-lexical make-lexical-ref)
+(define lexical-name lexical-ref-name)
+(define lexical-gensym lexical-ref-gensym)
+
+\f
+
+;; 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))))))
+
+(define (parse-tree-il env exp)
+ (let ((loc (location exp))
+ (retrans (lambda (x) (parse-ghil env x))))
+ (pmatch exp
+ ((apply ,proc ,args)
+ (make-application loc (retrans proc) (retrans args)))
+
+ ((if ,test ,then ,else)
+ (make-conditional loc (retrans test) (retrans then) (retrans else)))
+
+ ((primitive ,name) (guard (symbol? name))
+ (make-primitive-ref loc name))
+
+ ((lexical ,name) (guard (symbol? name))
+ (make-lexical-ref loc name name))
+
+ ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
+ (make-lexical-ref loc name sym))
+
+ ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
+ (make-lexical-set loc name sym (retrans exp)))
+
+ ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-ref loc mod name #t))
+
+ ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-set loc mod name #t (retrans exp)))
+
+ ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-ref loc mod name #f))
+
+ ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-set loc mod name #f (retrans exp)))
+
+ ((toplevel ,name) (guard (symbol? name))
+ (make-toplevel-ref loc name))
+
+ ((set! (toplevel ,name) exp) (guard (symbol? name))
+ (make-toplevel-set loc name (retrans exp)))
+
+ ((define ,name exp) (guard (symbol? name))
+ (make-toplevel-define loc name (retrans exp)))
+
+ ((lambda ,vars ,exp)
+ (make-lambda loc vars '() (retrans exp)))
+
+ ((lambda ,vars ,meta ,exp)
+ (make-lambda loc vars meta (retrans exp)))
+
+ ((const ,exp)
+ (make-const loc exp))
+
+ ((begin . ,exps)
+ (make-sequence loc (map retrans exps)))
+
+ ((let ,vars ,vals ,exp)
+ (make-let loc vars vals (retrans exp)))
+
+ ((letrec ,vars ,vals ,exp)
+ (make-letrec loc vars vals (retrans exp)))
+
+ (else
+ (error "unrecognized tree-il" exp)))))
+
+(define (unparse-tree-il tree-il)
+ (record-case tree-il
+ ((<application> proc args)
+ `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args)))
+
+ ((<conditional> test then else)
+ `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
+
+ ((<primitive-ref> name)
+ `(primitive ,name))
+
+ ((<lexical-ref> name gensym)
+ `(lexical ,name ,gensym))
+
+ ((<lexical-set> name gensym exp)
+ `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
+
+ ((<toplevel-ref> name)
+ `(toplevel ,name))
+
+ ((<toplevel-set> name exp)
+ `(set! (toplevel ,name) ,(unparse-tree-il exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(unparse-tree-il exp)))
+
+ ((<lambda> vars meta body)
+ `(lambda ,vars ,meta ,(unparse-tree-il body)))
+
+ ((<const> exp)
+ `(const ,exp))
+
+ ((<sequence> exps)
+ `(begin ,@(map unparse-tree-il exps)))
+
+ ((<let> vars vals exp)
+ `(let ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
+
+ ((<letrec> vars vals exp)
+ `(letrec ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))))
+
+(define (tree-il->scheme e)
+ (cond ((list? e)
+ (map tree-il->scheme e))
+ ((pair? e)
+ (cons (tree-il->scheme (car e))
+ (tree-il->scheme (cdr e))))
+ ((record? e)
+ (record-case e
+ ((<application> proc args)
+ `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+
+ ((<conditional> test then else)
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))
+
+ ((<primitive-ref> name)
+ name)
+
+ ((<lexical-ref> name gensym)
+ gensym)
+
+ ((<lexical-set> name gensym exp)
+ `(set! ,gensym ,(tree-il->scheme exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
+
+ ((<toplevel-ref> name)
+ name)
+
+ ((<toplevel-set> name exp)
+ `(set! ,name ,(tree-il->scheme exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(tree-il->scheme exp)))
+
+ ((<lambda> vars meta body)
+ `(lambda ,vars
+ ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
+ ,(tree-il->scheme body)))
+
+ ((<const> exp)
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))
+
+ ((<sequence> exps)
+ `(begin ,@(map tree-il->scheme exps)))
+
+ ((<let> vars vals exp)
+ `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))
+
+ ((<letrec> vars vals exp)
+ `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))))
+ (else e)))
--- /dev/null
+;;; TREE-IL -> GLIL compiler
+
+;; 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 program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il compile-glil)
+ #:use-module (system base syntax)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (ice-9 common-list)
+ #:export (compile-glil))
+
+(define (compile-glil x e opts)
+ (if (memq #:O opts) (set! x (optimize x)))
+ (values (codegen x)
+ (and e (cons (car e) (cddr e)))
+ e))
+
+\f
+;;;
+;;; Stage 2: Optimization
+;;;
+
+(define (lift-variables! env)
+ (let ((parent-env (ghil-env-parent env)))
+ (for-each (lambda (v)
+ (case (ghil-var-kind v)
+ ((argument) (set! (ghil-var-kind v) 'local)))
+ (set! (ghil-var-env v) parent-env)
+ (ghil-env-add! parent-env v))
+ (ghil-env-variables env))))
+
+;; The premise of this, unused, approach to optimization is that you can
+;; determine the environment of a variable lexically, because they have
+;; been alpha-renamed. It makes the transformations *much* easier.
+;; Unfortunately it doesn't work yet.
+(define (optimize* x)
+ (transform-record (<ghil> env loc) x
+ ((quasiquote exp)
+ (define (optimize-qq x)
+ (cond ((list? x) (map optimize-qq x))
+ ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
+ ((record? x) (optimize x))
+ (else x)))
+ (-> (quasiquote (optimize-qq x))))
+
+ ((unquote exp)
+ (-> (unquote (optimize exp))))
+
+ ((unquote-splicing exp)
+ (-> (unquote-splicing (optimize exp))))
+
+ ((set var val)
+ (-> (set var (optimize val))))
+
+ ((define var val)
+ (-> (define var (optimize val))))
+
+ ((if test then else)
+ (-> (if (optimize test) (optimize then) (optimize else))))
+
+ ((and exps)
+ (-> (and (map optimize exps))))
+
+ ((or exps)
+ (-> (or (map optimize exps))))
+
+ ((begin exps)
+ (-> (begin (map optimize exps))))
+
+ ((bind vars vals body)
+ (-> (bind vars (map optimize vals) (optimize body))))
+
+ ((mv-bind producer vars rest body)
+ (-> (mv-bind (optimize producer) vars rest (optimize body))))
+
+ ((inline inst args)
+ (-> (inline inst (map optimize args))))
+
+ ((call (proc (lambda vars (rest #f) meta body)) args)
+ (-> (bind vars (optimize args) (optimize body))))
+
+ ((call proc args)
+ (-> (call (optimize proc) (map optimize args))))
+
+ ((lambda vars rest meta body)
+ (-> (lambda vars rest meta (optimize body))))
+
+ ((mv-call producer (consumer (lambda vars rest meta body)))
+ (-> (mv-bind (optimize producer) vars rest (optimize body))))
+
+ ((mv-call producer consumer)
+ (-> (mv-call (optimize producer) (optimize consumer))))
+
+ ((values values)
+ (-> (values (map optimize values))))
+
+ ((values* values)
+ (-> (values* (map optimize values))))
+
+ (else
+ (error "unrecognized GHIL" x))))
+
+(define (optimize x)
+ (record-case x
+ ((<ghil-set> env loc var val)
+ (make-ghil-set env var (optimize val)))
+
+ ((<ghil-define> env loc var val)
+ (make-ghil-define env var (optimize val)))
+
+ ((<ghil-if> env loc test then else)
+ (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
+
+ ((<ghil-and> env loc exps)
+ (make-ghil-and env loc (map optimize exps)))
+
+ ((<ghil-or> env loc exps)
+ (make-ghil-or env loc (map optimize exps)))
+
+ ((<ghil-begin> env loc exps)
+ (make-ghil-begin env loc (map optimize exps)))
+
+ ((<ghil-bind> env loc vars vals body)
+ (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
+
+ ((<ghil-lambda> env loc vars rest meta body)
+ (make-ghil-lambda env loc vars rest meta (optimize body)))
+
+ ((<ghil-inline> env loc instruction args)
+ (make-ghil-inline env loc instruction (map optimize args)))
+
+ ((<ghil-call> env loc proc args)
+ (let ((parent-env env))
+ (record-case proc
+ ;; ((@lambda (VAR...) BODY...) ARG...) =>
+ ;; (@let ((VAR ARG) ...) BODY...)
+ ((<ghil-lambda> env loc vars rest meta body)
+ (cond
+ ((not rest)
+ (lift-variables! env)
+ (make-ghil-bind parent-env loc (map optimize args)))
+ (else
+ (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
+ (else
+ (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
+
+ ((<ghil-mv-call> env loc producer consumer)
+ (record-case consumer
+ ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
+ ;; (mv-let PRODUCER ARGS BODY...)
+ ((<ghil-lambda> env loc vars rest meta body)
+ (lift-variables! env)
+ (make-ghil-mv-bind producer vars rest body))
+ (else
+ (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
+
+ (else x)))
+
+\f
+;;;
+;;; Stage 3: Code generation
+;;;
+
+(define *ia-void* (make-glil-void))
+(define *ia-drop* (make-glil-call 'drop 1))
+(define *ia-return* (make-glil-call 'return 1))
+
+(define (make-label) (gensym ":L"))
+
+(define (make-glil-var op env var)
+ (case (ghil-var-kind var)
+ ((argument)
+ (make-glil-argument op (ghil-var-index var)))
+ ((local)
+ (make-glil-local op (ghil-var-index var)))
+ ((external)
+ (do ((depth 0 (1+ depth))
+ (e env (ghil-env-parent e)))
+ ((eq? e (ghil-var-env var))
+ (make-glil-external op depth (ghil-var-index var)))))
+ ((toplevel)
+ (make-glil-toplevel op (ghil-var-name var)))
+ ((public private)
+ (make-glil-module op (ghil-var-env var) (ghil-var-name var)
+ (eq? (ghil-var-kind var) 'public)))
+ (else (error "Unknown kind of variable:" var))))
+
+(define (constant? x)
+ (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
+ ((pair? x) (and (constant? (car x))
+ (constant? (cdr x))))
+ ((vector? x) (let lp ((i (vector-length x)))
+ (or (zero? i)
+ (and (constant? (vector-ref x (1- i)))
+ (lp (1- i))))))))
+
+(define (codegen ghil)
+ (let ((stack '()))
+ (define (push-code! loc code)
+ (set! stack (cons code stack))
+ (if loc (set! stack (cons (make-glil-source loc) stack))))
+ (define (var->binding var)
+ (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
+ (define (push-bindings! loc vars)
+ (if (not (null? vars))
+ (push-code! loc (make-glil-bind (map var->binding vars)))))
+ (define (comp tree tail drop)
+ (define (push-label! label)
+ (push-code! #f (make-glil-label label)))
+ (define (push-branch! loc inst label)
+ (push-code! loc (make-glil-branch inst label)))
+ (define (push-call! loc inst args)
+ (for-each comp-push args)
+ (push-code! loc (make-glil-call inst (length args))))
+ ;; possible tail position
+ (define (comp-tail tree) (comp tree tail drop))
+ ;; push the result
+ (define (comp-push tree) (comp tree #f #f))
+ ;; drop the result
+ (define (comp-drop tree) (comp tree #f #t))
+ ;; drop the result if unnecessary
+ (define (maybe-drop)
+ (if drop (push-code! #f *ia-drop*)))
+ ;; return here if necessary
+ (define (maybe-return)
+ (if tail (push-code! #f *ia-return*)))
+ ;; return this code if necessary
+ (define (return-code! loc code)
+ (if (not drop) (push-code! loc code))
+ (maybe-return))
+ ;; return void if necessary
+ (define (return-void!)
+ (return-code! #f *ia-void*))
+ ;; return object if necessary
+ (define (return-object! loc obj)
+ (return-code! loc (make-glil-const obj)))
+ ;;
+ ;; dispatch
+ (record-case tree
+ ((<ghil-void>)
+ (return-void!))
+
+ ((<ghil-quote> env loc obj)
+ (return-object! loc obj))
+
+ ((<ghil-quasiquote> env loc exp)
+ (let loop ((x exp) (in-car? #f))
+ (cond
+ ((list? x)
+ (push-call! #f 'mark '())
+ (for-each (lambda (x) (loop x #t)) x)
+ (push-call! #f 'list-mark '()))
+ ((pair? x)
+ (push-call! #f 'mark '())
+ (loop (car x) #t)
+ (loop (cdr x) #f)
+ (push-call! #f 'cons-mark '()))
+ ((record? x)
+ (record-case x
+ ((<ghil-unquote> env loc exp)
+ (comp-push exp))
+ ((<ghil-unquote-splicing> env loc exp)
+ (if (not in-car?)
+ (error "unquote-splicing in the cdr of a pair" exp))
+ (comp-push exp)
+ (push-call! #f 'list-break '()))))
+ ((constant? x)
+ (push-code! #f (make-glil-const x)))
+ (else
+ (error "element of quasiquote can't be compiled" x))))
+ (maybe-drop)
+ (maybe-return))
+
+ ((<ghil-unquote> env loc exp)
+ (error "unquote outside of quasiquote" exp))
+
+ ((<ghil-unquote-splicing> env loc exp)
+ (error "unquote-splicing outside of quasiquote" exp))
+
+ ((<ghil-ref> env loc var)
+ (return-code! loc (make-glil-var 'ref env var)))
+
+ ((<ghil-set> env loc var val)
+ (comp-push val)
+ (push-code! loc (make-glil-var 'set env var))
+ (return-void!))
+
+ ((<ghil-define> env loc var val)
+ (comp-push val)
+ (push-code! loc (make-glil-var 'define env var))
+ (return-void!))
+
+ ((<ghil-if> env loc test then else)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; THEN
+ ;; (br L2)
+ ;; L1: ELSE
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (comp-push test)
+ (push-branch! loc 'br-if-not L1)
+ (comp-tail then)
+ (if (not tail) (push-branch! #f 'br L2))
+ (push-label! L1)
+ (comp-tail else)
+ (if (not tail) (push-label! L2))))
+
+ ((<ghil-and> env loc exps)
+ ;; EXP
+ ;; (br-if-not L1)
+ ;; ...
+ ;; TAIL
+ ;; (br L2)
+ ;; L1: (const #f)
+ ;; L2:
+ (cond ((null? exps) (return-object! loc #t))
+ ((null? (cdr exps)) (comp-tail (car exps)))
+ (else
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (let lp ((exps exps))
+ (cond ((null? (cdr exps))
+ (comp-tail (car exps))
+ (push-branch! #f 'br L2)
+ (push-label! L1)
+ (return-object! #f #f)
+ (push-label! L2)
+ (maybe-return))
+ (else
+ (comp-push (car exps))
+ (push-branch! #f 'br-if-not L1)
+ (lp (cdr exps)))))))))
+
+ ((<ghil-or> env loc exps)
+ ;; EXP
+ ;; (dup)
+ ;; (br-if L1)
+ ;; (drop)
+ ;; ...
+ ;; TAIL
+ ;; L1:
+ (cond ((null? exps) (return-object! loc #f))
+ ((null? (cdr exps)) (comp-tail (car exps)))
+ (else
+ (let ((L1 (make-label)))
+ (let lp ((exps exps))
+ (cond ((null? (cdr exps))
+ (comp-tail (car exps))
+ (push-label! L1)
+ (maybe-return))
+ (else
+ (comp-push (car exps))
+ (if (not drop)
+ (push-call! #f 'dup '()))
+ (push-branch! #f 'br-if L1)
+ (if (not drop)
+ (push-code! loc (make-glil-call 'drop 1)))
+ (lp (cdr exps)))))))))
+
+ ((<ghil-begin> env loc exps)
+ ;; EXPS...
+ ;; TAIL
+ (if (null? exps)
+ (return-void!)
+ (do ((exps exps (cdr exps)))
+ ((null? (cdr exps))
+ (comp-tail (car exps)))
+ (comp-drop (car exps)))))
+
+ ((<ghil-bind> env loc vars vals body)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (for-each comp-push vals)
+ (push-bindings! loc vars)
+ (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
+ (reverse vars))
+ (comp-tail body)
+ (push-code! #f (make-glil-unbind)))
+
+ ((<ghil-mv-bind> env loc producer vars rest body)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (let ((MV (make-label)))
+ (comp-push producer)
+ (push-code! loc (make-glil-mv-call 0 MV))
+ (push-code! #f (make-glil-const 1))
+ (push-label! MV)
+ (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
+ (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
+ (reverse vars)))
+ (comp-tail body)
+ (push-code! #f (make-glil-unbind)))
+
+ ((<ghil-lambda> env loc vars rest meta body)
+ (return-code! loc (codegen tree)))
+
+ ((<ghil-inline> env loc inline args)
+ ;; ARGS...
+ ;; (INST NARGS)
+ (let ((tail-table '((call . goto/args)
+ (apply . goto/apply)
+ (call/cc . goto/cc))))
+ (cond ((and tail (assq-ref tail-table inline))
+ => (lambda (tail-inst)
+ (push-call! loc tail-inst args)))
+ (else
+ (push-call! loc inline args)
+ (maybe-drop)
+ (maybe-return)))))
+
+ ((<ghil-values> env loc values)
+ (cond (tail ;; (lambda () (values 1 2))
+ (push-call! loc 'return/values values))
+ (drop ;; (lambda () (values 1 2) 3)
+ (for-each comp-drop values))
+ (else ;; (lambda () (list (values 10 12) 1))
+ (push-code! #f (make-glil-const 'values))
+ (push-code! #f (make-glil-call 'link-now 1))
+ (push-code! #f (make-glil-call 'variable-ref 0))
+ (push-call! loc 'call values))))
+
+ ((<ghil-values*> env loc values)
+ (cond (tail ;; (lambda () (apply values '(1 2)))
+ (push-call! loc 'return/values* values))
+ (drop ;; (lambda () (apply values '(1 2)) 3)
+ (for-each comp-drop values))
+ (else ;; (lambda () (list (apply values '(10 12)) 1))
+ (push-code! #f (make-glil-const 'values))
+ (push-code! #f (make-glil-call 'link-now 1))
+ (push-code! #f (make-glil-call 'variable-ref 0))
+ (push-call! loc 'apply values))))
+
+ ((<ghil-call> env loc proc args)
+ ;; PROC
+ ;; ARGS...
+ ;; ([tail-]call NARGS)
+ (comp-push proc)
+ (let ((nargs (length args)))
+ (cond ((< nargs 255)
+ (push-call! loc (if tail 'goto/args 'call) args))
+ (else
+ (push-call! loc 'mark '())
+ (for-each comp-push args)
+ (push-call! loc 'list-mark '())
+ (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
+ (maybe-drop))
+
+ ((<ghil-mv-call> env loc producer consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (let ((MV (make-label)) (POST (make-label)))
+ (comp-push consumer)
+ (comp-push producer)
+ (push-code! loc (make-glil-mv-call 0 MV))
+ (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
+ (cond ((not tail)
+ (push-branch! #f 'br POST)))
+ (push-label! MV)
+ (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
+ (cond ((not tail)
+ (push-label! POST)
+ (maybe-drop)))))
+
+ ((<ghil-reified-env> env loc)
+ (return-object! loc (ghil-env-reify env)))))
+
+ ;;
+ ;; main
+ (record-case ghil
+ ((<ghil-lambda> env loc vars rest meta body)
+ (let* ((evars (ghil-env-variables env))
+ (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
+ (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
+ (nargs (allocate-indices-linearly! vars))
+ (nlocs (allocate-locals! locs body))
+ (nexts (allocate-indices-linearly! exts)))
+ ;; meta bindings
+ (push-bindings! #f vars)
+ ;; push on definition source location
+ (if loc (set! stack (cons (make-glil-source loc) stack)))
+ ;; copy args to the heap if they're marked as external
+ (do ((n 0 (1+ n))
+ (l vars (cdr l)))
+ ((null? l))
+ (let ((v (car l)))
+ (case (ghil-var-kind v)
+ ((external)
+ (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
+ ;; compile body
+ (comp body #t #f)
+ ;; create GLIL
+ (make-glil-program nargs (if rest 1 0) nlocs nexts meta
+ (reverse! stack)))))))
+
+(define (allocate-indices-linearly! vars)
+ (do ((n 0 (1+ n))
+ (l vars (cdr l)))
+ ((null? l) n)
+ (let ((v (car l))) (set! (ghil-var-index v) n))))
+
+(define (allocate-locals! vars body)
+ (let ((free '()) (nlocs 0))
+ (define (allocate! var)
+ (cond
+ ((pair? free)
+ (set! (ghil-var-index var) (car free))
+ (set! free (cdr free)))
+ (else
+ (set! (ghil-var-index var) nlocs)
+ (set! nlocs (1+ nlocs)))))
+ (define (deallocate! var)
+ (set! free (cons (ghil-var-index var) free)))
+ (let lp ((x body))
+ (record-case x
+ ((<ghil-void>))
+ ((<ghil-quote>))
+ ((<ghil-quasiquote> exp)
+ (let qlp ((x exp))
+ (cond ((list? x) (for-each qlp x))
+ ((pair? x) (qlp (car x)) (qlp (cdr x)))
+ ((record? x)
+ (record-case x
+ ((<ghil-unquote> exp) (lp exp))
+ ((<ghil-unquote-splicing> exp) (lp exp)))))))
+ ((<ghil-unquote> exp)
+ (lp exp))
+ ((<ghil-unquote-splicing> exp)
+ (lp exp))
+ ((<ghil-reified-env>))
+ ((<ghil-set> val)
+ (lp val))
+ ((<ghil-ref>))
+ ((<ghil-define> val)
+ (lp val))
+ ((<ghil-if> test then else)
+ (lp test) (lp then) (lp else))
+ ((<ghil-and> exps)
+ (for-each lp exps))
+ ((<ghil-or> exps)
+ (for-each lp exps))
+ ((<ghil-begin> exps)
+ (for-each lp exps))
+ ((<ghil-bind> vars vals body)
+ (for-each allocate! vars)
+ (for-each lp vals)
+ (lp body)
+ (for-each deallocate! vars))
+ ((<ghil-mv-bind> vars producer body)
+ (lp producer)
+ (for-each allocate! vars)
+ (lp body)
+ (for-each deallocate! vars))
+ ((<ghil-inline> args)
+ (for-each lp args))
+ ((<ghil-call> proc args)
+ (lp proc)
+ (for-each lp args))
+ ((<ghil-lambda>))
+ ((<ghil-mv-call> producer consumer)
+ (lp producer)
+ (lp consumer))
+ ((<ghil-values> values)
+ (for-each lp values))
+ ((<ghil-values*> values)
+ (for-each lp values))))
+ nlocs))
--- /dev/null
+;;; Tree Intermediate Language
+
+;; Copyright (C) 2009 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 program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il spec)
+ #:use-module (system base language)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il compile-glil)
+ #:export (tree-il))
+
+(define (write-tree-il exp . port)
+ (apply write (unparse-tree-il exp) port))
+
+(define (parse x)
+ (make-lambda #f '() '() (parse-tree-il x)))
+
+(define (join exps env)
+ (if (or-map (lambda (x)
+ (or (not (lambda? x))
+ (not (null? (lambda-vars x)))))
+ exps)
+ (error "tree-il expressions to join must be thunks"))
+
+ (make-lambda #f '() '() (make-sequence #f (map lambda-body exps))))
+
+(define-language tree-il
+ #:title "Tree Intermediate Language"
+ #:version "1.0"
+ #:reader read
+ #:printer write-tree-il
+ #:parser parse
+ #:joiner join
+ #:compilers `((glil . ,compile-glil))
+ )
HCoop / bpt / guile.git / commitdiff