mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity
guile/ice-9/psyntax.pp
Mikael Djurfeldt 402dd41f64 Regenerated
2000-08-13 20:27:39 +00:00

11 lines
96 KiB
ObjectPascal
Raw Blame History

(letrec ((lambda-var-list (lambda (vars) (let lvl ((vars402 vars) (ls (quote ())) (w (quote (())))) (cond ((pair? vars402) (lvl (cdr vars402) (cons (wrap (car vars402) w) ls) w)) ((id? vars402) (cons (wrap vars402 w) ls)) ((null? vars402) ls) ((syntax-object? vars402) (lvl (syntax-object-expression vars402) ls (join-wraps w (syntax-object-wrap vars402)))) ((annotation? vars402) (lvl (annotation-expression vars402) ls w)) (else (cons vars402 ls)))))) (gen-var (lambda (id) (let ((id403 (if (syntax-object? id) (syntax-object-expression id) id))) (if (annotation? id403) (gensym (annotation-expression id403) generated-symbols) (gensym id403 generated-symbols))))) (strip (lambda (x404 w405) (if (memq (quote top) (wrap-marks w405)) (if (or (annotation? x404) (and (pair? x404) (annotation? (car x404)))) (strip-annotation x404 (quote #f)) x404) (let f406 ((x407 x404)) (cond ((syntax-object? x407) (strip (syntax-object-expression x407) (syntax-object-wrap x407))) ((pair? x407) (let ((a (f406 (car x407))) (d (f406 (cdr x407)))) (if (and (eq? a (car x407)) (eq? d (cdr x407))) x407 (cons a d)))) ((vector? x407) (let ((old (vector->list x407))) (let ((new (map f406 old))) (if (andmap eq? old new) x407 (list->vector new))))) (else x407)))))) (strip-annotation (lambda (x408 parent) (cond ((pair? x408) (let ((new409 (cons (quote #f) (quote #f)))) (begin (when parent (set-annotation-stripped! parent new409)) (set-car! new409 (strip-annotation (car x408) (quote #f))) (set-cdr! new409 (strip-annotation (cdr x408) (quote #f))) new409))) ((annotation? x408) (or (annotation-stripped x408) (strip-annotation (annotation-expression x408) x408))) ((vector? x408) (let ((new410 (make-vector (vector-length x408)))) (begin (when parent (set-annotation-stripped! parent new410)) (let loop ((i411 (- (vector-length x408) (quote 1)))) (unless (fx< i411 (quote 0)) (vector-set! new410 i411 (strip-annotation (vector-ref x408 i411) (quote #f))) (loop (fx- i411 (quote 1))))) new410))) (else x408)))) (ellipsis? (lambda (x412) (and (nonsymbol-id? x412) (free-id=? x412 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void (lambda () (list (quote void)))) (eval-local-transformer (lambda (expanded) (let ((p (local-eval-hook expanded))) (if (procedure? p) p (syntax-error p (quote "nonprocedure transfomer")))))) (chi-local-syntax (lambda (rec? e r w413 s k) ((lambda (tmp414) ((lambda (tmp415) (if tmp415 (apply (lambda (_416 id417 val e1 e2) (let ((ids418 id417)) (if (not (valid-bound-ids? ids418)) (syntax-error e (quote "duplicate bound keyword in")) (let ((labels (gen-labels ids418))) (let ((new-w (make-binding-wrap ids418 labels w413))) (k (cons e1 e2) (extend-env labels (let ((w421 (if rec? new-w w413)) (trans-r (macros-only-env r))) (map (lambda (x422) (cons (quote macro) (eval-local-transformer (chi x422 trans-r w421)))) val)) r) new-w s)))))) tmp415) ((lambda (_424) (syntax-error (source-wrap e w413 s))) tmp414))) (syntax-dispatch tmp414 (quote (any #(each (any any)) any . each-any))))) e))) (chi-lambda-clause (lambda (e425 c r426 w427 k428) ((lambda (tmp429) ((lambda (tmp430) (if tmp430 (apply (lambda (id431 e1432 e2433) (let ((ids434 id431)) (if (not (valid-bound-ids? ids434)) (syntax-error e425 (quote "invalid parameter list in")) (let ((labels436 (gen-labels ids434)) (new-vars (map gen-var ids434))) (k428 new-vars (chi-body (cons e1432 e2433) e425 (extend-var-env labels436 new-vars r426) (make-binding-wrap ids434 labels436 w427))))))) tmp430) ((lambda (tmp438) (if tmp438 (apply (lambda (ids439 e1440 e2441) (let ((old-ids (lambda-var-list ids439))) (if (not (valid-bound-ids? old-ids)) (syntax-error e425 (quote "invalid parameter list in")) (let ((labels442 (gen-labels old-ids)) (new-vars443 (map gen-var old-ids))) (k428 (let f444 ((ls1 (cdr new-vars443)) (ls2 (car new-vars443))) (if (null? ls1) ls2 (f444 (cdr ls1) (cons (car ls1) ls2)))) (chi-body (cons e1440 e2441) e425 (extend-var-env labels442 new-vars443 r426) (make-binding-wrap old-ids labels442 w427))))))) tmp438) ((lambda (_446) (syntax-error e425)) tmp429))) (syntax-dispatch tmp429 (quote (any any . each-any)))))) (syntax-dispatch tmp429 (quote (each-any any . each-any))))) c))) (chi-body (lambda (body outer-form r447 w448) (let ((r449 (cons (quote ("placeholder" placeholder)) r447))) (let ((ribcage (make-ribcage (quote ()) (quote ()) (quote ())))) (let ((w450 (make-wrap (wrap-marks w448) (cons ribcage (wrap-subst w448))))) (let parse ((body451 (map (lambda (x455) (cons r449 (wrap x455 w450))) body)) (ids452 (quote ())) (labels453 (quote ())) (vars454 (quote ())) (vals (quote ())) (bindings (quote ()))) (if (null? body451) (syntax-error outer-form (quote "no expressions in body")) (let ((e456 (cdar body451)) (er (caar body451))) (call-with-values (lambda () (syntax-type e456 er (quote (())) (quote #f) ribcage)) (lambda (type value e457 w458 s459) (let ((t type)) (if (memv t (quote (define-form))) (let ((id460 (wrap value w458)) (label (gen-label))) (let ((var (gen-var id460))) (begin (extend-ribcage! ribcage id460 label) (parse (cdr body451) (cons id460 ids452) (cons label labels453) (cons var vars454) (cons (cons er (wrap e457 w458)) vals) (cons (cons (quote lexical) var) bindings))))) (if (memv t (quote (define-syntax-form))) (let ((id461 (wrap value w458)) (label462 (gen-label))) (begin (extend-ribcage! ribcage id461 label462) (parse (cdr body451) (cons id461 ids452) (cons label462 labels453) vars454 vals (cons (cons (quote macro) (cons er (wrap e457 w458))) bindings)))) (if (memv t (quote (begin-form))) ((lambda (tmp463) ((lambda (tmp464) (if tmp464 (apply (lambda (_465 e1466) (parse (let f467 ((forms e1466)) (if (null? forms) (cdr body451) (cons (cons er (wrap (car forms) w458)) (f467 (cdr forms))))) ids452 labels453 vars454 vals bindings)) tmp464) (syntax-error tmp463))) (syntax-dispatch tmp463 (quote (any . each-any))))) e457) (if (memv t (quote (local-syntax-form))) (chi-local-syntax value e457 er w458 s459 (lambda (forms469 er470 w471 s472) (parse (let f473 ((forms474 forms469)) (if (null? forms474) (cdr body451) (cons (cons er470 (wrap (car forms474) w471)) (f473 (cdr forms474))))) ids452 labels453 vars454 vals bindings))) (if (null? ids452) (build-sequence (quote #f) (map (lambda (x475) (chi (cdr x475) (car x475) (quote (())))) (cons (cons er (source-wrap e457 w458 s459)) (cdr body451)))) (begin (if (not (valid-bound-ids? ids452)) (syntax-error outer-form (quote "invalid or duplicate identifier in definition"))) (let loop476 ((bs bindings) (er-cache (quote #f)) (r-cache (quote #f))) (if (not (null? bs)) (let ((b (car bs))) (if (eq? (car b) (quote macro)) (let ((er477 (cadr b))) (let ((r-cache478 (if (eq? er477 er-cache) r-cache (macros-only-env er477)))) (begin (set-cdr! b (eval-local-transformer (chi (cddr b) r-cache478 (quote (()))))) (loop476 (cdr bs) er477 r-cache478)))) (loop476 (cdr bs) er-cache r-cache))))) (set-cdr! r449 (extend-env labels453 bindings (cdr r449))) (build-letrec (quote #f) vars454 (map (lambda (x479) (chi (cdr x479) (car x479) (quote (())))) vals) (build-sequence (quote #f) (map (lambda (x480) (chi (cdr x480) (car x480) (quote (())))) (cons (cons er (source-wrap e457 w458 s459)) (cdr body451)))))))))))))))))))))) (chi-macro (lambda (p481 e482 r483 w484 rib) (letrec ((rebuild-macro-output (lambda (x485 m) (cond ((pair? x485) (cons (rebuild-macro-output (car x485) m) (rebuild-macro-output (cdr x485) m))) ((syntax-object? x485) (let ((w486 (syntax-object-wrap x485))) (let ((ms (wrap-marks w486)) (s487 (wrap-subst w486))) (make-syntax-object (syntax-object-expression x485) (if (and (pair? ms) (eq? (car ms) (quote #f))) (make-wrap (cdr ms) (if rib (cons rib (cdr s487)) (cdr s487))) (make-wrap (cons m ms) (if rib (cons rib (cons (quote shift) s487)) (cons (quote shift) s487)))))))) ((vector? x485) (let ((n (vector-length x485))) (let ((v (make-vector n))) (let doloop ((i488 (quote 0))) (if (fx= i488 n) v (begin (vector-set! v i488 (rebuild-macro-output (vector-ref x485 i488) m)) (doloop (fx+ i488 (quote 1))))))))) ((symbol? x485) (syntax-error x485 (quote "encountered raw symbol in macro output"))) (else x485))))) (rebuild-macro-output (p481 (wrap e482 (anti-mark w484))) (string (quote #\m)))))) (chi-application (lambda (x489 e490 r491 w492 s493) ((lambda (tmp494) ((lambda (tmp495) (if tmp495 (apply (lambda (e0 e1496) (cons x489 (map (lambda (e497) (chi e497 r491 w492)) e1496))) tmp495) (syntax-error tmp494))) (syntax-dispatch tmp494 (quote (any . each-any))))) e490))) (chi-expr (lambda (type499 value500 e501 r502 w503 s504) (let ((t505 type499)) (if (memv t505 (quote (lexical))) value500 (if (memv t505 (quote (core))) (value500 e501 r502 w503 s504) (if (memv t505 (quote (lexical-call))) (chi-application value500 e501 r502 w503 s504) (if (memv t505 (quote (global-call))) (chi-application value500 e501 r502 w503 s504) (if (memv t505 (quote (constant))) (list (quote quote) (strip (source-wrap e501 w503 s504) (quote (())))) (if (memv t505 (quote (global))) value500 (if (memv t505 (quote (call))) (chi-application (chi (car e501) r502 w503) e501 r502 w503 s504) (if (memv t505 (quote (begin-form))) ((lambda (tmp506) ((lambda (tmp507) (if tmp507 (apply (lambda (_508 e1509 e2510) (chi-sequence (cons e1509 e2510) r502 w503 s504)) tmp507) (syntax-error tmp506))) (syntax-dispatch tmp506 (quote (any any . each-any))))) e501) (if (memv t505 (quote (local-syntax-form))) (chi-local-syntax value500 e501 r502 w503 s504 chi-sequence) (if (memv t505 (quote (eval-when-form))) ((lambda (tmp512) ((lambda (tmp513) (if tmp513 (apply (lambda (_514 x515 e1516 e2517) (let ((when-list (chi-when-list e501 x515 w503))) (if (memq (quote eval) when-list) (chi-sequence (cons e1516 e2517) r502 w503 s504) (chi-void)))) tmp513) (syntax-error tmp512))) (syntax-dispatch tmp512 (quote (any each-any any . each-any))))) e501) (if (memv t505 (quote (define-form define-syntax-form))) (syntax-error (wrap value500 w503) (quote "invalid context for definition of")) (if (memv t505 (quote (syntax))) (syntax-error (source-wrap e501 w503 s504) (quote "reference to pattern variable outside syntax form")) (if (memv t505 (quote (displaced-lexical))) (syntax-error (source-wrap e501 w503 s504) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap e501 w503 s504)))))))))))))))))) (chi (lambda (e520 r521 w522) (call-with-values (lambda () (syntax-type e520 r521 w522 (quote #f) (quote #f))) (lambda (type523 value524 e525 w526 s527) (chi-expr type523 value524 e525 r521 w526 s527))))) (chi-top (lambda (e528 r529 w530 m531 esew) (call-with-values (lambda () (syntax-type e528 r529 w530 (quote #f) (quote #f))) (lambda (type543 value544 e545 w546 s547) (let ((t548 type543)) (if (memv t548 (quote (begin-form))) ((lambda (tmp549) ((lambda (tmp550) (if tmp550 (apply (lambda (_551) (chi-void)) tmp550) ((lambda (tmp552) (if tmp552 (apply (lambda (_553 e1554 e2555) (chi-top-sequence (cons e1554 e2555) r529 w546 s547 m531 esew)) tmp552) (syntax-error tmp549))) (syntax-dispatch tmp549 (quote (any any . each-any)))))) (syntax-dispatch tmp549 (quote (any))))) e545) (if (memv t548 (quote (local-syntax-form))) (chi-local-syntax value544 e545 r529 w546 s547 (lambda (body557 r558 w559 s560) (chi-top-sequence body557 r558 w559 s560 m531 esew))) (if (memv t548 (quote (eval-when-form))) ((lambda (tmp561) ((lambda (tmp562) (if tmp562 (apply (lambda (_563 x564 e1565 e2566) (let ((when-list567 (chi-when-list e545 x564 w546)) (body568 (cons e1565 e2566))) (cond ((eq? m531 (quote e)) (if (memq (quote eval) when-list567) (chi-top-sequence body568 r529 w546 s547 (quote e) (quote (eval))) (chi-void))) ((memq (quote load) when-list567) (if (or (memq (quote compile) when-list567) (and (eq? m531 (quote c&e)) (memq (quote eval) when-list567))) (chi-top-sequence body568 r529 w546 s547 (quote c&e) (quote (compile load))) (if (memq m531 (quote (c c&e))) (chi-top-sequence body568 r529 w546 s547 (quote c) (quote (load))) (chi-void)))) ((or (memq (quote compile) when-list567) (and (eq? m531 (quote c&e)) (memq (quote eval) when-list567))) (top-level-eval-hook (chi-top-sequence body568 r529 w546 s547 (quote e) (quote (eval)))) (chi-void)) (else (chi-void))))) tmp562) (syntax-error tmp561))) (syntax-dispatch tmp561 (quote (any each-any any . each-any))))) e545) (if (memv t548 (quote (define-syntax-form))) (let ((n571 (id-var-name value544 w546)) (r572 (macros-only-env r529))) (let ((t573 m531)) (if (memv t573 (quote (c))) (if (memq (quote compile) esew) (let ((e574 (chi-install-global n571 (chi e545 r572 w546)))) (begin (top-level-eval-hook e574) (if (memq (quote load) esew) e574 (chi-void)))) (if (memq (quote load) esew) (chi-install-global n571 (chi e545 r572 w546)) (chi-void))) (if (memv t573 (quote (c&e))) (let ((e575 (chi-install-global n571 (chi e545 r572 w546)))) (begin (top-level-eval-hook e575) e575)) (begin (if (memq (quote eval) esew) (top-level-eval-hook (chi-install-global n571 (chi e545 r572 w546)))) (chi-void)))))) (if (memv t548 (quote (define-form))) (let ((n576 (id-var-name value544 w546))) (let ((t577 (binding-type (lookup n576 r529)))) (if (memv t577 (quote (global))) (let ((x578 (list (quote define) n576 (chi e545 r529 w546)))) (begin (if (eq? m531 (quote c&e)) (top-level-eval-hook x578)) x578)) (if (memv t577 (quote (displaced-lexical))) (syntax-error (wrap value544 w546) (quote "identifier out of context")) (syntax-error (wrap value544 w546) (quote "cannot define keyword at top level")))))) (let ((x579 (chi-expr type543 value544 e545 r529 w546 s547))) (begin (if (eq? m531 (quote c&e)) (top-level-eval-hook x579)) x579)))))))))))) (syntax-type (lambda (e580 r581 w582 s583 rib584) (cond ((symbol? e580) (let ((n585 (id-var-name e580 w582))) (let ((b586 (lookup n585 r581))) (let ((type587 (binding-type b586))) (let ((t588 type587)) (if (memv t588 (quote (lexical))) (values type587 (binding-value b586) e580 w582 s583) (if (memv t588 (quote (global))) (values type587 n585 e580 w582 s583) (if (memv t588 (quote (macro))) (syntax-type (chi-macro (binding-value b586) e580 r581 w582 rib584) r581 (quote (())) s583 rib584) (values type587 (binding-value b586) e580 w582 s583))))))))) ((pair? e580) (let ((first (car e580))) (if (id? first) (let ((n589 (id-var-name first w582))) (let ((b590 (lookup n589 r581))) (let ((type591 (binding-type b590))) (let ((t592 type591)) (if (memv t592 (quote (lexical))) (values (quote lexical-call) (binding-value b590) e580 w582 s583) (if (memv t592 (quote (global))) (values (quote global-call) n589 e580 w582 s583) (if (memv t592 (quote (macro))) (syntax-type (chi-macro (binding-value b590) e580 r581 w582 rib584) r581 (quote (())) s583 rib584) (if (memv t592 (quote (core))) (values type591 (binding-value b590) e580 w582 s583) (if (memv t592 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value b590) e580 w582 s583) (if (memv t592 (quote (begin))) (values (quote begin-form) (quote #f) e580 w582 s583) (if (memv t592 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e580 w582 s583) (if (memv t592 (quote (define))) ((lambda (tmp593) ((lambda (tmp594) (if (if tmp594 (apply (lambda (_595 name596 val597) (id? name596)) tmp594) (quote #f)) (apply (lambda (_598 name599 val600) (values (quote define-form) name599 val600 w582 s583)) tmp594) ((lambda (tmp601) (if (if tmp601 (apply (lambda (_602 name603 args604 e1605 e2606) (and (id? name603) (valid-bound-ids? (lambda-var-list args604)))) tmp601) (quote #f)) (apply (lambda (_607 name608 args609 e1610 e2611) (values (quote define-form) (wrap name608 w582) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap (cons args609 (cons e1610 e2611)) w582)) (quote (())) s583)) tmp601) ((lambda (tmp613) (if (if tmp613 (apply (lambda (_614 name615) (id? name615)) tmp613) (quote #f)) (apply (lambda (_616 name617) (values (quote define-form) (wrap name617 w582) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s583)) tmp613) (syntax-error tmp593))) (syntax-dispatch tmp593 (quote (any any)))))) (syntax-dispatch tmp593 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp593 (quote (any any any))))) e580) (if (memv t592 (quote (define-syntax))) ((lambda (tmp618) ((lambda (tmp619) (if (if tmp619 (apply (lambda (_620 name621 val622) (id? name621)) tmp619) (quote #f)) (apply (lambda (_623 name624 val625) (values (quote define-syntax-form) name624 val625 w582 s583)) tmp619) (syntax-error tmp618))) (syntax-dispatch tmp618 (quote (any any any))))) e580) (values (quote call) (quote #f) e580 w582 s583)))))))))))))) (values (quote call) (quote #f) e580 w582 s583)))) ((syntax-object? e580) (syntax-type (syntax-object-expression e580) r581 (join-wraps w582 (syntax-object-wrap e580)) (quote #f) rib584)) ((annotation? e580) (syntax-type (annotation-expression e580) r581 w582 (annotation-source e580) rib584)) ((let ((x626 e580)) (or (boolean? x626) (number? x626) (string? x626) (char? x626) (null? x626) (keyword? x626))) (values (quote constant) (quote #f) e580 w582 s583)) (else (values (quote other) (quote #f) e580 w582 s583))))) (chi-when-list (lambda (e627 when-list628 w629) (let f630 ((when-list631 when-list628) (situations (quote ()))) (if (null? when-list631) situations (f630 (cdr when-list631) (cons (let ((x632 (car when-list631))) (cond ((free-id=? x632 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=? x632 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=? x632 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap x632 w629) (quote "invalid eval-when situation"))))) situations)))))) (chi-install-global (lambda (name633 e634) (list (quote install-global-transformer) (list (quote quote) name633) e634))) (chi-top-sequence (lambda (body635 r636 w637 s638 m639 esew640) (build-sequence s638 (let dobody ((body641 body635) (r642 r636) (w643 w637) (m644 m639) (esew645 esew640)) (if (null? body641) (quote ()) (let ((first646 (chi-top (car body641) r642 w643 m644 esew645))) (cons first646 (dobody (cdr body641) r642 w643 m644 esew645)))))))) (chi-sequence (lambda (body647 r648 w649 s650) (build-sequence s650 (let dobody651 ((body652 body647) (r653 r648) (w654 w649)) (if (null? body652) (quote ()) (let ((first655 (chi (car body652) r653 w654))) (cons first655 (dobody651 (cdr body652) r653 w654)))))))) (source-wrap (lambda (x656 w657 s658) (wrap (if s658 (make-annotation x656 s658 (quote #f)) x656) w657))) (wrap (lambda (x659 w660) (cond ((and (null? (wrap-marks w660)) (null? (wrap-subst w660))) x659) ((syntax-object? x659) (make-syntax-object (syntax-object-expression x659) (join-wraps w660 (syntax-object-wrap x659)))) ((null? x659) x659) (else (make-syntax-object x659 w660))))) (bound-id-member? (lambda (x661 list) (and (not (null? list)) (or (bound-id=? x661 (car list)) (bound-id-member? x661 (cdr list)))))) (distinct-bound-ids? (lambda (ids662) (let distinct? ((ids663 ids662)) (or (null? ids663) (and (not (bound-id-member? (car ids663) (cdr ids663))) (distinct? (cdr ids663))))))) (valid-bound-ids? (lambda (ids664) (and (let all-ids? ((ids665 ids664)) (or (null? ids665) (and (id? (car ids665)) (all-ids? (cdr ids665))))) (distinct-bound-ids? ids664)))) (bound-id=? (lambda (i666 j) (if (and (syntax-object? i666) (syntax-object? j)) (and (eq? (let ((e667 (syntax-object-expression i666))) (if (annotation? e667) (annotation-expression e667) e667)) (let ((e668 (syntax-object-expression j))) (if (annotation? e668) (annotation-expression e668) e668))) (same-marks? (wrap-marks (syntax-object-wrap i666)) (wrap-marks (syntax-object-wrap j)))) (eq? (let ((e669 i666)) (if (annotation? e669) (annotation-expression e669) e669)) (let ((e670 j)) (if (annotation? e670) (annotation-expression e670) e670)))))) (free-id=? (lambda (i671 j672) (and (eq? (let ((x673 i671)) (let ((e674 (if (syntax-object? x673) (syntax-object-expression x673) x673))) (if (annotation? e674) (annotation-expression e674) e674))) (let ((x675 j672)) (let ((e676 (if (syntax-object? x675) (syntax-object-expression x675) x675))) (if (annotation? e676) (annotation-expression e676) e676)))) (eq? (id-var-name i671 (quote (()))) (id-var-name j672 (quote (()))))))) (id-var-name (lambda (id677 w678) (letrec ((search-vector-rib (lambda (sym subst marks symnames ribcage688) (let ((n689 (vector-length symnames))) (let f690 ((i691 (quote 0))) (cond ((fx= i691 n689) (search sym (cdr subst) marks)) ((and (eq? (vector-ref symnames i691) sym) (same-marks? marks (vector-ref (ribcage-marks ribcage688) i691))) (values (vector-ref (ribcage-labels ribcage688) i691) marks)) (else (f690 (fx+ i691 (quote 1))))))))) (search-list-rib (lambda (sym692 subst693 marks694 symnames695 ribcage696) (let f697 ((symnames698 symnames695) (i699 (quote 0))) (cond ((null? symnames698) (search sym692 (cdr subst693) marks694)) ((and (eq? (car symnames698) sym692) (same-marks? marks694 (list-ref (ribcage-marks ribcage696) i699))) (values (list-ref (ribcage-labels ribcage696) i699) marks694)) (else (f697 (cdr symnames698) (fx+ i699 (quote 1)))))))) (search (lambda (sym700 subst701 marks702) (if (null? subst701) (values (quote #f) marks702) (let ((fst (car subst701))) (if (eq? fst (quote shift)) (search sym700 (cdr subst701) (cdr marks702)) (let ((symnames703 (ribcage-symnames fst))) (if (vector? symnames703) (search-vector-rib sym700 subst701 marks702 symnames703 fst) (search-list-rib sym700 subst701 marks702 symnames703 fst))))))))) (cond ((symbol? id677) (or (call-with-values (lambda () (search id677 (wrap-subst w678) (wrap-marks w678))) (lambda (x704 . ignore) x704)) id677)) ((syntax-object? id677) (let ((id705 (let ((e706 (syntax-object-expression id677))) (if (annotation? e706) (annotation-expression e706) e706))) (w1 (syntax-object-wrap id677))) (let ((marks707 (join-marks (wrap-marks w678) (wrap-marks w1)))) (call-with-values (lambda () (search id705 (wrap-subst w678) marks707)) (lambda (new-id marks708) (or new-id (call-with-values (lambda () (search id705 (wrap-subst w1) marks708)) (lambda (x710 . ignore709) x710)) id705)))))) ((annotation? id677) (let ((id711 (let ((e712 id677)) (if (annotation? e712) (annotation-expression e712) e712)))) (or (call-with-values (lambda () (search id711 (wrap-subst w678) (wrap-marks w678))) (lambda (x714 . ignore713) x714)) id711))) (else (error-hook (quote id-var-name) (quote "invalid id") id677)))))) (same-marks? (lambda (x715 y) (or (eq? x715 y) (and (not (null? x715)) (not (null? y)) (eq? (car x715) (car y)) (same-marks? (cdr x715) (cdr y)))))) (join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-wraps (lambda (w1716 w2) (let ((m1717 (wrap-marks w1716)) (s1 (wrap-subst w1716))) (if (null? m1717) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2)))) (make-wrap (smart-append m1717 (wrap-marks w2)) (smart-append s1 (wrap-subst w2))))))) (smart-append (lambda (m1718 m2719) (if (null? m2719) m1718 (append m1718 m2719)))) (make-binding-wrap (lambda (ids720 labels721 w722) (if (null? ids720) w722 (make-wrap (wrap-marks w722) (cons (let ((labelvec (list->vector labels721))) (let ((n723 (vector-length labelvec))) (let ((symnamevec (make-vector n723)) (marksvec (make-vector n723))) (begin (let f724 ((ids725 ids720) (i726 (quote 0))) (if (not (null? ids725)) (call-with-values (lambda () (id-sym-name&marks (car ids725) w722)) (lambda (symname marks727) (begin (vector-set! symnamevec i726 symname) (vector-set! marksvec i726 marks727) (f724 (cdr ids725) (fx+ i726 (quote 1)))))))) (make-ribcage symnamevec marksvec labelvec))))) (wrap-subst w722)))))) (extend-ribcage! (lambda (ribcage728 id729 label730) (begin (set-ribcage-symnames! ribcage728 (cons (let ((e731 (syntax-object-expression id729))) (if (annotation? e731) (annotation-expression e731) e731)) (ribcage-symnames ribcage728))) (set-ribcage-marks! ribcage728 (cons (wrap-marks (syntax-object-wrap id729)) (ribcage-marks ribcage728))) (set-ribcage-labels! ribcage728 (cons label730 (ribcage-labels ribcage728)))))) (anti-mark (lambda (w732) (make-wrap (cons (quote #f) (wrap-marks w732)) (cons (quote shift) (wrap-subst w732))))) (set-ribcage-labels! (lambda (x733 update) (vector-set! x733 (quote 3) update))) (set-ribcage-marks! (lambda (x734 update735) (vector-set! x734 (quote 2) update735))) (set-ribcage-symnames! (lambda (x736 update737) (vector-set! x736 (quote 1) update737))) (ribcage-labels (lambda (x738) (vector-ref x738 (quote 3)))) (ribcage-marks (lambda (x739) (vector-ref x739 (quote 2)))) (ribcage-symnames (lambda (x740) (vector-ref x740 (quote 1)))) (ribcage? (lambda (x741) (and (vector? x741) (= (vector-length x741) (quote 4)) (eq? (vector-ref x741 (quote 0)) (quote ribcage))))) (make-ribcage (lambda (symnames742 marks743 labels744) (vector (quote ribcage) symnames742 marks743 labels744))) (gen-labels (lambda (ls745) (if (null? ls745) (quote ()) (cons (gen-label) (gen-labels (cdr ls745)))))) (gen-label (lambda () (string (quote #\i)))) (wrap-subst cdr) (wrap-marks car) (make-wrap cons) (id-sym-name&marks (lambda (x746 w747) (if (syntax-object? x746) (values (let ((e748 (syntax-object-expression x746))) (if (annotation? e748) (annotation-expression e748) e748)) (join-marks (wrap-marks w747) (wrap-marks (syntax-object-wrap x746)))) (values (let ((e749 x746)) (if (annotation? e749) (annotation-expression e749) e749)) (wrap-marks w747))))) (id? (lambda (x750) (cond ((symbol? x750) (quote #t)) ((syntax-object? x750) (symbol? (let ((e751 (syntax-object-expression x750))) (if (annotation? e751) (annotation-expression e751) e751)))) ((annotation? x750) (symbol? (annotation-expression x750))) (else (quote #f))))) (nonsymbol-id? (lambda (x752) (and (syntax-object? x752) (symbol? (let ((e753 (syntax-object-expression x752))) (if (annotation? e753) (annotation-expression e753) e753)))))) (global-extend (lambda (type754 sym755 val756) (put-global-definition-hook sym755 (cons type754 val756)))) (lookup (lambda (x757 r758) (cond ((assq x757 r758) => cdr) ((symbol? x757) (or (get-global-definition-hook x757) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env (lambda (r759) (if (null? r759) (quote ()) (let ((a760 (car r759))) (if (eq? (cadr a760) (quote macro)) (cons a760 (macros-only-env (cdr r759))) (macros-only-env (cdr r759))))))) (extend-var-env (lambda (labels761 vars762 r763) (if (null? labels761) r763 (extend-var-env (cdr labels761) (cdr vars762) (cons (cons (car labels761) (cons (quote lexical) (car vars762))) r763))))) (extend-env (lambda (labels764 bindings765 r766) (if (null? labels764) r766 (extend-env (cdr labels764) (cdr bindings765) (cons (cons (car labels764) (car bindings765)) r766))))) (binding-value cdr) (binding-type car) (source-annotation (lambda (x767) (cond ((annotation? x767) (annotation-source x767)) ((syntax-object? x767) (source-annotation (syntax-object-expression x767))) (else (quote #f))))) (set-syntax-object-wrap! (lambda (x768 update769) (vector-set! x768 (quote 2) update769))) (set-syntax-object-expression! (lambda (x770 update771) (vector-set! x770 (quote 1) update771))) (syntax-object-wrap (lambda (x772) (vector-ref x772 (quote 2)))) (syntax-object-expression (lambda (x773) (vector-ref x773 (quote 1)))) (syntax-object? (lambda (x774) (and (vector? x774) (= (vector-length x774) (quote 3)) (eq? (vector-ref x774 (quote 0)) (quote syntax-object))))) (make-syntax-object (lambda (expression wrap775) (vector (quote syntax-object) expression wrap775))) (build-letrec (lambda (src vars776 val-exps body-exp) (if (null? vars776) body-exp (list (quote letrec) (map list vars776 val-exps) body-exp)))) (build-named-let (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence (lambda (src785 exps) (if (null? (cdr exps)) (car exps) (cons (quote begin) exps)))) (get-global-definition-hook (lambda (symbol) (getprop symbol (quote *sc-expander*)))) (put-global-definition-hook (lambda (symbol786 binding) (putprop symbol786 (quote *sc-expander*) binding))) (error-hook (lambda (who why what) (error who (quote "~a ~s") why what))) (local-eval-hook (lambda (x787) (eval (list noexpand x787) (interaction-environment)))) (top-level-eval-hook (lambda (x788) (eval (list noexpand x788) (interaction-environment)))) (annotation? (lambda (x789) (quote #f))) (fx< <) (fx= =) (fx- -) (fx+ +) (noexpand (quote "noexpand"))) (begin (global-extend (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend (quote core) (quote fluid-let-syntax) (lambda (e790 r791 w792 s793) ((lambda (tmp794) ((lambda (tmp795) (if (if tmp795 (apply (lambda (_796 var797 val798 e1799 e2800) (valid-bound-ids? var797)) tmp795) (quote #f)) (apply (lambda (_802 var803 val804 e1805 e2806) (let ((names (map (lambda (x807) (id-var-name x807 w792)) var803))) (begin (for-each (lambda (id809 n810) (let ((t811 (binding-type (lookup n810 r791)))) (if (memv t811 (quote (displaced-lexical))) (syntax-error (source-wrap id809 w792 s793) (quote "identifier out of context"))))) var803 names) (chi-body (cons e1805 e2806) (source-wrap e790 w792 s793) (extend-env names (let ((trans-r814 (macros-only-env r791))) (map (lambda (x815) (cons (quote macro) (eval-local-transformer (chi x815 trans-r814 w792)))) val804)) r791) w792)))) tmp795) ((lambda (_817) (syntax-error (source-wrap e790 w792 s793))) tmp794))) (syntax-dispatch tmp794 (quote (any #(each (any any)) any . each-any))))) e790))) (global-extend (quote core) (quote quote) (lambda (e818 r819 w820 s821) ((lambda (tmp822) ((lambda (tmp823) (if tmp823 (apply (lambda (_824 e825) (list (quote quote) (strip e825 w820))) tmp823) ((lambda (_826) (syntax-error (source-wrap e818 w820 s821))) tmp822))) (syntax-dispatch tmp822 (quote (any any))))) e818))) (global-extend (quote core) (quote syntax) (letrec ((regen (lambda (x827) (let ((t828 (car x827))) (if (memv t828 (quote (ref))) (cadr x827) (if (memv t828 (quote (primitive))) (cadr x827) (if (memv t828 (quote (quote))) (list (quote quote) (cadr x827)) (if (memv t828 (quote (lambda))) (list (quote lambda) (cadr x827) (regen (caddr x827))) (if (memv t828 (quote (map))) (let ((ls829 (map regen (cdr x827)))) (cons (if (fx= (length ls829) (quote 2)) (quote map) (quote map)) ls829)) (cons (car x827) (map regen (cdr x827))))))))))) (gen-vector (lambda (x830) (cond ((eq? (car x830) (quote list)) (cons (quote vector) (cdr x830))) ((eq? (car x830) (quote quote)) (list (quote quote) (list->vector (cadr x830)))) (else (list (quote list->vector) x830))))) (gen-append (lambda (x831 y832) (if (equal? y832 (quote (quote ()))) x831 (list (quote append) x831 y832)))) (gen-cons (lambda (x833 y834) (let ((t835 (car y834))) (if (memv t835 (quote (quote))) (if (eq? (car x833) (quote quote)) (list (quote quote) (cons (cadr x833) (cadr y834))) (if (eq? (cadr y834) (quote ())) (list (quote list) x833) (list (quote cons) x833 y834))) (if (memv t835 (quote (list))) (cons (quote list) (cons x833 (cdr y834))) (list (quote cons) x833 y834)))))) (gen-map (lambda (e836 map-env) (let ((formals (map cdr map-env)) (actuals (map (lambda (x837) (list (quote ref) (car x837))) map-env))) (cond ((eq? (car e836) (quote ref)) (car actuals)) ((andmap (lambda (x838) (and (eq? (car x838) (quote ref)) (memq (cadr x838) formals))) (cdr e836)) (cons (quote map) (cons (list (quote primitive) (car e836)) (map (let ((r839 (map cons formals actuals))) (lambda (x840) (cdr (assq (cadr x840) r839)))) (cdr e836))))) (else (cons (quote map) (cons (list (quote lambda) formals e836) actuals))))))) (gen-mappend (lambda (e841 map-env842) (list (quote apply) (quote (primitive append)) (gen-map e841 map-env842)))) (gen-ref (lambda (src843 var844 level maps) (if (fx= level (quote 0)) (values var844 maps) (if (null? maps) (syntax-error src843 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref src843 var844 (fx- level (quote 1)) (cdr maps))) (lambda (outer-var outer-maps) (let ((b845 (assq outer-var (car maps)))) (if b845 (values (cdr b845) maps) (let ((inner-var (gen-var (quote tmp)))) (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (gen-syntax (lambda (src846 e847 r848 maps849 ellipsis?850) (if (id? e847) (let ((label851 (id-var-name e847 (quote (()))))) (let ((b852 (lookup label851 r848))) (if (eq? (binding-type b852) (quote syntax)) (call-with-values (lambda () (let ((var.lev (binding-value b852))) (gen-ref src846 (car var.lev) (cdr var.lev) maps849))) (lambda (var853 maps854) (values (list (quote ref) var853) maps854))) (if (ellipsis?850 e847) (syntax-error src846 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e847) maps849))))) ((lambda (tmp855) ((lambda (tmp856) (if (if tmp856 (apply (lambda (dots e857) (ellipsis?850 dots)) tmp856) (quote #f)) (apply (lambda (dots858 e859) (gen-syntax src846 e859 r848 maps849 (lambda (x860) (quote #f)))) tmp856) ((lambda (tmp861) (if (if tmp861 (apply (lambda (x862 dots863 y864) (ellipsis?850 dots863)) tmp861) (quote #f)) (apply (lambda (x865 dots866 y867) (let f868 ((y869 y867) (k870 (lambda (maps871) (call-with-values (lambda () (gen-syntax src846 x865 r848 (cons (quote ()) maps871) ellipsis?850)) (lambda (x872 maps873) (if (null? (car maps873)) (syntax-error src846 (quote "extra ellipsis in syntax form")) (values (gen-map x872 (car maps873)) (cdr maps873)))))))) ((lambda (tmp874) ((lambda (tmp875) (if (if tmp875 (apply (lambda (dots876 y877) (ellipsis?850 dots876)) tmp875) (quote #f)) (apply (lambda (dots878 y879) (f868 y879 (lambda (maps880) (call-with-values (lambda () (k870 (cons (quote ()) maps880))) (lambda (x881 maps882) (if (null? (car maps882)) (syntax-error src846 (quote "extra ellipsis in syntax form")) (values (gen-mappend x881 (car maps882)) (cdr maps882)))))))) tmp875) ((lambda (_883) (call-with-values (lambda () (gen-syntax src846 y869 r848 maps849 ellipsis?850)) (lambda (y884 maps885) (call-with-values (lambda () (k870 maps885)) (lambda (x886 maps887) (values (gen-append x886 y884) maps887)))))) tmp874))) (syntax-dispatch tmp874 (quote (any . any))))) y869))) tmp861) ((lambda (tmp888) (if tmp888 (apply (lambda (x889 y890) (call-with-values (lambda () (gen-syntax src846 x889 r848 maps849 ellipsis?850)) (lambda (x891 maps892) (call-with-values (lambda () (gen-syntax src846 y890 r848 maps892 ellipsis?850)) (lambda (y893 maps894) (values (gen-cons x891 y893) maps894)))))) tmp888) ((lambda (tmp895) (if tmp895 (apply (lambda (e1896 e2897) (call-with-values (lambda () (gen-syntax src846 (cons e1896 e2897) r848 maps849 ellipsis?850)) (lambda (e899 maps900) (values (gen-vector e899) maps900)))) tmp895) ((lambda (_901) (values (list (quote quote) e847) maps849)) tmp855))) (syntax-dispatch tmp855 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp855 (quote (any . any)))))) (syntax-dispatch tmp855 (quote (any any . any)))))) (syntax-dispatch tmp855 (quote (any any))))) e847))))) (lambda (e902 r903 w904 s905) (let ((e906 (source-wrap e902 w904 s905))) ((lambda (tmp907) ((lambda (tmp908) (if tmp908 (apply (lambda (_909 x910) (call-with-values (lambda () (gen-syntax e906 x910 r903 (quote ()) ellipsis?)) (lambda (e911 maps912) (regen e911)))) tmp908) ((lambda (_913) (syntax-error e906)) tmp907))) (syntax-dispatch tmp907 (quote (any any))))) e906))))) (global-extend (quote core) (quote lambda) (lambda (e914 r915 w916 s917) ((lambda (tmp918) ((lambda (tmp919) (if tmp919 (apply (lambda (_920 c921) (chi-lambda-clause (source-wrap e914 w916 s917) c921 r915 w916 (lambda (vars922 body923) (list (quote lambda) vars922 body923)))) tmp919) (syntax-error tmp918))) (syntax-dispatch tmp918 (quote (any . any))))) e914))) (global-extend (quote core) (quote let) (letrec ((chi-let (lambda (e924 r925 w926 s927 constructor928 ids929 vals930 exps931) (if (not (valid-bound-ids? ids929)) (syntax-error e924 (quote "duplicate bound variable in")) (let ((labels932 (gen-labels ids929)) (new-vars933 (map gen-var ids929))) (let ((nw (make-binding-wrap ids929 labels932 w926)) (nr (extend-var-env labels932 new-vars933 r925))) (constructor928 s927 new-vars933 (map (lambda (x934) (chi x934 r925 w926)) vals930) (chi-body exps931 (source-wrap e924 nw s927) nr nw)))))))) (lambda (e935 r936 w937 s938) ((lambda (tmp939) ((lambda (tmp940) (if tmp940 (apply (lambda (_941 id942 val943 e1944 e2945) (chi-let e935 r936 w937 s938 build-let id942 val943 (cons e1944 e2945))) tmp940) ((lambda (tmp949) (if (if tmp949 (apply (lambda (_950 f951 id952 val953 e1954 e2955) (id? f951)) tmp949) (quote #f)) (apply (lambda (_956 f957 id958 val959 e1960 e2961) (chi-let e935 r936 w937 s938 build-named-let (cons f957 id958) val959 (cons e1960 e2961))) tmp949) ((lambda (_965) (syntax-error (source-wrap e935 w937 s938))) tmp939))) (syntax-dispatch tmp939 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp939 (quote (any #(each (any any)) any . each-any))))) e935)))) (global-extend (quote core) (quote letrec) (lambda (e966 r967 w968 s969) ((lambda (tmp970) ((lambda (tmp971) (if tmp971 (apply (lambda (_972 id973 val974 e1975 e2976) (let ((ids977 id973)) (if (not (valid-bound-ids? ids977)) (syntax-error e966 (quote "duplicate bound variable in")) (let ((labels979 (gen-labels ids977)) (new-vars980 (map gen-var ids977))) (let ((w981 (make-binding-wrap ids977 labels979 w968)) (r982 (extend-var-env labels979 new-vars980 r967))) (build-letrec s969 new-vars980 (map (lambda (x983) (chi x983 r982 w981)) val974) (chi-body (cons e1975 e2976) (source-wrap e966 w981 s969) r982 w981))))))) tmp971) ((lambda (_986) (syntax-error (source-wrap e966 w968 s969))) tmp970))) (syntax-dispatch tmp970 (quote (any #(each (any any)) any . each-any))))) e966))) (global-extend (quote core) (quote set!) (lambda (e987 r988 w989 s990) ((lambda (tmp991) ((lambda (tmp992) (if (if tmp992 (apply (lambda (_993 id994 val995) (id? id994)) tmp992) (quote #f)) (apply (lambda (_996 id997 val998) (let ((val999 (chi val998 r988 w989)) (n1000 (id-var-name id997 w989))) (let ((b1001 (lookup n1000 r988))) (let ((t1002 (binding-type b1001))) (if (memv t1002 (quote (lexical))) (list (quote set!) (binding-value b1001) val999) (if (memv t1002 (quote (global))) (list (quote set!) n1000 val999) (if (memv t1002 (quote (displaced-lexical))) (syntax-error (wrap id997 w989) (quote "identifier out of context")) (syntax-error (source-wrap e987 w989 s990))))))))) tmp992) ((lambda (_1003) (syntax-error (source-wrap e987 w989 s990))) tmp991))) (syntax-dispatch tmp991 (quote (any any any))))) e987))) (global-extend (quote begin) (quote begin) (quote ())) (global-extend (quote define) (quote define) (quote ())) (global-extend (quote define-syntax) (quote define-syntax) (quote ())) (global-extend (quote eval-when) (quote eval-when) (quote ())) (global-extend (quote core) (quote syntax-case) (letrec ((gen-syntax-case (lambda (x1004 keys clauses r1005) (if (null? clauses) (list (quote syntax-error) x1004) ((lambda (tmp1006) ((lambda (tmp1007) (if tmp1007 (apply (lambda (pat exp) (if (and (id? pat) (andmap (lambda (x1008) (not (free-id=? pat x1008))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? 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 get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys))) (let ((labels1009 (list (gen-label))) (var1010 (gen-var pat))) (list (list (quote lambda) (list var1010) (chi exp (extend-env labels1009 (list (cons (quote syntax) (cons var1010 (quote 0)))) r1005) (make-binding-wrap (list pat) labels1009 (quote (()))))) x1004)) (gen-clause x1004 keys (cdr clauses) r1005 pat (quote #t) exp))) tmp1007) ((lambda (tmp1011) (if tmp1011 (apply (lambda (pat1012 fender exp1013) (gen-clause x1004 keys (cdr clauses) r1005 pat1012 fender exp1013)) tmp1011) ((lambda (_1014) (syntax-error (car clauses) (quote "invalid syntax-case clause"))) tmp1006))) (syntax-dispatch tmp1006 (quote (any any any)))))) (syntax-dispatch tmp1006 (quote (any any))))) (car clauses))))) (gen-clause (lambda (x1015 keys1016 clauses1017 r1018 pat1019 fender1020 exp1021) (call-with-values (lambda () (convert-pattern pat1019 keys1016)) (lambda (p1022 pvars) (cond ((not (distinct-bound-ids? (map car pvars))) (syntax-error pat1019 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1023) (not (ellipsis? (car x1023)))) pvars)) (syntax-error pat1019 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1024 (gen-var (quote tmp)))) (list (list (quote lambda) (list y1024) (let ((y1025 y1024)) (list (quote if) ((lambda (tmp1026) ((lambda (tmp1027) (if tmp1027 (apply (lambda () y1025) tmp1027) ((lambda (_1028) (list (quote if) y1025 (build-dispatch-call pvars fender1020 y1025 r1018) (list (quote quote) (quote #f)))) tmp1026))) (syntax-dispatch tmp1026 (quote #(atom #t))))) fender1020) (build-dispatch-call pvars exp1021 y1025 r1018) (gen-syntax-case x1015 keys1016 clauses1017 r1018)))) (if (eq? p1022 (quote any)) (list (quote list) x1015) (list (quote syntax-dispatch) x1015 (list (quote quote) p1022))))))))))) (build-dispatch-call (lambda (pvars1029 exp1030 y1031 r1032) (let ((ids1033 (map car pvars1029)) (levels (map cdr pvars1029))) (let ((labels1034 (gen-labels ids1033)) (new-vars1035 (map gen-var ids1033))) (list (quote apply) (list (quote lambda) new-vars1035 (chi exp1030 (extend-env labels1034 (map (lambda (var1036 level1037) (cons (quote syntax) (cons var1036 level1037))) new-vars1035 (map cdr pvars1029)) r1032) (make-binding-wrap ids1033 labels1034 (quote (()))))) y1031))))) (convert-pattern (lambda (pattern keys1038) (let cvt ((p1039 pattern) (n1040 (quote 0)) (ids1041 (quote ()))) (if (id? p1039) (if (bound-id-member? p1039 keys1038) (values (vector (quote free-id) p1039) ids1041) (values (quote any) (cons (cons p1039 n1040) ids1041))) ((lambda (tmp1042) ((lambda (tmp1043) (if (if tmp1043 (apply (lambda (x1044 dots1045) (ellipsis? dots1045)) tmp1043) (quote #f)) (apply (lambda (x1046 dots1047) (call-with-values (lambda () (cvt x1046 (fx+ n1040 (quote 1)) ids1041)) (lambda (p1048 ids1049) (values (if (eq? p1048 (quote any)) (quote each-any) (vector (quote each) p1048)) ids1049)))) tmp1043) ((lambda (tmp1050) (if tmp1050 (apply (lambda (x1051 y1052) (call-with-values (lambda () (cvt y1052 n1040 ids1041)) (lambda (y1053 ids1054) (call-with-values (lambda () (cvt x1051 n1040 ids1054)) (lambda (x1055 ids1056) (values (cons x1055 y1053) ids1056)))))) tmp1050) ((lambda (tmp1057) (if tmp1057 (apply (lambda () (values (quote ()) ids1041)) tmp1057) ((lambda (tmp1058) (if tmp1058 (apply (lambda (x1059) (call-with-values (lambda () (cvt x1059 n1040 ids1041)) (lambda (p1061 ids1062) (values (vector (quote vector) p1061) ids1062)))) tmp1058) ((lambda (x1063) (values (vector (quote atom) (strip p1039 (quote (())))) ids1041)) tmp1042))) (syntax-dispatch tmp1042 (quote #(vector each-any)))))) (syntax-dispatch tmp1042 (quote ()))))) (syntax-dispatch tmp1042 (quote (any . any)))))) (syntax-dispatch tmp1042 (quote (any any))))) p1039)))))) (lambda (e1064 r1065 w1066 s1067) (let ((e1068 (source-wrap e1064 w1066 s1067))) ((lambda (tmp1069) ((lambda (tmp1070) (if tmp1070 (apply (lambda (_1071 val1072 key m1073) (if (andmap (lambda (x1074) (and (id? x1074) (not (ellipsis? x1074)))) key) (let ((x1076 (gen-var (quote tmp)))) (list (list (quote lambda) (list x1076) (gen-syntax-case x1076 key m1073 r1065)) (chi val1072 r1065 (quote (()))))) (syntax-error e1068 (quote "invalid literals list in")))) tmp1070) (syntax-error tmp1069))) (syntax-dispatch tmp1069 (quote (any any each-any . each-any))))) e1068))))) (set! sc-expand (let ((m1079 (quote e)) (esew1080 (quote (eval)))) (lambda (x1081) (if (and (pair? x1081) (equal? (car x1081) noexpand)) (cadr x1081) (chi-top x1081 (quote ()) (quote ((top))) m1079 esew1080))))) (set! sc-expand3 (let ((m1082 (quote e)) (esew1083 (quote (eval)))) (lambda (x1084 . rest) (if (and (pair? x1084) (equal? (car x1084) noexpand)) (cadr x1084) (chi-top x1084 (quote ()) (quote ((top))) (if (null? rest) m1082 (car rest)) (if (or (null? rest) (null? (cdr rest))) esew1083 (cadr rest))))))) (set! identifier? (lambda (x1085) (nonsymbol-id? x1085))) (set! datum->syntax-object (lambda (id1086 datum) (begin (let ((x1087 id1086)) (if (not (nonsymbol-id? x1087)) (error-hook (quote datum->syntax-object) (quote "invalid argument") x1087))) (make-syntax-object datum (syntax-object-wrap id1086))))) (set! syntax-object->datum (lambda (x1088) (strip x1088 (quote (()))))) (set! generate-temporaries (lambda (ls1089) (begin (let ((x1090 ls1089)) (if (not (list? x1090)) (error-hook (quote generate-temporaries) (quote "invalid argument") x1090))) (map (lambda (x1091) (wrap (gensym) (quote ((top))))) ls1089)))) (set! free-identifier=? (lambda (x1092 y1093) (begin (let ((x1094 x1092)) (if (not (nonsymbol-id? x1094)) (error-hook (quote free-identifier=?) (quote "invalid argument") x1094))) (let ((x1095 y1093)) (if (not (nonsymbol-id? x1095)) (error-hook (quote free-identifier=?) (quote "invalid argument") x1095))) (free-id=? x1092 y1093)))) (set! bound-identifier=? (lambda (x1096 y1097) (begin (let ((x1098 x1096)) (if (not (nonsymbol-id? x1098)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x1098))) (let ((x1099 y1097)) (if (not (nonsymbol-id? x1099)) (error-hook (quote bound-identifier=?) (quote "invalid argument") x1099))) (bound-id=? x1096 y1097)))) (set! syntax-error (lambda (object . messages) (begin (for-each (lambda (x1100) (let ((x1101 x1100)) (if (not (string? x1101)) (error-hook (quote syntax-error) (quote "invalid argument") x1101)))) messages) (let ((message (if (null? messages) (quote "invalid syntax") (apply string-append messages)))) (error-hook (quote #f) message (strip object (quote (())))))))) (set! install-global-transformer (lambda (sym1102 v1103) (begin (let ((x1104 sym1102)) (if (not (symbol? x1104)) (error-hook (quote define-syntax) (quote "invalid argument") x1104))) (let ((x1105 v1103)) (if (not (procedure? x1105)) (error-hook (quote define-syntax) (quote "invalid argument") x1105))) (global-extend (quote macro) sym1102 v1103)))) (letrec ((match (lambda (e1106 p1107 w1108 r1109) (cond ((not r1109) (quote #f)) ((eq? p1107 (quote any)) (cons (wrap e1106 w1108) r1109)) ((syntax-object? e1106) (match* (let ((e1110 (syntax-object-expression e1106))) (if (annotation? e1110) (annotation-expression e1110) e1110)) p1107 (join-wraps w1108 (syntax-object-wrap e1106)) r1109)) (else (match* (let ((e1111 e1106)) (if (annotation? e1111) (annotation-expression e1111) e1111)) p1107 w1108 r1109))))) (match* (lambda (e1112 p1113 w1114 r1115) (cond ((null? p1113) (and (null? e1112) r1115)) ((pair? p1113) (and (pair? e1112) (match (car e1112) (car p1113) w1114 (match (cdr e1112) (cdr p1113) w1114 r1115)))) ((eq? p1113 (quote each-any)) (let ((l (match-each-any e1112 w1114))) (and l (cons l r1115)))) (else (let ((t1116 (vector-ref p1113 (quote 0)))) (if (memv t1116 (quote (each))) (if (null? e1112) (match-empty (vector-ref p1113 (quote 1)) r1115) (let ((l1117 (match-each e1112 (vector-ref p1113 (quote 1)) w1114))) (and l1117 (let collect ((l1118 l1117)) (if (null? (car l1118)) r1115 (cons (map car l1118) (collect (map cdr l1118)))))))) (if (memv t1116 (quote (free-id))) (and (id? e1112) (free-id=? (wrap e1112 w1114) (vector-ref p1113 (quote 1))) r1115) (if (memv t1116 (quote (atom))) (and (equal? (vector-ref p1113 (quote 1)) (strip e1112 w1114)) r1115) (if (memv t1116 (quote (vector))) (and (vector? e1112) (match (vector->list e1112) (vector-ref p1113 (quote 1)) w1114 r1115))))))))))) (match-empty (lambda (p1119 r1120) (cond ((null? p1119) r1120) ((eq? p1119 (quote any)) (cons (quote ()) r1120)) ((pair? p1119) (match-empty (car p1119) (match-empty (cdr p1119) r1120))) ((eq? p1119 (quote each-any)) (cons (quote ()) r1120)) (else (let ((t1121 (vector-ref p1119 (quote 0)))) (if (memv t1121 (quote (each))) (match-empty (vector-ref p1119 (quote 1)) r1120) (if (memv t1121 (quote (free-id atom))) r1120 (if (memv t1121 (quote (vector))) (match-empty (vector-ref p1119 (quote 1)) r1120))))))))) (match-each-any (lambda (e1122 w1123) (cond ((annotation? e1122) (match-each-any (annotation-expression e1122) w1123)) ((pair? e1122) (let ((l1124 (match-each-any (cdr e1122) w1123))) (and l1124 (cons (wrap (car e1122) w1123) l1124)))) ((null? e1122) (quote ())) ((syntax-object? e1122) (match-each-any (syntax-object-expression e1122) (join-wraps w1123 (syntax-object-wrap e1122)))) (else (quote #f))))) (match-each (lambda (e1125 p1126 w1127) (cond ((annotation? e1125) (match-each (annotation-expression e1125) p1126 w1127)) ((pair? e1125) (let ((first1128 (match (car e1125) p1126 w1127 (quote ())))) (and first1128 (let ((rest1129 (match-each (cdr e1125) p1126 w1127))) (and rest1129 (cons first1128 rest1129)))))) ((null? e1125) (quote ())) ((syntax-object? e1125) (match-each (syntax-object-expression e1125) p1126 (join-wraps w1127 (syntax-object-wrap e1125)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1130 p1131) (cond ((eq? p1131 (quote any)) (list e1130)) ((syntax-object? e1130) (match* (let ((e1132 (syntax-object-expression e1130))) (if (annotation? e1132) (annotation-expression e1132) e1132)) p1131 (syntax-object-wrap e1130) (quote ()))) (else (match* (let ((e1133 e1130)) (if (annotation? e1133) (annotation-expression e1133) e1133)) p1131 (quote (())) (quote ())))))))))
(install-global-transformer (quote with-syntax) (lambda (x1134) ((lambda (tmp1135) ((lambda (tmp1136) (if tmp1136 (apply (lambda (_1137 e11138 e21139) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11138 e21139))) tmp1136) ((lambda (tmp1141) (if tmp1141 (apply (lambda (_1142 out in e11143 e21144) (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"))))) in (quote ()) (list out (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11143 e21144))))) tmp1141) ((lambda (tmp1146) (if tmp1146 (apply (lambda (_1147 out1148 in1149 e11150 e21151) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1149) (quote ()) (list out1148 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11150 e21151))))) tmp1146) (syntax-error tmp1135))) (syntax-dispatch tmp1135 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1135 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1135 (quote (any () any . each-any))))) x1134)))
(install-global-transformer (quote syntax-rules) (lambda (x1173) ((lambda (tmp1174) ((lambda (tmp1175) (if tmp1175 (apply (lambda (_1176 k1177 keyword pattern1178 template) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k1177 (map (lambda (tmp1180 tmp1179) (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"))))) tmp1179) (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"))))) tmp1180))) template pattern1178)))))) tmp1175) (syntax-error tmp1174))) (syntax-dispatch tmp1174 (quote (any each-any . #(each ((any . any) any))))))) x1173)))
(install-global-transformer (quote let*) (lambda (x) ((lambda (tmp1191) ((lambda (tmp1192) (if (if tmp1192 (apply (lambda (let* x1193 v e1 e2) (andmap identifier? x1193)) tmp1192) (quote #f)) (apply (lambda (let*1195 x1196 v1197 e11198 e21199) (let f ((bindings (map list x1196 v1197))) (if (null? bindings) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e11198 e21199))) ((lambda (tmp1203) ((lambda (tmp1204) (if tmp1204 (apply (lambda (body binding) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding) body)) tmp1204) (syntax-error tmp1203))) (syntax-dispatch tmp1203 (quote (any any))))) (list (f (cdr bindings)) (car bindings)))))) tmp1192) (syntax-error tmp1191))) (syntax-dispatch tmp1191 (quote (any #(each (any any)) any . each-any))))) x)))
(install-global-transformer (quote do) (lambda (orig-x) ((lambda (tmp1224) ((lambda (tmp1225) (if tmp1225 (apply (lambda (_ var init step e0 e11226 c) ((lambda (tmp1227) ((lambda (tmp1228) (if tmp1228 (apply (lambda (step1229) ((lambda (tmp1230) ((lambda (tmp1231) (if tmp1231 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e0) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (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"))))) step1229))))))) tmp1231) ((lambda (tmp1235) (if tmp1235 (apply (lambda (e11236 e21237) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var init) (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"))))) e0 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11236 e21237)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c (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"))))) step1229))))))) tmp1235) (syntax-error tmp1230))) (syntax-dispatch tmp1230 (quote (any . each-any)))))) (syntax-dispatch tmp1230 (quote ())))) e11226)) tmp1228) (syntax-error tmp1227))) (syntax-dispatch tmp1227 (quote each-any)))) (map (lambda (v1244 s) ((lambda (tmp1245) ((lambda (tmp1246) (if tmp1246 (apply (lambda () v1244) tmp1246) ((lambda (tmp1247) (if tmp1247 (apply (lambda (e) e) tmp1247) ((lambda (_1248) (syntax-error orig-x)) tmp1245))) (syntax-dispatch tmp1245 (quote (any)))))) (syntax-dispatch tmp1245 (quote ())))) s)) var step))) tmp1225) (syntax-error tmp1224))) (syntax-dispatch tmp1224 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x)))
(install-global-transformer (quote quasiquote) (letrec ((quasicons (lambda (x1276 y) ((lambda (tmp) ((lambda (tmp1277) (if tmp1277 (apply (lambda (x1278 y1279) ((lambda (tmp1280) ((lambda (tmp1281) (if tmp1281 (apply (lambda (dy) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (dx) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx dy))) tmp1283) ((lambda (_1284) (if (null? dy) (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"))))) x1278) (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"))))) x1278 y1279))) tmp1282))) (syntax-dispatch tmp1282 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1278)) tmp1281) ((lambda (tmp1285) (if tmp1285 (apply (lambda (stuff) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1278 stuff))) tmp1285) ((lambda (else) (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"))))) x1278 y1279)) tmp1280))) (syntax-dispatch tmp1280 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1280 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1279)) tmp1277) (syntax-error tmp))) (syntax-dispatch tmp (quote (any any))))) (list x1276 y)))) (quasiappend (lambda (x1286 y1287) ((lambda (tmp1288) ((lambda (tmp1289) (if tmp1289 (apply (lambda (x1290 y1291) ((lambda (tmp1292) ((lambda (tmp1293) (if tmp1293 (apply (lambda () x1290) tmp1293) ((lambda (_1294) (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"))))) x1290 y1291)) tmp1292))) (syntax-dispatch tmp1292 (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"))))) ()))))) y1291)) tmp1289) (syntax-error tmp1288))) (syntax-dispatch tmp1288 (quote (any any))))) (list x1286 y1287)))) (quasivector (lambda (x1295) ((lambda (tmp1296) ((lambda (x1297) ((lambda (tmp1298) ((lambda (tmp1299) (if tmp1299 (apply (lambda (x1300) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1300))) tmp1299) ((lambda (tmp1302) (if tmp1302 (apply (lambda (x1303) (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"))))) x1303)) tmp1302) ((lambda (_1305) (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"))))) x1297)) tmp1298))) (syntax-dispatch tmp1298 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1298 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1297)) tmp1296)) x1295))) (quasi (lambda (p lev) ((lambda (tmp1306) ((lambda (tmp1307) (if tmp1307 (apply (lambda (p1308) (if (= lev (quote 0)) p1308 (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1308) (- lev (quote 1)))))) tmp1307) ((lambda (tmp1309) (if tmp1309 (apply (lambda (p1310 q) (if (= lev (quote 0)) (quasiappend p1310 (quasi q lev)) (quasicons (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1310) (- lev (quote 1)))) (quasi q lev)))) tmp1309) ((lambda (tmp1311) (if tmp1311 (apply (lambda (p1312) (quasicons (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi (list p1312) (+ lev (quote 1))))) tmp1311) ((lambda (tmp1313) (if tmp1313 (apply (lambda (p1314 q1315) (quasicons (quasi p1314 lev) (quasi q1315 lev))) tmp1313) ((lambda (tmp1316) (if tmp1316 (apply (lambda (x1317) (quasivector (quasi x1317 lev))) tmp1316) ((lambda (p1319) (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"))))) p1319)) tmp1306))) (syntax-dispatch tmp1306 (quote #(vector each-any)))))) (syntax-dispatch tmp1306 (quote (any . any)))))) (syntax-dispatch tmp1306 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1306 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1306 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p)))) (lambda (x1320) ((lambda (tmp1321) ((lambda (tmp1322) (if tmp1322 (apply (lambda (_1323 e1324) (quasi e1324 (quote 0))) tmp1322) (syntax-error tmp1321))) (syntax-dispatch tmp1321 (quote (any any))))) x1320))))
(install-global-transformer (quote include) (lambda (x) (letrec ((read-file (lambda (fn k) (let ((p1384 (open-input-file fn))) (let f ((x1385 (read p1384))) (if (eof-object? x1385) (begin (close-input-port p1384) (quote ())) (cons (datum->syntax-object k x1385) (f (read p1384))))))))) ((lambda (tmp1386) ((lambda (tmp1387) (if tmp1387 (apply (lambda (k1388 filename) (let ((fn1389 (syntax-object->datum filename))) ((lambda (tmp1390) ((lambda (tmp1391) (if tmp1391 (apply (lambda (exp) (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"))))) exp)) tmp1391) (syntax-error tmp1390))) (syntax-dispatch tmp1390 (quote each-any)))) (read-file fn1389 k1388)))) tmp1387) (syntax-error tmp1386))) (syntax-dispatch tmp1386 (quote (any any))))) x))))
(install-global-transformer (quote unquote) (lambda (x1408) ((lambda (tmp1409) ((lambda (tmp1410) (if tmp1410 (apply (lambda (_ e) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e))) tmp1410) (syntax-error tmp1409))) (syntax-dispatch tmp1409 (quote (any any))))) x1408)))
(install-global-transformer (quote unquote-splicing) (lambda (x1416) ((lambda (tmp1417) ((lambda (tmp1418) (if tmp1418 (apply (lambda (_1419 e1420) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1420))) tmp1418) (syntax-error tmp1417))) (syntax-dispatch tmp1417 (quote (any any))))) x1416)))
(install-global-transformer (quote case) (lambda (x1426) ((lambda (tmp1427) ((lambda (tmp1428) (if tmp1428 (apply (lambda (_1429 e1430 m1 m2) ((lambda (tmp1431) ((lambda (body) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1430)) body)) tmp1431)) (let f1432 ((clause m1) (clauses m2)) (if (null? clauses) ((lambda (tmp1434) ((lambda (tmp1435) (if tmp1435 (apply (lambda (e1 e2) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1 e2))) tmp1435) ((lambda (tmp1437) (if tmp1437 (apply (lambda (k1438 e11439 e21440) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1438)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11439 e21440)))) tmp1437) ((lambda (_1443) (syntax-error x1426)) tmp1434))) (syntax-dispatch tmp1434 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1434 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause) ((lambda (tmp1444) ((lambda (rest) ((lambda (tmp1445) ((lambda (tmp1446) (if tmp1446 (apply (lambda (k1447 e11448 e21449) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1447)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11448 e21449)) rest)) tmp1446) ((lambda (_1452) (syntax-error x1426)) tmp1445))) (syntax-dispatch tmp1445 (quote (each-any any . each-any))))) clause)) tmp1444)) (f1432 (car clauses) (cdr clauses))))))) tmp1428) (syntax-error tmp1427))) (syntax-dispatch tmp1427 (quote (any any any . each-any))))) x1426)))
(install-global-transformer (quote identifier-syntax) (lambda (x) ((lambda (tmp) ((lambda (tmp1482) (if tmp1482 (apply (lambda (_ e) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e)) (list (cons _ (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1482) (syntax-error tmp))) (syntax-dispatch tmp (quote (any any))))) x)))
View git blame Copy permalink