summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/psyntax-pp.scm7787
-rw-r--r--module/ice-9/psyntax.scm63
2 files changed, 4050 insertions, 3800 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index a6e35b098..e2a3d60e3 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,90 +1,97 @@
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f)
-(letrec ((and-map*17
- (lambda (f57 first56 . rest55)
- (let ((t58 (null? first56)))
- (if t58
- t58
- (if (null? rest55)
- (letrec ((andmap59
- (lambda (first60)
- (let ((x61 (car first60))
- (first62 (cdr first60)))
- (if (null? first62)
- (f57 x61)
- (if (f57 x61) (andmap59 first62) #f))))))
- (andmap59 first56))
- (letrec ((andmap63
- (lambda (first64 rest65)
- (let ((x66 (car first64))
- (xr67 (map car rest65))
- (first68 (cdr first64))
- (rest69 (map cdr rest65)))
- (if (null? first68)
- (apply f57 (cons x66 xr67))
- (if (apply f57 (cons x66 xr67))
- (andmap63 first68 rest69)
+(letrec ((and-map*2378
+ (lambda (f2418 first2417 . rest2416)
+ (let ((t2419 (null? first2417)))
+ (if t2419
+ t2419
+ (if (null? rest2416)
+ (letrec ((andmap2420
+ (lambda (first2421)
+ (let ((x2422 (car first2421))
+ (first2423 (cdr first2421)))
+ (if (null? first2423)
+ (f2418 x2422)
+ (if (f2418 x2422)
+ (andmap2420 first2423)
#f))))))
- (andmap63 first56 rest55))))))))
- (letrec ((lambda-var-list162
- (lambda (vars286)
- (letrec ((lvl287
- (lambda (vars288 ls289 w290)
- (if (pair? vars288)
- (lvl287
- (cdr vars288)
- (cons (wrap142 (car vars288) w290 #f) ls289)
- w290)
- (if (id?114 vars288)
- (cons (wrap142 vars288 w290 #f) ls289)
- (if (null? vars288)
- ls289
- (if (syntax-object?98 vars288)
- (lvl287
- (syntax-object-expression99 vars288)
- ls289
- (join-wraps133
- w290
- (syntax-object-wrap100 vars288)))
- (cons vars288 ls289))))))))
- (lvl287 vars286 (quote ()) (quote (()))))))
- (gen-var161
- (lambda (id291)
- (let ((id292 (if (syntax-object?98 id291)
- (syntax-object-expression99 id291)
- id291)))
- (gensym (symbol->string id292)))))
- (strip160
- (lambda (x293 w294)
- (if (memq (quote top) (wrap-marks117 w294))
- x293
- (letrec ((f295 (lambda (x296)
- (if (syntax-object?98 x296)
- (strip160
- (syntax-object-expression99 x296)
- (syntax-object-wrap100 x296))
- (if (pair? x296)
- (let ((a297 (f295 (car x296)))
- (d298 (f295 (cdr x296))))
- (if (if (eq? a297 (car x296))
- (eq? d298 (cdr x296))
- #f)
- x296
- (cons a297 d298)))
- (if (vector? x296)
- (let ((old299 (vector->list x296)))
- (let ((new300 (map f295 old299)))
- (if (and-map*17 eq? old299 new300)
- x296
- (list->vector new300))))
- x296))))))
- (f295 x293)))))
- (ellipsis?159
- (lambda (x301)
- (if (nonsymbol-id?113 x301)
- (free-id=?137
- x301
+ (andmap2420 first2417))
+ (letrec ((andmap2424
+ (lambda (first2425 rest2426)
+ (let ((x2427 (car first2425))
+ (xr2428 (map car rest2426))
+ (first2429 (cdr first2425))
+ (rest2430 (map cdr rest2426)))
+ (if (null? first2429)
+ (apply f2418 (cons x2427 xr2428))
+ (if (apply f2418 (cons x2427 xr2428))
+ (andmap2424 first2429 rest2430)
+ #f))))))
+ (andmap2424 first2417 rest2416))))))))
+ (letrec ((lambda-var-list2524
+ (lambda (vars2648)
+ (letrec ((lvl2649
+ (lambda (vars2650 ls2651 w2652)
+ (if (pair? vars2650)
+ (lvl2649
+ (cdr vars2650)
+ (cons (wrap2504 (car vars2650) w2652 #f)
+ ls2651)
+ w2652)
+ (if (id?2476 vars2650)
+ (cons (wrap2504 vars2650 w2652 #f) ls2651)
+ (if (null? vars2650)
+ ls2651
+ (if (syntax-object?2460 vars2650)
+ (lvl2649
+ (syntax-object-expression2461 vars2650)
+ ls2651
+ (join-wraps2495
+ w2652
+ (syntax-object-wrap2462 vars2650)))
+ (cons vars2650 ls2651))))))))
+ (lvl2649 vars2648 (quote ()) (quote (()))))))
+ (gen-var2523
+ (lambda (id2653)
+ (let ((id2654
+ (if (syntax-object?2460 id2653)
+ (syntax-object-expression2461 id2653)
+ id2653)))
+ (gensym (symbol->string id2654)))))
+ (strip2522
+ (lambda (x2655 w2656)
+ (if (memq (quote top) (wrap-marks2479 w2656))
+ x2655
+ (letrec ((f2657 (lambda (x2658)
+ (if (syntax-object?2460 x2658)
+ (strip2522
+ (syntax-object-expression2461 x2658)
+ (syntax-object-wrap2462 x2658))
+ (if (pair? x2658)
+ (let ((a2659 (f2657 (car x2658)))
+ (d2660 (f2657 (cdr x2658))))
+ (if (if (eq? a2659 (car x2658))
+ (eq? d2660 (cdr x2658))
+ #f)
+ x2658
+ (cons a2659 d2660)))
+ (if (vector? x2658)
+ (let ((old2661 (vector->list x2658)))
+ (let ((new2662 (map f2657 old2661)))
+ (if (and-map*2378
+ eq?
+ old2661
+ new2662)
+ x2658
+ (list->vector new2662))))
+ x2658))))))
+ (f2657 x2655)))))
+ (ellipsis?2521
+ (lambda (x2663)
+ (if (nonsymbol-id?2475 x2663)
+ (free-id=?2499
+ x2663
'#(syntax-object
...
((top)
@@ -192,6 +199,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -313,6 +321,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -424,6 +433,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
@@ -431,1128 +441,1172 @@
("i" "i")))
(hygiene guile)))
#f)))
- (chi-void158 (lambda () (build-void80 #f)))
- (eval-local-transformer157
- (lambda (expanded302 mod303)
- (let ((p304 (local-eval-hook77 expanded302 mod303)))
- (if (procedure? p304)
- p304
+ (chi-void2520 (lambda () (build-void2442 #f)))
+ (eval-local-transformer2519
+ (lambda (expanded2664 mod2665)
+ (let ((p2666 (local-eval-hook2438 expanded2664 mod2665)))
+ (if (procedure? p2666)
+ p2666
(syntax-violation
#f
"nonprocedure transformer"
- p304)))))
- (chi-local-syntax156
- (lambda (rec?305 e306 r307 w308 s309 mod310 k311)
- ((lambda (tmp312)
- ((lambda (tmp313)
- (if tmp313
- (apply (lambda (_314 id315 val316 e1317 e2318)
- (let ((ids319 id315))
- (if (not (valid-bound-ids?139 ids319))
+ p2666)))))
+ (chi-local-syntax2518
+ (lambda (rec?2667 e2668 r2669 w2670 s2671 mod2672 k2673)
+ ((lambda (tmp2674)
+ ((lambda (tmp2675)
+ (if tmp2675
+ (apply (lambda (_2676 id2677 val2678 e12679 e22680)
+ (let ((ids2681 id2677))
+ (if (not (valid-bound-ids?2501 ids2681))
(syntax-violation
#f
"duplicate bound keyword"
- e306)
- (let ((labels321 (gen-labels120 ids319)))
- (let ((new-w322
- (make-binding-wrap131
- ids319
- labels321
- w308)))
- (k311 (cons e1317 e2318)
- (extend-env108
- labels321
- (let ((w324 (if rec?305
- new-w322
- w308))
- (trans-r325
- (macros-only-env110
- r307)))
- (map (lambda (x326)
- (cons 'macro
- (eval-local-transformer157
- (chi150
- x326
- trans-r325
- w324
- mod310)
- mod310)))
- val316))
- r307)
- new-w322
- s309
- mod310))))))
- tmp313)
- ((lambda (_328)
+ e2668)
+ (let ((labels2683
+ (gen-labels2482 ids2681)))
+ (let ((new-w2684
+ (make-binding-wrap2493
+ ids2681
+ labels2683
+ w2670)))
+ (k2673 (cons e12679 e22680)
+ (extend-env2470
+ labels2683
+ (let ((w2686 (if rec?2667
+ new-w2684
+ w2670))
+ (trans-r2687
+ (macros-only-env2472
+ r2669)))
+ (map (lambda (x2688)
+ (cons 'macro
+ (eval-local-transformer2519
+ (chi2512
+ x2688
+ trans-r2687
+ w2686
+ mod2672)
+ mod2672)))
+ val2678))
+ r2669)
+ new-w2684
+ s2671
+ mod2672))))))
+ tmp2675)
+ ((lambda (_2690)
(syntax-violation
#f
"bad local syntax definition"
- (source-wrap143 e306 w308 s309 mod310)))
- tmp312)))
+ (source-wrap2505 e2668 w2670 s2671 mod2672)))
+ tmp2674)))
($sc-dispatch
- tmp312
+ tmp2674
'(any #(each (any any)) any . each-any))))
- e306)))
- (chi-lambda-clause155
- (lambda (e329 docstring330 c331 r332 w333 mod334 k335)
- ((lambda (tmp336)
- ((lambda (tmp337)
- (if (if tmp337
- (apply (lambda (args338 doc339 e1340 e2341)
- (if (string? (syntax->datum doc339))
- (not docstring330)
+ e2668)))
+ (chi-lambda-clause2517
+ (lambda (e2691
+ docstring2692
+ c2693
+ r2694
+ w2695
+ mod2696
+ k2697)
+ ((lambda (tmp2698)
+ ((lambda (tmp2699)
+ (if (if tmp2699
+ (apply (lambda (args2700 doc2701 e12702 e22703)
+ (if (string? (syntax->datum doc2701))
+ (not docstring2692)
#f))
- tmp337)
+ tmp2699)
#f)
- (apply (lambda (args342 doc343 e1344 e2345)
- (chi-lambda-clause155
- e329
- doc343
- (cons args342 (cons e1344 e2345))
- r332
- w333
- mod334
- k335))
- tmp337)
- ((lambda (tmp347)
- (if tmp347
- (apply (lambda (id348 e1349 e2350)
- (let ((ids351 id348))
- (if (not (valid-bound-ids?139 ids351))
+ (apply (lambda (args2704 doc2705 e12706 e22707)
+ (chi-lambda-clause2517
+ e2691
+ doc2705
+ (cons args2704 (cons e12706 e22707))
+ r2694
+ w2695
+ mod2696
+ k2697))
+ tmp2699)
+ ((lambda (tmp2709)
+ (if tmp2709
+ (apply (lambda (id2710 e12711 e22712)
+ (let ((ids2713 id2710))
+ (if (not (valid-bound-ids?2501 ids2713))
(syntax-violation
'lambda
"invalid parameter list"
- e329)
- (let ((labels353
- (gen-labels120 ids351))
- (new-vars354
- (map gen-var161 ids351)))
- (k335 (map syntax->datum ids351)
- new-vars354
- (if docstring330
- (syntax->datum docstring330)
- #f)
- (chi-body154
- (cons e1349 e2350)
- e329
- (extend-var-env109
- labels353
- new-vars354
- r332)
- (make-binding-wrap131
- ids351
- labels353
- w333)
- mod334))))))
- tmp347)
- ((lambda (tmp356)
- (if tmp356
- (apply (lambda (ids357 e1358 e2359)
- (let ((old-ids360
- (lambda-var-list162 ids357)))
- (if (not (valid-bound-ids?139
- old-ids360))
+ e2691)
+ (let ((labels2715
+ (gen-labels2482 ids2713))
+ (new-vars2716
+ (map gen-var2523 ids2713)))
+ (k2697 (map syntax->datum ids2713)
+ new-vars2716
+ (if docstring2692
+ (syntax->datum
+ docstring2692)
+ #f)
+ (chi-body2516
+ (cons e12711 e22712)
+ e2691
+ (extend-var-env2471
+ labels2715
+ new-vars2716
+ r2694)
+ (make-binding-wrap2493
+ ids2713
+ labels2715
+ w2695)
+ mod2696))))))
+ tmp2709)
+ ((lambda (tmp2718)
+ (if tmp2718
+ (apply (lambda (ids2719 e12720 e22721)
+ (let ((old-ids2722
+ (lambda-var-list2524
+ ids2719)))
+ (if (not (valid-bound-ids?2501
+ old-ids2722))
(syntax-violation
'lambda
"invalid parameter list"
- e329)
- (let ((labels361
- (gen-labels120
- old-ids360))
- (new-vars362
- (map gen-var161
- old-ids360)))
- (k335 (letrec ((f363 (lambda (ls1364
- ls2365)
- (if (null? ls1364)
- (syntax->datum
- ls2365)
- (f363 (cdr ls1364)
- (cons (syntax->datum
- (car ls1364))
- ls2365))))))
- (f363 (cdr old-ids360)
- (car old-ids360)))
- (letrec ((f366 (lambda (ls1367
- ls2368)
- (if (null? ls1367)
- ls2368
- (f366 (cdr ls1367)
- (cons (car ls1367)
- ls2368))))))
- (f366 (cdr new-vars362)
- (car new-vars362)))
- (if docstring330
- (syntax->datum
- docstring330)
- #f)
- (chi-body154
- (cons e1358 e2359)
- e329
- (extend-var-env109
- labels361
- new-vars362
- r332)
- (make-binding-wrap131
- old-ids360
- labels361
- w333)
- mod334))))))
- tmp356)
- ((lambda (_370)
+ e2691)
+ (let ((labels2723
+ (gen-labels2482
+ old-ids2722))
+ (new-vars2724
+ (map gen-var2523
+ old-ids2722)))
+ (k2697 (letrec ((f2725 (lambda (ls12726
+ ls22727)
+ (if (null? ls12726)
+ (syntax->datum
+ ls22727)
+ (f2725 (cdr ls12726)
+ (cons (syntax->datum
+ (car ls12726))
+ ls22727))))))
+ (f2725 (cdr old-ids2722)
+ (car old-ids2722)))
+ (letrec ((f2728 (lambda (ls12729
+ ls22730)
+ (if (null? ls12729)
+ ls22730
+ (f2728 (cdr ls12729)
+ (cons (car ls12729)
+ ls22730))))))
+ (f2728 (cdr new-vars2724)
+ (car new-vars2724)))
+ (if docstring2692
+ (syntax->datum
+ docstring2692)
+ #f)
+ (chi-body2516
+ (cons e12720 e22721)
+ e2691
+ (extend-var-env2471
+ labels2723
+ new-vars2724
+ r2694)
+ (make-binding-wrap2493
+ old-ids2722
+ labels2723
+ w2695)
+ mod2696))))))
+ tmp2718)
+ ((lambda (_2732)
(syntax-violation
'lambda
"bad lambda"
- e329))
- tmp336)))
+ e2691))
+ tmp2698)))
($sc-dispatch
- tmp336
+ tmp2698
'(any any . each-any)))))
($sc-dispatch
- tmp336
+ tmp2698
'(each-any any . each-any)))))
($sc-dispatch
- tmp336
+ tmp2698
'(any any any . each-any))))
- c331)))
- (chi-body154
- (lambda (body371 outer-form372 r373 w374 mod375)
- (let ((r376 (cons (quote ("placeholder" placeholder)) r373)))
- (let ((ribcage377
- (make-ribcage121
+ c2693)))
+ (chi-body2516
+ (lambda (body2733 outer-form2734 r2735 w2736 mod2737)
+ (let ((r2738 (cons (quote ("placeholder" placeholder)) r2735)))
+ (let ((ribcage2739
+ (make-ribcage2483
'()
'()
'())))
- (let ((w378 (make-wrap116
- (wrap-marks117 w374)
- (cons ribcage377 (wrap-subst118 w374)))))
- (letrec ((parse379
- (lambda (body380
- ids381
- labels382
- var-ids383
- vars384
- vals385
- bindings386)
- (if (null? body380)
+ (let ((w2740 (make-wrap2478
+ (wrap-marks2479 w2736)
+ (cons ribcage2739 (wrap-subst2480 w2736)))))
+ (letrec ((parse2741
+ (lambda (body2742
+ ids2743
+ labels2744
+ var-ids2745
+ vars2746
+ vals2747
+ bindings2748)
+ (if (null? body2742)
(syntax-violation
#f
"no expressions in body"
- outer-form372)
- (let ((e388 (cdar body380))
- (er389 (caar body380)))
+ outer-form2734)
+ (let ((e2750 (cdar body2742))
+ (er2751 (caar body2742)))
(call-with-values
(lambda ()
- (syntax-type148
- e388
- er389
+ (syntax-type2510
+ e2750
+ er2751
'(())
- (source-annotation105 er389)
- ribcage377
- mod375
+ (source-annotation2467 er2751)
+ ribcage2739
+ mod2737
#f))
- (lambda (type390
- value391
- e392
- w393
- s394
- mod395)
- (if (memv type390
+ (lambda (type2752
+ value2753
+ e2754
+ w2755
+ s2756
+ mod2757)
+ (if (memv type2752
'(define-form))
- (let ((id396 (wrap142
- value391
- w393
- mod395))
- (label397 (gen-label119)))
- (let ((var398
- (gen-var161 id396)))
+ (let ((id2758
+ (wrap2504
+ value2753
+ w2755
+ mod2757))
+ (label2759 (gen-label2481)))
+ (let ((var2760
+ (gen-var2523 id2758)))
(begin
- (extend-ribcage!130
- ribcage377
- id396
- label397)
- (parse379
- (cdr body380)
- (cons id396 ids381)
- (cons label397 labels382)
- (cons id396 var-ids383)
- (cons var398 vars384)
- (cons (cons er389
- (wrap142
- e392
- w393
- mod395))
- vals385)
+ (extend-ribcage!2492
+ ribcage2739
+ id2758
+ label2759)
+ (parse2741
+ (cdr body2742)
+ (cons id2758 ids2743)
+ (cons label2759 labels2744)
+ (cons id2758 var-ids2745)
+ (cons var2760 vars2746)
+ (cons (cons er2751
+ (wrap2504
+ e2754
+ w2755
+ mod2757))
+ vals2747)
(cons (cons 'lexical
- var398)
- bindings386)))))
- (if (memv type390
+ var2760)
+ bindings2748)))))
+ (if (memv type2752
'(define-syntax-form))
- (let ((id399 (wrap142
- value391
- w393
- mod395))
- (label400 (gen-label119)))
+ (let ((id2761
+ (wrap2504
+ value2753
+ w2755
+ mod2757))
+ (label2762
+ (gen-label2481)))
(begin
- (extend-ribcage!130
- ribcage377
- id399
- label400)
- (parse379
- (cdr body380)
- (cons id399 ids381)
- (cons label400 labels382)
- var-ids383
- vars384
- vals385
+ (extend-ribcage!2492
+ ribcage2739
+ id2761
+ label2762)
+ (parse2741
+ (cdr body2742)
+ (cons id2761 ids2743)
+ (cons label2762 labels2744)
+ var-ids2745
+ vars2746
+ vals2747
(cons (cons 'macro
- (cons er389
- (wrap142
- e392
- w393
- mod395)))
- bindings386))))
- (if (memv type390
+ (cons er2751
+ (wrap2504
+ e2754
+ w2755
+ mod2757)))
+ bindings2748))))
+ (if (memv type2752
'(begin-form))
- ((lambda (tmp401)
- ((lambda (tmp402)
- (if tmp402
- (apply (lambda (_403
- e1404)
- (parse379
- (letrec ((f405 (lambda (forms406)
- (if (null? forms406)
- (cdr body380)
- (cons (cons er389
- (wrap142
- (car forms406)
- w393
- mod395))
- (f405 (cdr forms406)))))))
- (f405 e1404))
- ids381
- labels382
- var-ids383
- vars384
- vals385
- bindings386))
- tmp402)
+ ((lambda (tmp2763)
+ ((lambda (tmp2764)
+ (if tmp2764
+ (apply (lambda (_2765
+ e12766)
+ (parse2741
+ (letrec ((f2767 (lambda (forms2768)
+ (if (null? forms2768)
+ (cdr body2742)
+ (cons (cons er2751
+ (wrap2504
+ (car forms2768)
+ w2755
+ mod2757))
+ (f2767 (cdr forms2768)))))))
+ (f2767 e12766))
+ ids2743
+ labels2744
+ var-ids2745
+ vars2746
+ vals2747
+ bindings2748))
+ tmp2764)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp401)))
+ tmp2763)))
($sc-dispatch
- tmp401
+ tmp2763
'(any . each-any))))
- e392)
- (if (memv type390
+ e2754)
+ (if (memv type2752
'(local-syntax-form))
- (chi-local-syntax156
- value391
- e392
- er389
- w393
- s394
- mod395
- (lambda (forms408
- er409
- w410
- s411
- mod412)
- (parse379
- (letrec ((f413 (lambda (forms414)
- (if (null? forms414)
- (cdr body380)
- (cons (cons er409
- (wrap142
- (car forms414)
- w410
- mod412))
- (f413 (cdr forms414)))))))
- (f413 forms408))
- ids381
- labels382
- var-ids383
- vars384
- vals385
- bindings386)))
- (if (null? ids381)
- (build-sequence93
+ (chi-local-syntax2518
+ value2753
+ e2754
+ er2751
+ w2755
+ s2756
+ mod2757
+ (lambda (forms2770
+ er2771
+ w2772
+ s2773
+ mod2774)
+ (parse2741
+ (letrec ((f2775 (lambda (forms2776)
+ (if (null? forms2776)
+ (cdr body2742)
+ (cons (cons er2771
+ (wrap2504
+ (car forms2776)
+ w2772
+ mod2774))
+ (f2775 (cdr forms2776)))))))
+ (f2775 forms2770))
+ ids2743
+ labels2744
+ var-ids2745
+ vars2746
+ vals2747
+ bindings2748)))
+ (if (null? ids2743)
+ (build-sequence2455
#f
- (map (lambda (x415)
- (chi150
- (cdr x415)
- (car x415)
+ (map (lambda (x2777)
+ (chi2512
+ (cdr x2777)
+ (car x2777)
'(())
- mod395))
- (cons (cons er389
- (source-wrap143
- e392
- w393
- s394
- mod395))
- (cdr body380))))
+ mod2757))
+ (cons (cons er2751
+ (source-wrap2505
+ e2754
+ w2755
+ s2756
+ mod2757))
+ (cdr body2742))))
(begin
- (if (not (valid-bound-ids?139
- ids381))
+ (if (not (valid-bound-ids?2501
+ ids2743))
(syntax-violation
#f
"invalid or duplicate identifier in definition"
- outer-form372))
- (letrec ((loop416
- (lambda (bs417
- er-cache418
- r-cache419)
- (if (not (null? bs417))
- (let ((b420 (car bs417)))
- (if (eq? (car b420)
+ outer-form2734))
+ (letrec ((loop2778
+ (lambda (bs2779
+ er-cache2780
+ r-cache2781)
+ (if (not (null? bs2779))
+ (let ((b2782 (car bs2779)))
+ (if (eq? (car b2782)
'macro)
- (let ((er421 (cadr b420)))
- (let ((r-cache422
- (if (eq? er421
- er-cache418)
- r-cache419
- (macros-only-env110
- er421))))
+ (let ((er2783
+ (cadr b2782)))
+ (let ((r-cache2784
+ (if (eq? er2783
+ er-cache2780)
+ r-cache2781
+ (macros-only-env2472
+ er2783))))
(begin
(set-cdr!
- b420
- (eval-local-transformer157
- (chi150
- (cddr b420)
- r-cache422
+ b2782
+ (eval-local-transformer2519
+ (chi2512
+ (cddr b2782)
+ r-cache2784
'(())
- mod395)
- mod395))
- (loop416
- (cdr bs417)
- er421
- r-cache422))))
- (loop416
- (cdr bs417)
- er-cache418
- r-cache419)))))))
- (loop416
- bindings386
+ mod2757)
+ mod2757))
+ (loop2778
+ (cdr bs2779)
+ er2783
+ r-cache2784))))
+ (loop2778
+ (cdr bs2779)
+ er-cache2780
+ r-cache2781)))))))
+ (loop2778
+ bindings2748
#f
#f))
(set-cdr!
- r376
- (extend-env108
- labels382
- bindings386
- (cdr r376)))
- (build-letrec96
+ r2738
+ (extend-env2470
+ labels2744
+ bindings2748
+ (cdr r2738)))
+ (build-letrec2458
#f
(map syntax->datum
- var-ids383)
- vars384
- (map (lambda (x423)
- (chi150
- (cdr x423)
- (car x423)
+ var-ids2745)
+ vars2746
+ (map (lambda (x2785)
+ (chi2512
+ (cdr x2785)
+ (car x2785)
'(())
- mod395))
- vals385)
- (build-sequence93
+ mod2757))
+ vals2747)
+ (build-sequence2455
#f
- (map (lambda (x424)
- (chi150
- (cdr x424)
- (car x424)
+ (map (lambda (x2786)
+ (chi2512
+ (cdr x2786)
+ (car x2786)
'(())
- mod395))
- (cons (cons er389
- (source-wrap143
- e392
- w393
- s394
- mod395))
- (cdr body380))))))))))))))))))
- (parse379
- (map (lambda (x387)
- (cons r376 (wrap142 x387 w378 mod375)))
- body371)
+ mod2757))
+ (cons (cons er2751
+ (source-wrap2505
+ e2754
+ w2755
+ s2756
+ mod2757))
+ (cdr body2742))))))))))))))))))
+ (parse2741
+ (map (lambda (x2749)
+ (cons r2738 (wrap2504 x2749 w2740 mod2737)))
+ body2733)
'()
'()
'()
'()
'()
'())))))))
- (chi-macro153
- (lambda (p425 e426 r427 w428 rib429 mod430)
- (letrec ((rebuild-macro-output431
- (lambda (x432 m433)
- (if (pair? x432)
- (cons (rebuild-macro-output431 (car x432) m433)
- (rebuild-macro-output431 (cdr x432) m433))
- (if (syntax-object?98 x432)
- (let ((w434 (syntax-object-wrap100 x432)))
- (let ((ms435 (wrap-marks117 w434))
- (s436 (wrap-subst118 w434)))
- (if (if (pair? ms435)
- (eq? (car ms435) #f)
+ (chi-macro2515
+ (lambda (p2787 e2788 r2789 w2790 rib2791 mod2792)
+ (letrec ((rebuild-macro-output2793
+ (lambda (x2794 m2795)
+ (if (pair? x2794)
+ (cons (rebuild-macro-output2793
+ (car x2794)
+ m2795)
+ (rebuild-macro-output2793
+ (cdr x2794)
+ m2795))
+ (if (syntax-object?2460 x2794)
+ (let ((w2796 (syntax-object-wrap2462 x2794)))
+ (let ((ms2797 (wrap-marks2479 w2796))
+ (s2798 (wrap-subst2480 w2796)))
+ (if (if (pair? ms2797)
+ (eq? (car ms2797) #f)
#f)
- (make-syntax-object97
- (syntax-object-expression99 x432)
- (make-wrap116
- (cdr ms435)
- (if rib429
- (cons rib429 (cdr s436))
- (cdr s436)))
- (syntax-object-module101 x432))
- (make-syntax-object97
- (syntax-object-expression99 x432)
- (make-wrap116
- (cons m433 ms435)
- (if rib429
- (cons rib429
- (cons (quote shift) s436))
- (cons (quote shift) s436)))
- (let ((pmod437
- (procedure-module p425)))
- (if pmod437
+ (make-syntax-object2459
+ (syntax-object-expression2461 x2794)
+ (make-wrap2478
+ (cdr ms2797)
+ (if rib2791
+ (cons rib2791 (cdr s2798))
+ (cdr s2798)))
+ (syntax-object-module2463 x2794))
+ (make-syntax-object2459
+ (syntax-object-expression2461 x2794)
+ (make-wrap2478
+ (cons m2795 ms2797)
+ (if rib2791
+ (cons rib2791
+ (cons (quote shift) s2798))
+ (cons (quote shift) s2798)))
+ (let ((pmod2799
+ (procedure-module p2787)))
+ (if pmod2799
(cons 'hygiene
- (module-name pmod437))
+ (module-name pmod2799))
'(hygiene guile)))))))
- (if (vector? x432)
- (let ((n438 (vector-length x432)))
- (let ((v439 (make-vector n438)))
- (letrec ((loop440
- (lambda (i441)
- (if (fx=74 i441 n438)
- (begin (if #f #f) v439)
+ (if (vector? x2794)
+ (let ((n2800 (vector-length x2794)))
+ (let ((v2801 (make-vector n2800)))
+ (letrec ((loop2802
+ (lambda (i2803)
+ (if (fx=2435 i2803 n2800)
+ (begin (if #f #f) v2801)
(begin
(vector-set!
- v439
- i441
- (rebuild-macro-output431
+ v2801
+ i2803
+ (rebuild-macro-output2793
(vector-ref
- x432
- i441)
- m433))
- (loop440
- (fx+72 i441 1)))))))
- (loop440 0))))
- (if (symbol? x432)
+ x2794
+ i2803)
+ m2795))
+ (loop2802
+ (fx+2433
+ i2803
+ 1)))))))
+ (loop2802 0))))
+ (if (symbol? x2794)
(syntax-violation
#f
"encountered raw symbol in macro output"
- (source-wrap143 e426 w428 s mod430)
- x432)
- x432)))))))
- (rebuild-macro-output431
- (p425 (wrap142 e426 (anti-mark129 w428) mod430))
+ (source-wrap2505 e2788 w2790 s mod2792)
+ x2794)
+ x2794)))))))
+ (rebuild-macro-output2793
+ (p2787 (wrap2504 e2788 (anti-mark2491 w2790) mod2792))
(string #\m)))))
- (chi-application152
- (lambda (x442 e443 r444 w445 s446 mod447)
- ((lambda (tmp448)
- ((lambda (tmp449)
- (if tmp449
- (apply (lambda (e0450 e1451)
- (build-application81
- s446
- x442
- (map (lambda (e452)
- (chi150 e452 r444 w445 mod447))
- e1451)))
- tmp449)
+ (chi-application2514
+ (lambda (x2804 e2805 r2806 w2807 s2808 mod2809)
+ ((lambda (tmp2810)
+ ((lambda (tmp2811)
+ (if tmp2811
+ (apply (lambda (e02812 e12813)
+ (build-application2443
+ s2808
+ x2804
+ (map (lambda (e2814)
+ (chi2512 e2814 r2806 w2807 mod2809))
+ e12813)))
+ tmp2811)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp448)))
- ($sc-dispatch tmp448 (quote (any . each-any)))))
- e443)))
- (chi-expr151
- (lambda (type454 value455 e456 r457 w458 s459 mod460)
- (if (memv type454 (quote (lexical)))
- (build-lexical-reference83
+ tmp2810)))
+ ($sc-dispatch tmp2810 (quote (any . each-any)))))
+ e2805)))
+ (chi-expr2513
+ (lambda (type2816
+ value2817
+ e2818
+ r2819
+ w2820
+ s2821
+ mod2822)
+ (if (memv type2816 (quote (lexical)))
+ (build-lexical-reference2445
'value
- s459
- e456
- value455)
- (if (memv type454 (quote (core core-form)))
- (value455 e456 r457 w458 s459 mod460)
- (if (memv type454 (quote (module-ref)))
+ s2821
+ e2818
+ value2817)
+ (if (memv type2816 (quote (core core-form)))
+ (value2817 e2818 r2819 w2820 s2821 mod2822)
+ (if (memv type2816 (quote (module-ref)))
(call-with-values
- (lambda () (value455 e456))
- (lambda (id461 mod462)
- (build-global-reference86 s459 id461 mod462)))
- (if (memv type454 (quote (lexical-call)))
- (chi-application152
- (build-lexical-reference83
+ (lambda () (value2817 e2818))
+ (lambda (id2823 mod2824)
+ (build-global-reference2448 s2821 id2823 mod2824)))
+ (if (memv type2816 (quote (lexical-call)))
+ (chi-application2514
+ (build-lexical-reference2445
'fun
- (source-annotation105 (car e456))
- (car e456)
- value455)
- e456
- r457
- w458
- s459
- mod460)
- (if (memv type454 (quote (global-call)))
- (chi-application152
- (build-global-reference86
- (source-annotation105 (car e456))
- (if (syntax-object?98 value455)
- (syntax-object-expression99 value455)
- value455)
- (if (syntax-object?98 value455)
- (syntax-object-module101 value455)
- mod460))
- e456
- r457
- w458
- s459
- mod460)
- (if (memv type454 (quote (constant)))
- (build-data92
- s459
- (strip160
- (source-wrap143 e456 w458 s459 mod460)
+ (source-annotation2467 (car e2818))
+ (car e2818)
+ value2817)
+ e2818
+ r2819
+ w2820
+ s2821
+ mod2822)
+ (if (memv type2816 (quote (global-call)))
+ (chi-application2514
+ (build-global-reference2448
+ (source-annotation2467 (car e2818))
+ (if (syntax-object?2460 value2817)
+ (syntax-object-expression2461 value2817)
+ value2817)
+ (if (syntax-object?2460 value2817)
+ (syntax-object-module2463 value2817)
+ mod2822))
+ e2818
+ r2819
+ w2820
+ s2821
+ mod2822)
+ (if (memv type2816 (quote (constant)))
+ (build-data2454
+ s2821
+ (strip2522
+ (source-wrap2505 e2818 w2820 s2821 mod2822)
'(())))
- (if (memv type454 (quote (global)))
- (build-global-reference86 s459 value455 mod460)
- (if (memv type454 (quote (call)))
- (chi-application152
- (chi150 (car e456) r457 w458 mod460)
- e456
- r457
- w458
- s459
- mod460)
- (if (memv type454 (quote (begin-form)))
- ((lambda (tmp463)
- ((lambda (tmp464)
- (if tmp464
- (apply (lambda (_465 e1466 e2467)
- (chi-sequence144
- (cons e1466 e2467)
- r457
- w458
- s459
- mod460))
- tmp464)
+ (if (memv type2816 (quote (global)))
+ (build-global-reference2448
+ s2821
+ value2817
+ mod2822)
+ (if (memv type2816 (quote (call)))
+ (chi-application2514
+ (chi2512 (car e2818) r2819 w2820 mod2822)
+ e2818
+ r2819
+ w2820
+ s2821
+ mod2822)
+ (if (memv type2816 (quote (begin-form)))
+ ((lambda (tmp2825)
+ ((lambda (tmp2826)
+ (if tmp2826
+ (apply (lambda (_2827 e12828 e22829)
+ (chi-sequence2506
+ (cons e12828 e22829)
+ r2819
+ w2820
+ s2821
+ mod2822))
+ tmp2826)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp463)))
+ tmp2825)))
($sc-dispatch
- tmp463
+ tmp2825
'(any any . each-any))))
- e456)
- (if (memv type454 (quote (local-syntax-form)))
- (chi-local-syntax156
- value455
- e456
- r457
- w458
- s459
- mod460
- chi-sequence144)
- (if (memv type454 (quote (eval-when-form)))
- ((lambda (tmp469)
- ((lambda (tmp470)
- (if tmp470
- (apply (lambda (_471
- x472
- e1473
- e2474)
- (let ((when-list475
- (chi-when-list147
- e456
- x472
- w458)))
+ e2818)
+ (if (memv type2816
+ '(local-syntax-form))
+ (chi-local-syntax2518
+ value2817
+ e2818
+ r2819
+ w2820
+ s2821
+ mod2822
+ chi-sequence2506)
+ (if (memv type2816 (quote (eval-when-form)))
+ ((lambda (tmp2831)
+ ((lambda (tmp2832)
+ (if tmp2832
+ (apply (lambda (_2833
+ x2834
+ e12835
+ e22836)
+ (let ((when-list2837
+ (chi-when-list2509
+ e2818
+ x2834
+ w2820)))
(if (memq 'eval
- when-list475)
- (chi-sequence144
- (cons e1473 e2474)
- r457
- w458
- s459
- mod460)
- (chi-void158))))
- tmp470)
+ when-list2837)
+ (chi-sequence2506
+ (cons e12835
+ e22836)
+ r2819
+ w2820
+ s2821
+ mod2822)
+ (chi-void2520))))
+ tmp2832)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp469)))
+ tmp2831)))
($sc-dispatch
- tmp469
+ tmp2831
'(any each-any any . each-any))))
- e456)
- (if (memv type454
+ e2818)
+ (if (memv type2816
'(define-form
define-syntax-form))
(syntax-violation
#f
"definition in expression context"
- e456
- (wrap142 value455 w458 mod460))
- (if (memv type454 (quote (syntax)))
+ e2818
+ (wrap2504 value2817 w2820 mod2822))
+ (if (memv type2816 (quote (syntax)))
(syntax-violation
#f
"reference to pattern variable outside syntax form"
- (source-wrap143
- e456
- w458
- s459
- mod460))
- (if (memv type454
+ (source-wrap2505
+ e2818
+ w2820
+ s2821
+ mod2822))
+ (if (memv type2816
'(displaced-lexical))
(syntax-violation
#f
"reference to identifier outside its scope"
- (source-wrap143
- e456
- w458
- s459
- mod460))
+ (source-wrap2505
+ e2818
+ w2820
+ s2821
+ mod2822))
(syntax-violation
#f
"unexpected syntax"
- (source-wrap143
- e456
- w458
- s459
- mod460))))))))))))))))))
- (chi150
- (lambda (e478 r479 w480 mod481)
+ (source-wrap2505
+ e2818
+ w2820
+ s2821
+ mod2822))))))))))))))))))
+ (chi2512
+ (lambda (e2840 r2841 w2842 mod2843)
(call-with-values
(lambda ()
- (syntax-type148
- e478
- r479
- w480
- (source-annotation105 e478)
+ (syntax-type2510
+ e2840
+ r2841
+ w2842
+ (source-annotation2467 e2840)
#f
- mod481
+ mod2843
#f))
- (lambda (type482 value483 e484 w485 s486 mod487)
- (chi-expr151
- type482
- value483
- e484
- r479
- w485
- s486
- mod487)))))
- (chi-top149
- (lambda (e488 r489 w490 m491 esew492 mod493)
+ (lambda (type2844 value2845 e2846 w2847 s2848 mod2849)
+ (chi-expr2513
+ type2844
+ value2845
+ e2846
+ r2841
+ w2847
+ s2848
+ mod2849)))))
+ (chi-top2511
+ (lambda (e2850 r2851 w2852 m2853 esew2854 mod2855)
(call-with-values
(lambda ()
- (syntax-type148
- e488
- r489
- w490
- (source-annotation105 e488)
+ (syntax-type2510
+ e2850
+ r2851
+ w2852
+ (source-annotation2467 e2850)
#f
- mod493
+ mod2855
#f))
- (lambda (type501 value502 e503 w504 s505 mod506)
- (if (memv type501 (quote (begin-form)))
- ((lambda (tmp507)
- ((lambda (tmp508)
- (if tmp508
- (apply (lambda (_509) (chi-void158)) tmp508)
- ((lambda (tmp510)
- (if tmp510
- (apply (lambda (_511 e1512 e2513)
- (chi-top-sequence145
- (cons e1512 e2513)
- r489
- w504
- s505
- m491
- esew492
- mod506))
- tmp510)
+ (lambda (type2863 value2864 e2865 w2866 s2867 mod2868)
+ (if (memv type2863 (quote (begin-form)))
+ ((lambda (tmp2869)
+ ((lambda (tmp2870)
+ (if tmp2870
+ (apply (lambda (_2871) (chi-void2520)) tmp2870)
+ ((lambda (tmp2872)
+ (if tmp2872
+ (apply (lambda (_2873 e12874 e22875)
+ (chi-top-sequence2507
+ (cons e12874 e22875)
+ r2851
+ w2866
+ s2867
+ m2853
+ esew2854
+ mod2868))
+ tmp2872)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp507)))
+ tmp2869)))
($sc-dispatch
- tmp507
+ tmp2869
'(any any . each-any)))))
- ($sc-dispatch tmp507 (quote (any)))))
- e503)
- (if (memv type501 (quote (local-syntax-form)))
- (chi-local-syntax156
- value502
- e503
- r489
- w504
- s505
- mod506
- (lambda (body515 r516 w517 s518 mod519)
- (chi-top-sequence145
- body515
- r516
- w517
- s518
- m491
- esew492
- mod519)))
- (if (memv type501 (quote (eval-when-form)))
- ((lambda (tmp520)
- ((lambda (tmp521)
- (if tmp521
- (apply (lambda (_522 x523 e1524 e2525)
- (let ((when-list526
- (chi-when-list147
- e503
- x523
- w504))
- (body527 (cons e1524 e2525)))
- (if (eq? m491 (quote e))
+ ($sc-dispatch tmp2869 (quote (any)))))
+ e2865)
+ (if (memv type2863 (quote (local-syntax-form)))
+ (chi-local-syntax2518
+ value2864
+ e2865
+ r2851
+ w2866
+ s2867
+ mod2868
+ (lambda (body2877 r2878 w2879 s2880 mod2881)
+ (chi-top-sequence2507
+ body2877
+ r2878
+ w2879
+ s2880
+ m2853
+ esew2854
+ mod2881)))
+ (if (memv type2863 (quote (eval-when-form)))
+ ((lambda (tmp2882)
+ ((lambda (tmp2883)
+ (if tmp2883
+ (apply (lambda (_2884 x2885 e12886 e22887)
+ (let ((when-list2888
+ (chi-when-list2509
+ e2865
+ x2885
+ w2866))
+ (body2889
+ (cons e12886 e22887)))
+ (if (eq? m2853 (quote e))
(if (memq 'eval
- when-list526)
- (chi-top-sequence145
- body527
- r489
- w504
- s505
+ when-list2888)
+ (chi-top-sequence2507
+ body2889
+ r2851
+ w2866
+ s2867
'e
'(eval)
- mod506)
- (chi-void158))
+ mod2868)
+ (chi-void2520))
(if (memq 'load
- when-list526)
- (if (let ((t530 (memq 'compile
- when-list526)))
- (if t530
- t530
- (if (eq? m491
+ when-list2888)
+ (if (let ((t2892 (memq 'compile
+ when-list2888)))
+ (if t2892
+ t2892
+ (if (eq? m2853
'c&e)
(memq 'eval
- when-list526)
+ when-list2888)
#f)))
- (chi-top-sequence145
- body527
- r489
- w504
- s505
+ (chi-top-sequence2507
+ body2889
+ r2851
+ w2866
+ s2867
'c&e
'(compile load)
- mod506)
- (if (memq m491
+ mod2868)
+ (if (memq m2853
'(c c&e))
- (chi-top-sequence145
- body527
- r489
- w504
- s505
+ (chi-top-sequence2507
+ body2889
+ r2851
+ w2866
+ s2867
'c
'(load)
- mod506)
- (chi-void158)))
- (if (let ((t531 (memq 'compile
- when-list526)))
- (if t531
- t531
- (if (eq? m491
+ mod2868)
+ (chi-void2520)))
+ (if (let ((t2893 (memq 'compile
+ when-list2888)))
+ (if t2893
+ t2893
+ (if (eq? m2853
'c&e)
(memq 'eval
- when-list526)
+ when-list2888)
#f)))
(begin
- (top-level-eval-hook76
- (chi-top-sequence145
- body527
- r489
- w504
- s505
+ (top-level-eval-hook2437
+ (chi-top-sequence2507
+ body2889
+ r2851
+ w2866
+ s2867
'e
'(eval)
- mod506)
- mod506)
- (chi-void158))
- (chi-void158))))))
- tmp521)
+ mod2868)
+ mod2868)
+ (chi-void2520))
+ (chi-void2520))))))
+ tmp2883)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp520)))
+ tmp2882)))
($sc-dispatch
- tmp520
+ tmp2882
'(any each-any any . each-any))))
- e503)
- (if (memv type501 (quote (define-syntax-form)))
- (let ((n532 (id-var-name136 value502 w504))
- (r533 (macros-only-env110 r489)))
- (if (memv m491 (quote (c)))
- (if (memq (quote compile) esew492)
- (let ((e534 (chi-install-global146
- n532
- (chi150
- e503
- r533
- w504
- mod506))))
+ e2865)
+ (if (memv type2863 (quote (define-syntax-form)))
+ (let ((n2894 (id-var-name2498 value2864 w2866))
+ (r2895 (macros-only-env2472 r2851)))
+ (if (memv m2853 (quote (c)))
+ (if (memq (quote compile) esew2854)
+ (let ((e2896 (chi-install-global2508
+ n2894
+ (chi2512
+ e2865
+ r2895
+ w2866
+ mod2868))))
(begin
- (top-level-eval-hook76 e534 mod506)
- (if (memq (quote load) esew492)
- e534
- (chi-void158))))
- (if (memq (quote load) esew492)
- (chi-install-global146
- n532
- (chi150 e503 r533 w504 mod506))
- (chi-void158)))
- (if (memv m491 (quote (c&e)))
- (let ((e535 (chi-install-global146
- n532
- (chi150
- e503
- r533
- w504
- mod506))))
+ (top-level-eval-hook2437 e2896 mod2868)
+ (if (memq (quote load) esew2854)
+ e2896
+ (chi-void2520))))
+ (if (memq (quote load) esew2854)
+ (chi-install-global2508
+ n2894
+ (chi2512 e2865 r2895 w2866 mod2868))
+ (chi-void2520)))
+ (if (memv m2853 (quote (c&e)))
+ (let ((e2897 (chi-install-global2508
+ n2894
+ (chi2512
+ e2865
+ r2895
+ w2866
+ mod2868))))
(begin
- (top-level-eval-hook76 e535 mod506)
- e535))
+ (top-level-eval-hook2437 e2897 mod2868)
+ e2897))
(begin
- (if (memq (quote eval) esew492)
- (top-level-eval-hook76
- (chi-install-global146
- n532
- (chi150 e503 r533 w504 mod506))
- mod506))
- (chi-void158)))))
- (if (memv type501 (quote (define-form)))
- (let ((n536 (id-var-name136 value502 w504)))
- (let ((type537
- (binding-type106
- (lookup111 n536 r489 mod506))))
- (if (memv type537
+ (if (memq (quote eval) esew2854)
+ (top-level-eval-hook2437
+ (chi-install-global2508
+ n2894
+ (chi2512 e2865 r2895 w2866 mod2868))
+ mod2868))
+ (chi-void2520)))))
+ (if (memv type2863 (quote (define-form)))
+ (let ((n2898 (id-var-name2498 value2864 w2866)))
+ (let ((type2899
+ (binding-type2468
+ (lookup2473 n2898 r2851 mod2868))))
+ (if (memv type2899
'(global core macro module-ref))
(begin
(if (if (not (module-local-variable
(current-module)
- n536))
+ n2898))
(current-module)
#f)
(module-define!
(current-module)
- n536
+ n2898
#f))
- (let ((x538 (build-global-definition89
- s505
- n536
- (chi150
- e503
- r489
- w504
- mod506))))
+ (let ((x2900 (build-global-definition2451
+ s2867
+ n2898
+ (chi2512
+ e2865
+ r2851
+ w2866
+ mod2868))))
(begin
- (if (eq? m491 (quote c&e))
- (top-level-eval-hook76 x538 mod506))
- x538)))
- (if (memv type537
+ (if (eq? m2853 (quote c&e))
+ (top-level-eval-hook2437
+ x2900
+ mod2868))
+ x2900)))
+ (if (memv type2899
'(displaced-lexical))
(syntax-violation
#f
"identifier out of context"
- e503
- (wrap142 value502 w504 mod506))
+ e2865
+ (wrap2504 value2864 w2866 mod2868))
(syntax-violation
#f
"cannot define keyword at top level"
- e503
- (wrap142 value502 w504 mod506))))))
- (let ((x539 (chi-expr151
- type501
- value502
- e503
- r489
- w504
- s505
- mod506)))
+ e2865
+ (wrap2504 value2864 w2866 mod2868))))))
+ (let ((x2901 (chi-expr2513
+ type2863
+ value2864
+ e2865
+ r2851
+ w2866
+ s2867
+ mod2868)))
(begin
- (if (eq? m491 (quote c&e))
- (top-level-eval-hook76 x539 mod506))
- x539)))))))))))
- (syntax-type148
- (lambda (e540 r541 w542 s543 rib544 mod545 for-car?546)
- (if (symbol? e540)
- (let ((n547 (id-var-name136 e540 w542)))
- (let ((b548 (lookup111 n547 r541 mod545)))
- (let ((type549 (binding-type106 b548)))
- (if (memv type549 (quote (lexical)))
+ (if (eq? m2853 (quote c&e))
+ (top-level-eval-hook2437 x2901 mod2868))
+ x2901)))))))))))
+ (syntax-type2510
+ (lambda (e2902
+ r2903
+ w2904
+ s2905
+ rib2906
+ mod2907
+ for-car?2908)
+ (if (symbol? e2902)
+ (let ((n2909 (id-var-name2498 e2902 w2904)))
+ (let ((b2910 (lookup2473 n2909 r2903 mod2907)))
+ (let ((type2911 (binding-type2468 b2910)))
+ (if (memv type2911 (quote (lexical)))
(values
- type549
- (binding-value107 b548)
- e540
- w542
- s543
- mod545)
- (if (memv type549 (quote (global)))
- (values type549 n547 e540 w542 s543 mod545)
- (if (memv type549 (quote (macro)))
- (if for-car?546
+ type2911
+ (binding-value2469 b2910)
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (if (memv type2911 (quote (global)))
+ (values type2911 n2909 e2902 w2904 s2905 mod2907)
+ (if (memv type2911 (quote (macro)))
+ (if for-car?2908
(values
- type549
- (binding-value107 b548)
- e540
- w542
- s543
- mod545)
- (syntax-type148
- (chi-macro153
- (binding-value107 b548)
- e540
- r541
- w542
- rib544
- mod545)
- r541
+ type2911
+ (binding-value2469 b2910)
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (syntax-type2510
+ (chi-macro2515
+ (binding-value2469 b2910)
+ e2902
+ r2903
+ w2904
+ rib2906
+ mod2907)
+ r2903
'(())
- s543
- rib544
- mod545
+ s2905
+ rib2906
+ mod2907
#f))
(values
- type549
- (binding-value107 b548)
- e540
- w542
- s543
- mod545)))))))
- (if (pair? e540)
- (let ((first550 (car e540)))
+ type2911
+ (binding-value2469 b2910)
+ e2902
+ w2904
+ s2905
+ mod2907)))))))
+ (if (pair? e2902)
+ (let ((first2912 (car e2902)))
(call-with-values
(lambda ()
- (syntax-type148
- first550
- r541
- w542
- s543
- rib544
- mod545
+ (syntax-type2510
+ first2912
+ r2903
+ w2904
+ s2905
+ rib2906
+ mod2907
#t))
- (lambda (ftype551 fval552 fe553 fw554 fs555 fmod556)
- (if (memv ftype551 (quote (lexical)))
+ (lambda (ftype2913
+ fval2914
+ fe2915
+ fw2916
+ fs2917
+ fmod2918)
+ (if (memv ftype2913 (quote (lexical)))
(values
'lexical-call
- fval552
- e540
- w542
- s543
- mod545)
- (if (memv ftype551 (quote (global)))
+ fval2914
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (if (memv ftype2913 (quote (global)))
(values
'global-call
- (make-syntax-object97 fval552 w542 fmod556)
- e540
- w542
- s543
- mod545)
- (if (memv ftype551 (quote (macro)))
- (syntax-type148
- (chi-macro153
- fval552
- e540
- r541
- w542
- rib544
- mod545)
- r541
+ (make-syntax-object2459 fval2914 w2904 fmod2918)
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (if (memv ftype2913 (quote (macro)))
+ (syntax-type2510
+ (chi-macro2515
+ fval2914
+ e2902
+ r2903
+ w2904
+ rib2906
+ mod2907)
+ r2903
'(())
- s543
- rib544
- mod545
- for-car?546)
- (if (memv ftype551 (quote (module-ref)))
+ s2905
+ rib2906
+ mod2907
+ for-car?2908)
+ (if (memv ftype2913 (quote (module-ref)))
(call-with-values
- (lambda () (fval552 e540))
- (lambda (sym557 mod558)
- (syntax-type148
- sym557
- r541
- w542
- s543
- rib544
- mod558
- for-car?546)))
- (if (memv ftype551 (quote (core)))
+ (lambda () (fval2914 e2902))
+ (lambda (sym2919 mod2920)
+ (syntax-type2510
+ sym2919
+ r2903
+ w2904
+ s2905
+ rib2906
+ mod2920
+ for-car?2908)))
+ (if (memv ftype2913 (quote (core)))
(values
'core-form
- fval552
- e540
- w542
- s543
- mod545)
- (if (memv ftype551 (quote (local-syntax)))
+ fval2914
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (if (memv ftype2913 (quote (local-syntax)))
(values
'local-syntax-form
- fval552
- e540
- w542
- s543
- mod545)
- (if (memv ftype551 (quote (begin)))
+ fval2914
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (if (memv ftype2913 (quote (begin)))
(values
'begin-form
#f
- e540
- w542
- s543
- mod545)
- (if (memv ftype551 (quote (eval-when)))
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (if (memv ftype2913 (quote (eval-when)))
(values
'eval-when-form
#f
- e540
- w542
- s543
- mod545)
- (if (memv ftype551 (quote (define)))
- ((lambda (tmp559)
- ((lambda (tmp560)
- (if (if tmp560
- (apply (lambda (_561
- name562
- val563)
- (id?114
- name562))
- tmp560)
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (if (memv ftype2913 (quote (define)))
+ ((lambda (tmp2921)
+ ((lambda (tmp2922)
+ (if (if tmp2922
+ (apply (lambda (_2923
+ name2924
+ val2925)
+ (id?2476
+ name2924))
+ tmp2922)
#f)
- (apply (lambda (_564
- name565
- val566)
+ (apply (lambda (_2926
+ name2927
+ val2928)
(values
'define-form
- name565
- val566
- w542
- s543
- mod545))
- tmp560)
- ((lambda (tmp567)
- (if (if tmp567
- (apply (lambda (_568
- name569
- args570
- e1571
- e2572)
- (if (id?114
- name569)
- (valid-bound-ids?139
- (lambda-var-list162
- args570))
+ name2927
+ val2928
+ w2904
+ s2905
+ mod2907))
+ tmp2922)
+ ((lambda (tmp2929)
+ (if (if tmp2929
+ (apply (lambda (_2930
+ name2931
+ args2932
+ e12933
+ e22934)
+ (if (id?2476
+ name2931)
+ (valid-bound-ids?2501
+ (lambda-var-list2524
+ args2932))
#f))
- tmp567)
+ tmp2929)
#f)
- (apply (lambda (_573
- name574
- args575
- e1576
- e2577)
+ (apply (lambda (_2935
+ name2936
+ args2937
+ e12938
+ e22939)
(values
'define-form
- (wrap142
- name574
- w542
- mod545)
+ (wrap2504
+ name2936
+ w2904
+ mod2907)
(cons '#(syntax-object
lambda
((top)
@@ -1742,6 +1796,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -1863,6 +1918,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -1974,6 +2030,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -1984,32 +2041,32 @@
"i")))
(hygiene
guile))
- (wrap142
- (cons args575
- (cons e1576
- e2577))
- w542
- mod545))
+ (wrap2504
+ (cons args2937
+ (cons e12938
+ e22939))
+ w2904
+ mod2907))
'(())
- s543
- mod545))
- tmp567)
- ((lambda (tmp579)
- (if (if tmp579
- (apply (lambda (_580
- name581)
- (id?114
- name581))
- tmp579)
+ s2905
+ mod2907))
+ tmp2929)
+ ((lambda (tmp2941)
+ (if (if tmp2941
+ (apply (lambda (_2942
+ name2943)
+ (id?2476
+ name2943))
+ tmp2941)
#f)
- (apply (lambda (_582
- name583)
+ (apply (lambda (_2944
+ name2945)
(values
'define-form
- (wrap142
- name583
- w542
- mod545)
+ (wrap2504
+ name2945
+ w2904
+ mod2907)
'(#(syntax-object
if
((top)
@@ -2190,6 +2247,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -2311,6 +2369,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -2422,6 +2481,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -2612,6 +2672,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -2733,6 +2794,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -2844,6 +2906,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -3034,6 +3097,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -3155,6 +3219,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -3266,6 +3331,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -3277,463 +3343,102 @@
(hygiene
guile)))
'(())
- s543
- mod545))
- tmp579)
+ s2905
+ mod2907))
+ tmp2941)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp559)))
+ tmp2921)))
($sc-dispatch
- tmp559
+ tmp2921
'(any any)))))
($sc-dispatch
- tmp559
+ tmp2921
'(any (any . any)
any
.
each-any)))))
($sc-dispatch
- tmp559
+ tmp2921
'(any any any))))
- e540)
- (if (memv ftype551
+ e2902)
+ (if (memv ftype2913
'(define-syntax))
- ((lambda (tmp584)
- ((lambda (tmp585)
- (if (if tmp585
- (apply (lambda (_586
- name587
- val588)
- (id?114
- name587))
- tmp585)
+ ((lambda (tmp2946)
+ ((lambda (tmp2947)
+ (if (if tmp2947
+ (apply (lambda (_2948
+ name2949
+ val2950)
+ (id?2476
+ name2949))
+ tmp2947)
#f)
- (apply (lambda (_589
- name590
- val591)
+ (apply (lambda (_2951
+ name2952
+ val2953)
(values
'define-syntax-form
- name590
- val591
- w542
- s543
- mod545))
- tmp585)
+ name2952
+ val2953
+ w2904
+ s2905
+ mod2907))
+ tmp2947)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp584)))
+ tmp2946)))
($sc-dispatch
- tmp584
+ tmp2946
'(any any any))))
- e540)
+ e2902)
(values
'call
#f
- e540
- w542
- s543
- mod545))))))))))))))
- (if (syntax-object?98 e540)
- (syntax-type148
- (syntax-object-expression99 e540)
- r541
- (join-wraps133 w542 (syntax-object-wrap100 e540))
- s543
- rib544
- (let ((t592 (syntax-object-module101 e540)))
- (if t592 t592 mod545))
- for-car?546)
- (if (self-evaluating? e540)
+ e2902
+ w2904
+ s2905
+ mod2907))))))))))))))
+ (if (syntax-object?2460 e2902)
+ (syntax-type2510
+ (syntax-object-expression2461 e2902)
+ r2903
+ (join-wraps2495
+ w2904
+ (syntax-object-wrap2462 e2902))
+ s2905
+ rib2906
+ (let ((t2954 (syntax-object-module2463 e2902)))
+ (if t2954 t2954 mod2907))
+ for-car?2908)
+ (if (self-evaluating? e2902)
(values
'constant
#f
- e540
- w542
- s543
- mod545)
- (values (quote other) #f e540 w542 s543 mod545)))))))
- (chi-when-list147
- (lambda (e593 when-list594 w595)
- (letrec ((f596 (lambda (when-list597 situations598)
- (if (null? when-list597)
- situations598
- (f596 (cdr when-list597)
- (cons (let ((x599 (car when-list597)))
- (if (free-id=?137
- x599
- '#(syntax-object
- compile
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage
- #(f
- when-list
- situations)
- #((top)
- (top)
- (top))
- #("i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(e when-list w)
- #((top)
- (top)
- (top))
- #("i" "i" "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- 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
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda
- build-global-definition
- maybe-name-value!
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- build-void
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- *mode*
- noexpand)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- (define-structure
- and-map*)
- ((top) (top))
- ("i" "i")))
- (hygiene guile)))
- 'compile
- (if (free-id=?137
- x599
+ e2902
+ w2904
+ s2905
+ mod2907)
+ (values
+ 'other
+ #f
+ e2902
+ w2904
+ s2905
+ mod2907)))))))
+ (chi-when-list2509
+ (lambda (e2955 when-list2956 w2957)
+ (letrec ((f2958 (lambda (when-list2959 situations2960)
+ (if (null? when-list2959)
+ situations2960
+ (f2958 (cdr when-list2959)
+ (cons (let ((x2961 (car when-list2959)))
+ (if (free-id=?2499
+ x2961
'#(syntax-object
- load
+ compile
((top)
#(ribcage () () ())
#(ribcage () () ())
@@ -3859,6 +3564,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -3980,6 +3686,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -4091,6 +3798,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -4098,11 +3806,11 @@
((top) (top))
("i" "i")))
(hygiene guile)))
- 'load
- (if (free-id=?137
- x599
+ 'compile
+ (if (free-id=?2499
+ x2961
'#(syntax-object
- eval
+ load
((top)
#(ribcage
()
@@ -4245,6 +3953,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -4366,6 +4075,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -4477,6 +4187,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -4484,1570 +4195,2077 @@
((top) (top))
("i" "i")))
(hygiene guile)))
- 'eval
- (syntax-violation
- 'eval-when
- "invalid situation"
- e593
- (wrap142
- x599
- w595
- #f))))))
- situations598))))))
- (f596 when-list594 (quote ())))))
- (chi-install-global146
- (lambda (name600 e601)
- (build-global-definition89
+ 'load
+ (if (free-id=?2499
+ x2961
+ '#(syntax-object
+ eval
+ ((top)
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ when-list
+ situations)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ when-list
+ w)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ 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
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top) (top))
+ ("i" "i")))
+ (hygiene
+ guile)))
+ 'eval
+ (syntax-violation
+ 'eval-when
+ "invalid situation"
+ e2955
+ (wrap2504
+ x2961
+ w2957
+ #f))))))
+ situations2960))))))
+ (f2958 when-list2956 (quote ())))))
+ (chi-install-global2508
+ (lambda (name2962 e2963)
+ (build-global-definition2451
#f
- name600
- (if (let ((v602 (module-variable (current-module) name600)))
- (if v602
- (if (variable-bound? v602)
- (if (macro? (variable-ref v602))
- (not (eq? (macro-type (variable-ref v602))
+ name2962
+ (if (let ((v2964 (module-variable (current-module) name2962)))
+ (if v2964
+ (if (variable-bound? v2964)
+ (if (macro? (variable-ref v2964))
+ (not (eq? (macro-type (variable-ref v2964))
'syncase-macro))
#f)
#f)
#f))
- (build-application81
+ (build-application2443
#f
- (build-primref91
+ (build-primref2453
#f
'make-extended-syncase-macro)
- (list (build-application81
+ (list (build-application2443
#f
- (build-primref91 #f (quote module-ref))
- (list (build-application81
+ (build-primref2453 #f (quote module-ref))
+ (list (build-application2443
#f
- (build-primref91
+ (build-primref2453
#f
'current-module)
'())
- (build-data92 #f name600)))
- (build-data92 #f (quote macro))
- e601))
- (build-application81
+ (build-data2454 #f name2962)))
+ (build-data2454 #f (quote macro))
+ e2963))
+ (build-application2443
#f
- (build-primref91 #f (quote make-syncase-macro))
- (list (build-data92 #f (quote macro)) e601))))))
- (chi-top-sequence145
- (lambda (body603 r604 w605 s606 m607 esew608 mod609)
- (build-sequence93
- s606
- (letrec ((dobody610
- (lambda (body611 r612 w613 m614 esew615 mod616)
- (if (null? body611)
+ (build-primref2453 #f (quote make-syncase-macro))
+ (list (build-data2454 #f (quote macro)) e2963))))))
+ (chi-top-sequence2507
+ (lambda (body2965
+ r2966
+ w2967
+ s2968
+ m2969
+ esew2970
+ mod2971)
+ (build-sequence2455
+ s2968
+ (letrec ((dobody2972
+ (lambda (body2973
+ r2974
+ w2975
+ m2976
+ esew2977
+ mod2978)
+ (if (null? body2973)
'()
- (let ((first617
- (chi-top149
- (car body611)
- r612
- w613
- m614
- esew615
- mod616)))
- (cons first617
- (dobody610
- (cdr body611)
- r612
- w613
- m614
- esew615
- mod616)))))))
- (dobody610 body603 r604 w605 m607 esew608 mod609)))))
- (chi-sequence144
- (lambda (body618 r619 w620 s621 mod622)
- (build-sequence93
- s621
- (letrec ((dobody623
- (lambda (body624 r625 w626 mod627)
- (if (null? body624)
+ (let ((first2979
+ (chi-top2511
+ (car body2973)
+ r2974
+ w2975
+ m2976
+ esew2977
+ mod2978)))
+ (cons first2979
+ (dobody2972
+ (cdr body2973)
+ r2974
+ w2975
+ m2976
+ esew2977
+ mod2978)))))))
+ (dobody2972
+ body2965
+ r2966
+ w2967
+ m2969
+ esew2970
+ mod2971)))))
+ (chi-sequence2506
+ (lambda (body2980 r2981 w2982 s2983 mod2984)
+ (build-sequence2455
+ s2983
+ (letrec ((dobody2985
+ (lambda (body2986 r2987 w2988 mod2989)
+ (if (null? body2986)
'()
- (let ((first628
- (chi150
- (car body624)
- r625
- w626
- mod627)))
- (cons first628
- (dobody623
- (cdr body624)
- r625
- w626
- mod627)))))))
- (dobody623 body618 r619 w620 mod622)))))
- (source-wrap143
- (lambda (x629 w630 s631 defmod632)
+ (let ((first2990
+ (chi2512
+ (car body2986)
+ r2987
+ w2988
+ mod2989)))
+ (cons first2990
+ (dobody2985
+ (cdr body2986)
+ r2987
+ w2988
+ mod2989)))))))
+ (dobody2985 body2980 r2981 w2982 mod2984)))))
+ (source-wrap2505
+ (lambda (x2991 w2992 s2993 defmod2994)
(begin
- (if (if s631 (pair? x629) #f)
- (set-source-properties! x629 s631))
- (wrap142 x629 w630 defmod632))))
- (wrap142
- (lambda (x633 w634 defmod635)
- (if (if (null? (wrap-marks117 w634))
- (null? (wrap-subst118 w634))
+ (if (if s2993 (pair? x2991) #f)
+ (set-source-properties! x2991 s2993))
+ (wrap2504 x2991 w2992 defmod2994))))
+ (wrap2504
+ (lambda (x2995 w2996 defmod2997)
+ (if (if (null? (wrap-marks2479 w2996))
+ (null? (wrap-subst2480 w2996))
#f)
- x633
- (if (syntax-object?98 x633)
- (make-syntax-object97
- (syntax-object-expression99 x633)
- (join-wraps133 w634 (syntax-object-wrap100 x633))
- (syntax-object-module101 x633))
- (if (null? x633)
- x633
- (make-syntax-object97 x633 w634 defmod635))))))
- (bound-id-member?141
- (lambda (x636 list637)
- (if (not (null? list637))
- (let ((t638 (bound-id=?138 x636 (car list637))))
- (if t638
- t638
- (bound-id-member?141 x636 (cdr list637))))
+ x2995
+ (if (syntax-object?2460 x2995)
+ (make-syntax-object2459
+ (syntax-object-expression2461 x2995)
+ (join-wraps2495
+ w2996
+ (syntax-object-wrap2462 x2995))
+ (syntax-object-module2463 x2995))
+ (if (null? x2995)
+ x2995
+ (make-syntax-object2459 x2995 w2996 defmod2997))))))
+ (bound-id-member?2503
+ (lambda (x2998 list2999)
+ (if (not (null? list2999))
+ (let ((t3000 (bound-id=?2500 x2998 (car list2999))))
+ (if t3000
+ t3000
+ (bound-id-member?2503 x2998 (cdr list2999))))
#f)))
- (distinct-bound-ids?140
- (lambda (ids639)
- (letrec ((distinct?640
- (lambda (ids641)
- (let ((t642 (null? ids641)))
- (if t642
- t642
- (if (not (bound-id-member?141
- (car ids641)
- (cdr ids641)))
- (distinct?640 (cdr ids641))
+ (distinct-bound-ids?2502
+ (lambda (ids3001)
+ (letrec ((distinct?3002
+ (lambda (ids3003)
+ (let ((t3004 (null? ids3003)))
+ (if t3004
+ t3004
+ (if (not (bound-id-member?2503
+ (car ids3003)
+ (cdr ids3003)))
+ (distinct?3002 (cdr ids3003))
#f))))))
- (distinct?640 ids639))))
- (valid-bound-ids?139
- (lambda (ids643)
- (if (letrec ((all-ids?644
- (lambda (ids645)
- (let ((t646 (null? ids645)))
- (if t646
- t646
- (if (id?114 (car ids645))
- (all-ids?644 (cdr ids645))
+ (distinct?3002 ids3001))))
+ (valid-bound-ids?2501
+ (lambda (ids3005)
+ (if (letrec ((all-ids?3006
+ (lambda (ids3007)
+ (let ((t3008 (null? ids3007)))
+ (if t3008
+ t3008
+ (if (id?2476 (car ids3007))
+ (all-ids?3006 (cdr ids3007))
#f))))))
- (all-ids?644 ids643))
- (distinct-bound-ids?140 ids643)
+ (all-ids?3006 ids3005))
+ (distinct-bound-ids?2502 ids3005)
#f)))
- (bound-id=?138
- (lambda (i647 j648)
- (if (if (syntax-object?98 i647)
- (syntax-object?98 j648)
+ (bound-id=?2500
+ (lambda (i3009 j3010)
+ (if (if (syntax-object?2460 i3009)
+ (syntax-object?2460 j3010)
#f)
- (if (eq? (syntax-object-expression99 i647)
- (syntax-object-expression99 j648))
- (same-marks?135
- (wrap-marks117 (syntax-object-wrap100 i647))
- (wrap-marks117 (syntax-object-wrap100 j648)))
+ (if (eq? (syntax-object-expression2461 i3009)
+ (syntax-object-expression2461 j3010))
+ (same-marks?2497
+ (wrap-marks2479 (syntax-object-wrap2462 i3009))
+ (wrap-marks2479 (syntax-object-wrap2462 j3010)))
#f)
- (eq? i647 j648))))
- (free-id=?137
- (lambda (i649 j650)
- (if (eq? (let ((x651 i649))
- (if (syntax-object?98 x651)
- (syntax-object-expression99 x651)
- x651))
- (let ((x652 j650))
- (if (syntax-object?98 x652)
- (syntax-object-expression99 x652)
- x652)))
- (eq? (id-var-name136 i649 (quote (())))
- (id-var-name136 j650 (quote (()))))
+ (eq? i3009 j3010))))
+ (free-id=?2499
+ (lambda (i3011 j3012)
+ (if (eq? (let ((x3013 i3011))
+ (if (syntax-object?2460 x3013)
+ (syntax-object-expression2461 x3013)
+ x3013))
+ (let ((x3014 j3012))
+ (if (syntax-object?2460 x3014)
+ (syntax-object-expression2461 x3014)
+ x3014)))
+ (eq? (id-var-name2498 i3011 (quote (())))
+ (id-var-name2498 j3012 (quote (()))))
#f)))
- (id-var-name136
- (lambda (id653 w654)
- (letrec ((search-vector-rib657
- (lambda (sym663
- subst664
- marks665
- symnames666
- ribcage667)
- (let ((n668 (vector-length symnames666)))
- (letrec ((f669 (lambda (i670)
- (if (fx=74 i670 n668)
- (search655
- sym663
- (cdr subst664)
- marks665)
- (if (if (eq? (vector-ref
- symnames666
- i670)
- sym663)
- (same-marks?135
- marks665
- (vector-ref
- (ribcage-marks124
- ribcage667)
- i670))
- #f)
- (values
- (vector-ref
- (ribcage-labels125
- ribcage667)
- i670)
- marks665)
- (f669 (fx+72 i670 1)))))))
- (f669 0)))))
- (search-list-rib656
- (lambda (sym671
- subst672
- marks673
- symnames674
- ribcage675)
- (letrec ((f676 (lambda (symnames677 i678)
- (if (null? symnames677)
- (search655
- sym671
- (cdr subst672)
- marks673)
- (if (if (eq? (car symnames677)
- sym671)
- (same-marks?135
- marks673
- (list-ref
- (ribcage-marks124
- ribcage675)
- i678))
- #f)
- (values
- (list-ref
- (ribcage-labels125
- ribcage675)
- i678)
- marks673)
- (f676 (cdr symnames677)
- (fx+72 i678 1)))))))
- (f676 symnames674 0))))
- (search655
- (lambda (sym679 subst680 marks681)
- (if (null? subst680)
- (values #f marks681)
- (let ((fst682 (car subst680)))
- (if (eq? fst682 (quote shift))
- (search655
- sym679
- (cdr subst680)
- (cdr marks681))
- (let ((symnames683
- (ribcage-symnames123 fst682)))
- (if (vector? symnames683)
- (search-vector-rib657
- sym679
- subst680
- marks681
- symnames683
- fst682)
- (search-list-rib656
- sym679
- subst680
- marks681
- symnames683
- fst682)))))))))
- (if (symbol? id653)
- (let ((t684 (call-with-values
- (lambda ()
- (search655
- id653
- (wrap-subst118 w654)
- (wrap-marks117 w654)))
- (lambda (x686 . ignore685) x686))))
- (if t684 t684 id653))
- (if (syntax-object?98 id653)
- (let ((id687 (syntax-object-expression99 id653))
- (w1688 (syntax-object-wrap100 id653)))
- (let ((marks689
- (join-marks134
- (wrap-marks117 w654)
- (wrap-marks117 w1688))))
+ (id-var-name2498
+ (lambda (id3015 w3016)
+ (letrec ((search-vector-rib3019
+ (lambda (sym3025
+ subst3026
+ marks3027
+ symnames3028
+ ribcage3029)
+ (let ((n3030 (vector-length symnames3028)))
+ (letrec ((f3031 (lambda (i3032)
+ (if (fx=2435 i3032 n3030)
+ (search3017
+ sym3025
+ (cdr subst3026)
+ marks3027)
+ (if (if (eq? (vector-ref
+ symnames3028
+ i3032)
+ sym3025)
+ (same-marks?2497
+ marks3027
+ (vector-ref
+ (ribcage-marks2486
+ ribcage3029)
+ i3032))
+ #f)
+ (values
+ (vector-ref
+ (ribcage-labels2487
+ ribcage3029)
+ i3032)
+ marks3027)
+ (f3031 (fx+2433
+ i3032
+ 1)))))))
+ (f3031 0)))))
+ (search-list-rib3018
+ (lambda (sym3033
+ subst3034
+ marks3035
+ symnames3036
+ ribcage3037)
+ (letrec ((f3038 (lambda (symnames3039 i3040)
+ (if (null? symnames3039)
+ (search3017
+ sym3033
+ (cdr subst3034)
+ marks3035)
+ (if (if (eq? (car symnames3039)
+ sym3033)
+ (same-marks?2497
+ marks3035
+ (list-ref
+ (ribcage-marks2486
+ ribcage3037)
+ i3040))
+ #f)
+ (values
+ (list-ref
+ (ribcage-labels2487
+ ribcage3037)
+ i3040)
+ marks3035)
+ (f3038 (cdr symnames3039)
+ (fx+2433
+ i3040
+ 1)))))))
+ (f3038 symnames3036 0))))
+ (search3017
+ (lambda (sym3041 subst3042 marks3043)
+ (if (null? subst3042)
+ (values #f marks3043)
+ (let ((fst3044 (car subst3042)))
+ (if (eq? fst3044 (quote shift))
+ (search3017
+ sym3041
+ (cdr subst3042)
+ (cdr marks3043))
+ (let ((symnames3045
+ (ribcage-symnames2485 fst3044)))
+ (if (vector? symnames3045)
+ (search-vector-rib3019
+ sym3041
+ subst3042
+ marks3043
+ symnames3045
+ fst3044)
+ (search-list-rib3018
+ sym3041
+ subst3042
+ marks3043
+ symnames3045
+ fst3044)))))))))
+ (if (symbol? id3015)
+ (let ((t3046 (call-with-values
+ (lambda ()
+ (search3017
+ id3015
+ (wrap-subst2480 w3016)
+ (wrap-marks2479 w3016)))
+ (lambda (x3048 . ignore3047) x3048))))
+ (if t3046 t3046 id3015))
+ (if (syntax-object?2460 id3015)
+ (let ((id3049 (syntax-object-expression2461 id3015))
+ (w13050 (syntax-object-wrap2462 id3015)))
+ (let ((marks3051
+ (join-marks2496
+ (wrap-marks2479 w3016)
+ (wrap-marks2479 w13050))))
(call-with-values
(lambda ()
- (search655 id687 (wrap-subst118 w654) marks689))
- (lambda (new-id690 marks691)
- (let ((t692 new-id690))
- (if t692
- t692
- (let ((t693 (call-with-values
- (lambda ()
- (search655
- id687
- (wrap-subst118 w1688)
- marks691))
- (lambda (x695 . ignore694)
- x695))))
- (if t693 t693 id687))))))))
+ (search3017
+ id3049
+ (wrap-subst2480 w3016)
+ marks3051))
+ (lambda (new-id3052 marks3053)
+ (let ((t3054 new-id3052))
+ (if t3054
+ t3054
+ (let ((t3055 (call-with-values
+ (lambda ()
+ (search3017
+ id3049
+ (wrap-subst2480 w13050)
+ marks3053))
+ (lambda (x3057 . ignore3056)
+ x3057))))
+ (if t3055 t3055 id3049))))))))
(syntax-violation
'id-var-name
"invalid id"
- id653))))))
- (same-marks?135
- (lambda (x696 y697)
- (let ((t698 (eq? x696 y697)))
- (if t698
- t698
- (if (not (null? x696))
- (if (not (null? y697))
- (if (eq? (car x696) (car y697))
- (same-marks?135 (cdr x696) (cdr y697))
+ id3015))))))
+ (same-marks?2497
+ (lambda (x3058 y3059)
+ (let ((t3060 (eq? x3058 y3059)))
+ (if t3060
+ t3060
+ (if (not (null? x3058))
+ (if (not (null? y3059))
+ (if (eq? (car x3058) (car y3059))
+ (same-marks?2497 (cdr x3058) (cdr y3059))
#f)
#f)
#f)))))
- (join-marks134
- (lambda (m1699 m2700)
- (smart-append132 m1699 m2700)))
- (join-wraps133
- (lambda (w1701 w2702)
- (let ((m1703 (wrap-marks117 w1701))
- (s1704 (wrap-subst118 w1701)))
- (if (null? m1703)
- (if (null? s1704)
- w2702
- (make-wrap116
- (wrap-marks117 w2702)
- (smart-append132 s1704 (wrap-subst118 w2702))))
- (make-wrap116
- (smart-append132 m1703 (wrap-marks117 w2702))
- (smart-append132 s1704 (wrap-subst118 w2702)))))))
- (smart-append132
- (lambda (m1705 m2706)
- (if (null? m2706) m1705 (append m1705 m2706))))
- (make-binding-wrap131
- (lambda (ids707 labels708 w709)
- (if (null? ids707)
- w709
- (make-wrap116
- (wrap-marks117 w709)
- (cons (let ((labelvec710 (list->vector labels708)))
- (let ((n711 (vector-length labelvec710)))
- (let ((symnamevec712 (make-vector n711))
- (marksvec713 (make-vector n711)))
+ (join-marks2496
+ (lambda (m13061 m23062)
+ (smart-append2494 m13061 m23062)))
+ (join-wraps2495
+ (lambda (w13063 w23064)
+ (let ((m13065 (wrap-marks2479 w13063))
+ (s13066 (wrap-subst2480 w13063)))
+ (if (null? m13065)
+ (if (null? s13066)
+ w23064
+ (make-wrap2478
+ (wrap-marks2479 w23064)
+ (smart-append2494 s13066 (wrap-subst2480 w23064))))
+ (make-wrap2478
+ (smart-append2494 m13065 (wrap-marks2479 w23064))
+ (smart-append2494 s13066 (wrap-subst2480 w23064)))))))
+ (smart-append2494
+ (lambda (m13067 m23068)
+ (if (null? m23068) m13067 (append m13067 m23068))))
+ (make-binding-wrap2493
+ (lambda (ids3069 labels3070 w3071)
+ (if (null? ids3069)
+ w3071
+ (make-wrap2478
+ (wrap-marks2479 w3071)
+ (cons (let ((labelvec3072 (list->vector labels3070)))
+ (let ((n3073 (vector-length labelvec3072)))
+ (let ((symnamevec3074 (make-vector n3073))
+ (marksvec3075 (make-vector n3073)))
(begin
- (letrec ((f714 (lambda (ids715 i716)
- (if (not (null? ids715))
- (call-with-values
- (lambda ()
- (id-sym-name&marks115
- (car ids715)
- w709))
- (lambda (symname717
- marks718)
- (begin
- (vector-set!
- symnamevec712
- i716
- symname717)
- (vector-set!
- marksvec713
- i716
- marks718)
- (f714 (cdr ids715)
- (fx+72 i716
- 1)))))))))
- (f714 ids707 0))
- (make-ribcage121
- symnamevec712
- marksvec713
- labelvec710)))))
- (wrap-subst118 w709))))))
- (extend-ribcage!130
- (lambda (ribcage719 id720 label721)
+ (letrec ((f3076 (lambda (ids3077 i3078)
+ (if (not (null? ids3077))
+ (call-with-values
+ (lambda ()
+ (id-sym-name&marks2477
+ (car ids3077)
+ w3071))
+ (lambda (symname3079
+ marks3080)
+ (begin
+ (vector-set!
+ symnamevec3074
+ i3078
+ symname3079)
+ (vector-set!
+ marksvec3075
+ i3078
+ marks3080)
+ (f3076 (cdr ids3077)
+ (fx+2433
+ i3078
+ 1)))))))))
+ (f3076 ids3069 0))
+ (make-ribcage2483
+ symnamevec3074
+ marksvec3075
+ labelvec3072)))))
+ (wrap-subst2480 w3071))))))
+ (extend-ribcage!2492
+ (lambda (ribcage3081 id3082 label3083)
(begin
- (set-ribcage-symnames!126
- ribcage719
- (cons (syntax-object-expression99 id720)
- (ribcage-symnames123 ribcage719)))
- (set-ribcage-marks!127
- ribcage719
- (cons (wrap-marks117 (syntax-object-wrap100 id720))
- (ribcage-marks124 ribcage719)))
- (set-ribcage-labels!128
- ribcage719
- (cons label721 (ribcage-labels125 ribcage719))))))
- (anti-mark129
- (lambda (w722)
- (make-wrap116
- (cons #f (wrap-marks117 w722))
- (cons (quote shift) (wrap-subst118 w722)))))
- (set-ribcage-labels!128
- (lambda (x723 update724)
- (vector-set! x723 3 update724)))
- (set-ribcage-marks!127
- (lambda (x725 update726)
- (vector-set! x725 2 update726)))
- (set-ribcage-symnames!126
- (lambda (x727 update728)
- (vector-set! x727 1 update728)))
- (ribcage-labels125
- (lambda (x729) (vector-ref x729 3)))
- (ribcage-marks124
- (lambda (x730) (vector-ref x730 2)))
- (ribcage-symnames123
- (lambda (x731) (vector-ref x731 1)))
- (ribcage?122
- (lambda (x732)
- (if (vector? x732)
- (if (= (vector-length x732) 4)
- (eq? (vector-ref x732 0) (quote ribcage))
+ (set-ribcage-symnames!2488
+ ribcage3081
+ (cons (syntax-object-expression2461 id3082)
+ (ribcage-symnames2485 ribcage3081)))
+ (set-ribcage-marks!2489
+ ribcage3081
+ (cons (wrap-marks2479 (syntax-object-wrap2462 id3082))
+ (ribcage-marks2486 ribcage3081)))
+ (set-ribcage-labels!2490
+ ribcage3081
+ (cons label3083 (ribcage-labels2487 ribcage3081))))))
+ (anti-mark2491
+ (lambda (w3084)
+ (make-wrap2478
+ (cons #f (wrap-marks2479 w3084))
+ (cons (quote shift) (wrap-subst2480 w3084)))))
+ (set-ribcage-labels!2490
+ (lambda (x3085 update3086)
+ (vector-set! x3085 3 update3086)))
+ (set-ribcage-marks!2489
+ (lambda (x3087 update3088)
+ (vector-set! x3087 2 update3088)))
+ (set-ribcage-symnames!2488
+ (lambda (x3089 update3090)
+ (vector-set! x3089 1 update3090)))
+ (ribcage-labels2487
+ (lambda (x3091) (vector-ref x3091 3)))
+ (ribcage-marks2486
+ (lambda (x3092) (vector-ref x3092 2)))
+ (ribcage-symnames2485
+ (lambda (x3093) (vector-ref x3093 1)))
+ (ribcage?2484
+ (lambda (x3094)
+ (if (vector? x3094)
+ (if (= (vector-length x3094) 4)
+ (eq? (vector-ref x3094 0) (quote ribcage))
#f)
#f)))
- (make-ribcage121
- (lambda (symnames733 marks734 labels735)
+ (make-ribcage2483
+ (lambda (symnames3095 marks3096 labels3097)
(vector
'ribcage
- symnames733
- marks734
- labels735)))
- (gen-labels120
- (lambda (ls736)
- (if (null? ls736)
+ symnames3095
+ marks3096
+ labels3097)))
+ (gen-labels2482
+ (lambda (ls3098)
+ (if (null? ls3098)
'()
- (cons (gen-label119) (gen-labels120 (cdr ls736))))))
- (gen-label119 (lambda () (string #\i)))
- (wrap-subst118 cdr)
- (wrap-marks117 car)
- (make-wrap116 cons)
- (id-sym-name&marks115
- (lambda (x737 w738)
- (if (syntax-object?98 x737)
+ (cons (gen-label2481)
+ (gen-labels2482 (cdr ls3098))))))
+ (gen-label2481 (lambda () (string #\i)))
+ (wrap-subst2480 cdr)
+ (wrap-marks2479 car)
+ (make-wrap2478 cons)
+ (id-sym-name&marks2477
+ (lambda (x3099 w3100)
+ (if (syntax-object?2460 x3099)
(values
- (syntax-object-expression99 x737)
- (join-marks134
- (wrap-marks117 w738)
- (wrap-marks117 (syntax-object-wrap100 x737))))
- (values x737 (wrap-marks117 w738)))))
- (id?114
- (lambda (x739)
- (if (symbol? x739)
+ (syntax-object-expression2461 x3099)
+ (join-marks2496
+ (wrap-marks2479 w3100)
+ (wrap-marks2479 (syntax-object-wrap2462 x3099))))
+ (values x3099 (wrap-marks2479 w3100)))))
+ (id?2476
+ (lambda (x3101)
+ (if (symbol? x3101)
#t
- (if (syntax-object?98 x739)
- (symbol? (syntax-object-expression99 x739))
+ (if (syntax-object?2460 x3101)
+ (symbol? (syntax-object-expression2461 x3101))
#f))))
- (nonsymbol-id?113
- (lambda (x740)
- (if (syntax-object?98 x740)
- (symbol? (syntax-object-expression99 x740))
+ (nonsymbol-id?2475
+ (lambda (x3102)
+ (if (syntax-object?2460 x3102)
+ (symbol? (syntax-object-expression2461 x3102))
#f)))
- (global-extend112
- (lambda (type741 sym742 val743)
- (put-global-definition-hook78
- sym742
- type741
- val743)))
- (lookup111
- (lambda (x744 r745 mod746)
- (let ((t747 (assq x744 r745)))
- (if t747
- (cdr t747)
- (if (symbol? x744)
- (let ((t748 (get-global-definition-hook79 x744 mod746)))
- (if t748 t748 (quote (global))))
+ (global-extend2474
+ (lambda (type3103 sym3104 val3105)
+ (put-global-definition-hook2439
+ sym3104
+ type3103
+ val3105)))
+ (lookup2473
+ (lambda (x3106 r3107 mod3108)
+ (let ((t3109 (assq x3106 r3107)))
+ (if t3109
+ (cdr t3109)
+ (if (symbol? x3106)
+ (let ((t3110 (get-global-definition-hook2440
+ x3106
+ mod3108)))
+ (if t3110 t3110 (quote (global))))
'(displaced-lexical))))))
- (macros-only-env110
- (lambda (r749)
- (if (null? r749)
+ (macros-only-env2472
+ (lambda (r3111)
+ (if (null? r3111)
'()
- (let ((a750 (car r749)))
- (if (eq? (cadr a750) (quote macro))
- (cons a750 (macros-only-env110 (cdr r749)))
- (macros-only-env110 (cdr r749)))))))
- (extend-var-env109
- (lambda (labels751 vars752 r753)
- (if (null? labels751)
- r753
- (extend-var-env109
- (cdr labels751)
- (cdr vars752)
- (cons (cons (car labels751)
- (cons (quote lexical) (car vars752)))
- r753)))))
- (extend-env108
- (lambda (labels754 bindings755 r756)
- (if (null? labels754)
- r756
- (extend-env108
- (cdr labels754)
- (cdr bindings755)
- (cons (cons (car labels754) (car bindings755))
- r756)))))
- (binding-value107 cdr)
- (binding-type106 car)
- (source-annotation105
- (lambda (x757)
- (if (syntax-object?98 x757)
- (source-annotation105
- (syntax-object-expression99 x757))
- (if (pair? x757)
- (let ((props758 (source-properties x757)))
- (if (pair? props758) props758 #f))
+ (let ((a3112 (car r3111)))
+ (if (eq? (cadr a3112) (quote macro))
+ (cons a3112 (macros-only-env2472 (cdr r3111)))
+ (macros-only-env2472 (cdr r3111)))))))
+ (extend-var-env2471
+ (lambda (labels3113 vars3114 r3115)
+ (if (null? labels3113)
+ r3115
+ (extend-var-env2471
+ (cdr labels3113)
+ (cdr vars3114)
+ (cons (cons (car labels3113)
+ (cons (quote lexical) (car vars3114)))
+ r3115)))))
+ (extend-env2470
+ (lambda (labels3116 bindings3117 r3118)
+ (if (null? labels3116)
+ r3118
+ (extend-env2470
+ (cdr labels3116)
+ (cdr bindings3117)
+ (cons (cons (car labels3116) (car bindings3117))
+ r3118)))))
+ (binding-value2469 cdr)
+ (binding-type2468 car)
+ (source-annotation2467
+ (lambda (x3119)
+ (if (syntax-object?2460 x3119)
+ (source-annotation2467
+ (syntax-object-expression2461 x3119))
+ (if (pair? x3119)
+ (let ((props3120 (source-properties x3119)))
+ (if (pair? props3120) props3120 #f))
#f))))
- (set-syntax-object-module!104
- (lambda (x759 update760)
- (vector-set! x759 3 update760)))
- (set-syntax-object-wrap!103
- (lambda (x761 update762)
- (vector-set! x761 2 update762)))
- (set-syntax-object-expression!102
- (lambda (x763 update764)
- (vector-set! x763 1 update764)))
- (syntax-object-module101
- (lambda (x765) (vector-ref x765 3)))
- (syntax-object-wrap100
- (lambda (x766) (vector-ref x766 2)))
- (syntax-object-expression99
- (lambda (x767) (vector-ref x767 1)))
- (syntax-object?98
- (lambda (x768)
- (if (vector? x768)
- (if (= (vector-length x768) 4)
- (eq? (vector-ref x768 0) (quote syntax-object))
+ (set-syntax-object-module!2466
+ (lambda (x3121 update3122)
+ (vector-set! x3121 3 update3122)))
+ (set-syntax-object-wrap!2465
+ (lambda (x3123 update3124)
+ (vector-set! x3123 2 update3124)))
+ (set-syntax-object-expression!2464
+ (lambda (x3125 update3126)
+ (vector-set! x3125 1 update3126)))
+ (syntax-object-module2463
+ (lambda (x3127) (vector-ref x3127 3)))
+ (syntax-object-wrap2462
+ (lambda (x3128) (vector-ref x3128 2)))
+ (syntax-object-expression2461
+ (lambda (x3129) (vector-ref x3129 1)))
+ (syntax-object?2460
+ (lambda (x3130)
+ (if (vector? x3130)
+ (if (= (vector-length x3130) 4)
+ (eq? (vector-ref x3130 0) (quote syntax-object))
#f)
#f)))
- (make-syntax-object97
- (lambda (expression769 wrap770 module771)
+ (make-syntax-object2459
+ (lambda (expression3131 wrap3132 module3133)
(vector
'syntax-object
- expression769
- wrap770
- module771)))
- (build-letrec96
- (lambda (src772 ids773 vars774 val-exps775 body-exp776)
- (if (null? vars774)
- body-exp776
- (let ((atom-key777 (fluid-ref *mode*71)))
- (if (memv atom-key777 (quote (c)))
+ expression3131
+ wrap3132
+ module3133)))
+ (build-letrec2458
+ (lambda (src3134
+ ids3135
+ vars3136
+ val-exps3137
+ body-exp3138)
+ (if (null? vars3136)
+ body-exp3138
+ (let ((atom-key3139 (fluid-ref *mode*2432)))
+ (if (memv atom-key3139 (quote (c)))
(begin
- (for-each maybe-name-value!88 ids773 val-exps775)
+ (for-each
+ maybe-name-value!2450
+ ids3135
+ val-exps3137)
((@ (language tree-il) make-letrec)
- src772
- ids773
- vars774
- val-exps775
- body-exp776))
- (list 'letrec
- (map list vars774 val-exps775)
- body-exp776))))))
- (build-named-let95
- (lambda (src778 ids779 vars780 val-exps781 body-exp782)
- (let ((f783 (car vars780))
- (f-name784 (car ids779))
- (vars785 (cdr vars780))
- (ids786 (cdr ids779)))
- (let ((atom-key787 (fluid-ref *mode*71)))
- (if (memv atom-key787 (quote (c)))
- (let ((proc788
- (build-lambda90
- src778
- ids786
- vars785
+ src3134
+ ids3135
+ vars3136
+ val-exps3137
+ body-exp3138))
+ (decorate-source2441
+ (list 'letrec
+ (map list vars3136 val-exps3137)
+ body-exp3138)
+ src3134))))))
+ (build-named-let2457
+ (lambda (src3140
+ ids3141
+ vars3142
+ val-exps3143
+ body-exp3144)
+ (let ((f3145 (car vars3142))
+ (f-name3146 (car ids3141))
+ (vars3147 (cdr vars3142))
+ (ids3148 (cdr ids3141)))
+ (let ((atom-key3149 (fluid-ref *mode*2432)))
+ (if (memv atom-key3149 (quote (c)))
+ (let ((proc3150
+ (build-lambda2452
+ src3140
+ ids3148
+ vars3147
#f
- body-exp782)))
+ body-exp3144)))
(begin
- (maybe-name-value!88 f-name784 proc788)
- (for-each maybe-name-value!88 ids786 val-exps781)
+ (maybe-name-value!2450 f-name3146 proc3150)
+ (for-each
+ maybe-name-value!2450
+ ids3148
+ val-exps3143)
((@ (language tree-il) make-letrec)
- src778
- (list f-name784)
- (list f783)
- (list proc788)
- (build-application81
- src778
- (build-lexical-reference83
+ src3140
+ (list f-name3146)
+ (list f3145)
+ (list proc3150)
+ (build-application2443
+ src3140
+ (build-lexical-reference2445
'fun
- src778
- f-name784
- f783)
- val-exps781))))
- (list 'let
- f783
- (map list vars785 val-exps781)
- body-exp782))))))
- (build-let94
- (lambda (src789 ids790 vars791 val-exps792 body-exp793)
- (if (null? vars791)
- body-exp793
- (let ((atom-key794 (fluid-ref *mode*71)))
- (if (memv atom-key794 (quote (c)))
+ src3140
+ f-name3146
+ f3145)
+ val-exps3143))))
+ (decorate-source2441
+ (list 'let
+ f3145
+ (map list vars3147 val-exps3143)
+ body-exp3144)
+ src3140))))))
+ (build-let2456
+ (lambda (src3151
+ ids3152
+ vars3153
+ val-exps3154
+ body-exp3155)
+ (if (null? vars3153)
+ body-exp3155
+ (let ((atom-key3156 (fluid-ref *mode*2432)))
+ (if (memv atom-key3156 (quote (c)))
(begin
- (for-each maybe-name-value!88 ids790 val-exps792)
+ (for-each
+ maybe-name-value!2450
+ ids3152
+ val-exps3154)
((@ (language tree-il) make-let)
- src789
- ids790
- vars791
- val-exps792
- body-exp793))
- (list 'let
- (map list vars791 val-exps792)
- body-exp793))))))
- (build-sequence93
- (lambda (src795 exps796)
- (if (null? (cdr exps796))
- (car exps796)
- (let ((atom-key797 (fluid-ref *mode*71)))
- (if (memv atom-key797 (quote (c)))
+ src3151
+ ids3152
+ vars3153
+ val-exps3154
+ body-exp3155))
+ (decorate-source2441
+ (list 'let
+ (map list vars3153 val-exps3154)
+ body-exp3155)
+ src3151))))))
+ (build-sequence2455
+ (lambda (src3157 exps3158)
+ (if (null? (cdr exps3158))
+ (car exps3158)
+ (let ((atom-key3159 (fluid-ref *mode*2432)))
+ (if (memv atom-key3159 (quote (c)))
((@ (language tree-il) make-sequence)
- src795
- exps796)
- (cons (quote begin) exps796))))))
- (build-data92
- (lambda (src798 exp799)
- (let ((atom-key800 (fluid-ref *mode*71)))
- (if (memv atom-key800 (quote (c)))
- ((@ (language tree-il) make-const) src798 exp799)
- (if (if (self-evaluating? exp799)
- (not (vector? exp799))
- #f)
- exp799
- (list (quote quote) exp799))))))
- (build-primref91
- (lambda (src801 name802)
+ src3157
+ exps3158)
+ (decorate-source2441
+ (cons (quote begin) exps3158)
+ src3157))))))
+ (build-data2454
+ (lambda (src3160 exp3161)
+ (let ((atom-key3162 (fluid-ref *mode*2432)))
+ (if (memv atom-key3162 (quote (c)))
+ ((@ (language tree-il) make-const)
+ src3160
+ exp3161)
+ (decorate-source2441
+ (if (if (self-evaluating? exp3161)
+ (not (vector? exp3161))
+ #f)
+ exp3161
+ (list (quote quote) exp3161))
+ src3160)))))
+ (build-primref2453
+ (lambda (src3163 name3164)
(if (equal?
(module-name (current-module))
'(guile))
- (let ((atom-key803 (fluid-ref *mode*71)))
- (if (memv atom-key803 (quote (c)))
+ (let ((atom-key3165 (fluid-ref *mode*2432)))
+ (if (memv atom-key3165 (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- src801
- name802)
- name802))
- (let ((atom-key804 (fluid-ref *mode*71)))
- (if (memv atom-key804 (quote (c)))
+ src3163
+ name3164)
+ (decorate-source2441 name3164 src3163)))
+ (let ((atom-key3166 (fluid-ref *mode*2432)))
+ (if (memv atom-key3166 (quote (c)))
((@ (language tree-il) make-module-ref)
- src801
+ src3163
'(guile)
- name802
+ name3164
#f)
- (list (quote @@) (quote (guile)) name802))))))
- (build-lambda90
- (lambda (src805 ids806 vars807 docstring808 exp809)
- (let ((atom-key810 (fluid-ref *mode*71)))
- (if (memv atom-key810 (quote (c)))
+ (decorate-source2441
+ (list (quote @@) (quote (guile)) name3164)
+ src3163))))))
+ (build-lambda2452
+ (lambda (src3167 ids3168 vars3169 docstring3170 exp3171)
+ (let ((atom-key3172 (fluid-ref *mode*2432)))
+ (if (memv atom-key3172 (quote (c)))
((@ (language tree-il) make-lambda)
- src805
- ids806
- vars807
- (if docstring808
- (list (cons (quote documentation) docstring808))
+ src3167
+ ids3168
+ vars3169
+ (if docstring3170
+ (list (cons (quote documentation) docstring3170))
'())
- exp809)
- (cons 'lambda
- (cons vars807
- (append
- (if docstring808
- (list docstring808)
- '())
- (list exp809))))))))
- (build-global-definition89
- (lambda (source811 var812 exp813)
- (let ((atom-key814 (fluid-ref *mode*71)))
- (if (memv atom-key814 (quote (c)))
+ exp3171)
+ (decorate-source2441
+ (cons 'lambda
+ (cons vars3169
+ (append
+ (if docstring3170
+ (list docstring3170)
+ '())
+ (list exp3171))))
+ src3167)))))
+ (build-global-definition2451
+ (lambda (source3173 var3174 exp3175)
+ (let ((atom-key3176 (fluid-ref *mode*2432)))
+ (if (memv atom-key3176 (quote (c)))
(begin
- (maybe-name-value!88 var812 exp813)
+ (maybe-name-value!2450 var3174 exp3175)
((@ (language tree-il) make-toplevel-define)
- source811
- var812
- exp813))
- (list (quote define) var812 exp813)))))
- (maybe-name-value!88
- (lambda (name815 val816)
- (if ((@ (language tree-il) lambda?) val816)
- (let ((meta817
- ((@ (language tree-il) lambda-meta) val816)))
- (if (not (assq (quote name) meta817))
+ source3173
+ var3174
+ exp3175))
+ (decorate-source2441
+ (list (quote define) var3174 exp3175)
+ source3173)))))
+ (maybe-name-value!2450
+ (lambda (name3177 val3178)
+ (if ((@ (language tree-il) lambda?) val3178)
+ (let ((meta3179
+ ((@ (language tree-il) lambda-meta) val3178)))
+ (if (not (assq (quote name) meta3179))
((setter (@ (language tree-il) lambda-meta))
- val816
- (acons (quote name) name815 meta817)))))))
- (build-global-assignment87
- (lambda (source818 var819 exp820 mod821)
- (analyze-variable85
- mod821
- var819
- (lambda (mod822 var823 public?824)
- (let ((atom-key825 (fluid-ref *mode*71)))
- (if (memv atom-key825 (quote (c)))
+ val3178
+ (acons (quote name) name3177 meta3179)))))))
+ (build-global-assignment2449
+ (lambda (source3180 var3181 exp3182 mod3183)
+ (analyze-variable2447
+ mod3183
+ var3181
+ (lambda (mod3184 var3185 public?3186)
+ (let ((atom-key3187 (fluid-ref *mode*2432)))
+ (if (memv atom-key3187 (quote (c)))
((@ (language tree-il) make-module-set)
- source818
- mod822
- var823
- public?824
- exp820)
- (list 'set!
- (list (if public?824 (quote @) (quote @@))
- mod822
- var823)
- exp820))))
- (lambda (var826)
- (let ((atom-key827 (fluid-ref *mode*71)))
- (if (memv atom-key827 (quote (c)))
+ source3180
+ mod3184
+ var3185
+ public?3186
+ exp3182)
+ (decorate-source2441
+ (list 'set!
+ (list (if public?3186 (quote @) (quote @@))
+ mod3184
+ var3185)
+ exp3182)
+ source3180))))
+ (lambda (var3188)
+ (let ((atom-key3189 (fluid-ref *mode*2432)))
+ (if (memv atom-key3189 (quote (c)))
((@ (language tree-il) make-toplevel-set)
- source818
- var826
- exp820)
- (list (quote set!) var826 exp820)))))))
- (build-global-reference86
- (lambda (source828 var829 mod830)
- (analyze-variable85
- mod830
- var829
- (lambda (mod831 var832 public?833)
- (let ((atom-key834 (fluid-ref *mode*71)))
- (if (memv atom-key834 (quote (c)))
+ source3180
+ var3188
+ exp3182)
+ (decorate-source2441
+ (list (quote set!) var3188 exp3182)
+ source3180)))))))
+ (build-global-reference2448
+ (lambda (source3190 var3191 mod3192)
+ (analyze-variable2447
+ mod3192
+ var3191
+ (lambda (mod3193 var3194 public?3195)
+ (let ((atom-key3196 (fluid-ref *mode*2432)))
+ (if (memv atom-key3196 (quote (c)))
((@ (language tree-il) make-module-ref)
- source828
- mod831
- var832
- public?833)
- (list (if public?833 (quote @) (quote @@))
- mod831
- var832))))
- (lambda (var835)
- (let ((atom-key836 (fluid-ref *mode*71)))
- (if (memv atom-key836 (quote (c)))
+ source3190
+ mod3193
+ var3194
+ public?3195)
+ (decorate-source2441
+ (list (if public?3195 (quote @) (quote @@))
+ mod3193
+ var3194)
+ source3190))))
+ (lambda (var3197)
+ (let ((atom-key3198 (fluid-ref *mode*2432)))
+ (if (memv atom-key3198 (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- source828
- var835)
- var835))))))
- (analyze-variable85
- (lambda (mod837 var838 modref-cont839 bare-cont840)
- (if (not mod837)
- (bare-cont840 var838)
- (let ((kind841 (car mod837)) (mod842 (cdr mod837)))
- (if (memv kind841 (quote (public)))
- (modref-cont839 mod842 var838 #t)
- (if (memv kind841 (quote (private)))
- (if (not (equal? mod842 (module-name (current-module))))
- (modref-cont839 mod842 var838 #f)
- (bare-cont840 var838))
- (if (memv kind841 (quote (bare)))
- (bare-cont840 var838)
- (if (memv kind841 (quote (hygiene)))
+ source3190
+ var3197)
+ (decorate-source2441 var3197 source3190)))))))
+ (analyze-variable2447
+ (lambda (mod3199 var3200 modref-cont3201 bare-cont3202)
+ (if (not mod3199)
+ (bare-cont3202 var3200)
+ (let ((kind3203 (car mod3199))
+ (mod3204 (cdr mod3199)))
+ (if (memv kind3203 (quote (public)))
+ (modref-cont3201 mod3204 var3200 #t)
+ (if (memv kind3203 (quote (private)))
+ (if (not (equal?
+ mod3204
+ (module-name (current-module))))
+ (modref-cont3201 mod3204 var3200 #f)
+ (bare-cont3202 var3200))
+ (if (memv kind3203 (quote (bare)))
+ (bare-cont3202 var3200)
+ (if (memv kind3203 (quote (hygiene)))
(if (if (not (equal?
- mod842
+ mod3204
(module-name (current-module))))
(module-variable
- (resolve-module mod842)
- var838)
+ (resolve-module mod3204)
+ var3200)
#f)
- (modref-cont839 mod842 var838 #f)
- (bare-cont840 var838))
+ (modref-cont3201 mod3204 var3200 #f)
+ (bare-cont3202 var3200))
(syntax-violation
#f
"bad module kind"
- var838
- mod842)))))))))
- (build-lexical-assignment84
- (lambda (source843 name844 var845 exp846)
- (let ((atom-key847 (fluid-ref *mode*71)))
- (if (memv atom-key847 (quote (c)))
+ var3200
+ mod3204)))))))))
+ (build-lexical-assignment2446
+ (lambda (source3205 name3206 var3207 exp3208)
+ (let ((atom-key3209 (fluid-ref *mode*2432)))
+ (if (memv atom-key3209 (quote (c)))
((@ (language tree-il) make-lexical-set)
- source843
- name844
- var845
- exp846)
- (list (quote set!) var845 exp846)))))
- (build-lexical-reference83
- (lambda (type848 source849 name850 var851)
- (let ((atom-key852 (fluid-ref *mode*71)))
- (if (memv atom-key852 (quote (c)))
+ source3205
+ name3206
+ var3207
+ exp3208)
+ (decorate-source2441
+ (list (quote set!) var3207 exp3208)
+ source3205)))))
+ (build-lexical-reference2445
+ (lambda (type3210 source3211 name3212 var3213)
+ (let ((atom-key3214 (fluid-ref *mode*2432)))
+ (if (memv atom-key3214 (quote (c)))
((@ (language tree-il) make-lexical-ref)
- source849
- name850
- var851)
- var851))))
- (build-conditional82
- (lambda (source853 test-exp854 then-exp855 else-exp856)
- (let ((atom-key857 (fluid-ref *mode*71)))
- (if (memv atom-key857 (quote (c)))
+ source3211
+ name3212
+ var3213)
+ (decorate-source2441 var3213 source3211)))))
+ (build-conditional2444
+ (lambda (source3215
+ test-exp3216
+ then-exp3217
+ else-exp3218)
+ (let ((atom-key3219 (fluid-ref *mode*2432)))
+ (if (memv atom-key3219 (quote (c)))
((@ (language tree-il) make-conditional)
- source853
- test-exp854
- then-exp855
- else-exp856)
- (if (equal? else-exp856 (quote (if #f #f)))
- (list (quote if) test-exp854 then-exp855)
- (list 'if
- test-exp854
- then-exp855
- else-exp856))))))
- (build-application81
- (lambda (source858 fun-exp859 arg-exps860)
- (let ((atom-key861 (fluid-ref *mode*71)))
- (if (memv atom-key861 (quote (c)))
+ source3215
+ test-exp3216
+ then-exp3217
+ else-exp3218)
+ (decorate-source2441
+ (if (equal? else-exp3218 (quote (if #f #f)))
+ (list (quote if) test-exp3216 then-exp3217)
+ (list 'if
+ test-exp3216
+ then-exp3217
+ else-exp3218))
+ source3215)))))
+ (build-application2443
+ (lambda (source3220 fun-exp3221 arg-exps3222)
+ (let ((atom-key3223 (fluid-ref *mode*2432)))
+ (if (memv atom-key3223 (quote (c)))
((@ (language tree-il) make-application)
- source858
- fun-exp859
- arg-exps860)
- (cons fun-exp859 arg-exps860)))))
- (build-void80
- (lambda (source862)
- (let ((atom-key863 (fluid-ref *mode*71)))
- (if (memv atom-key863 (quote (c)))
- ((@ (language tree-il) make-void) source862)
- '(if #f #f)))))
- (get-global-definition-hook79
- (lambda (symbol864 module865)
+ source3220
+ fun-exp3221
+ arg-exps3222)
+ (decorate-source2441
+ (cons fun-exp3221 arg-exps3222)
+ source3220)))))
+ (build-void2442
+ (lambda (source3224)
+ (let ((atom-key3225 (fluid-ref *mode*2432)))
+ (if (memv atom-key3225 (quote (c)))
+ ((@ (language tree-il) make-void) source3224)
+ (decorate-source2441
+ '(if #f #f)
+ source3224)))))
+ (decorate-source2441
+ (lambda (e3226 s3227)
(begin
- (if (if (not module865) (current-module) #f)
+ (if (if (pair? e3226) s3227 #f)
+ (set-source-properties! e3226 s3227))
+ e3226)))
+ (get-global-definition-hook2440
+ (lambda (symbol3228 module3229)
+ (begin
+ (if (if (not module3229) (current-module) #f)
(warn "module system is booted, we should have a module"
- symbol864))
- (let ((v866 (module-variable
- (if module865
- (resolve-module (cdr module865))
- (current-module))
- symbol864)))
- (if v866
- (if (variable-bound? v866)
- (let ((val867 (variable-ref v866)))
- (if (macro? val867)
- (if (syncase-macro-type val867)
- (cons (syncase-macro-type val867)
- (syncase-macro-binding val867))
+ symbol3228))
+ (let ((v3230 (module-variable
+ (if module3229
+ (resolve-module (cdr module3229))
+ (current-module))
+ symbol3228)))
+ (if v3230
+ (if (variable-bound? v3230)
+ (let ((val3231 (variable-ref v3230)))
+ (if (macro? val3231)
+ (if (syncase-macro-type val3231)
+ (cons (syncase-macro-type val3231)
+ (syncase-macro-binding val3231))
#f)
#f))
#f)
#f)))))
- (put-global-definition-hook78
- (lambda (symbol868 type869 val870)
- (let ((existing871
- (let ((v872 (module-variable
- (current-module)
- symbol868)))
- (if v872
- (if (variable-bound? v872)
- (let ((val873 (variable-ref v872)))
- (if (macro? val873)
- (if (not (syncase-macro-type val873))
- val873
+ (put-global-definition-hook2439
+ (lambda (symbol3232 type3233 val3234)
+ (let ((existing3235
+ (let ((v3236 (module-variable
+ (current-module)
+ symbol3232)))
+ (if v3236
+ (if (variable-bound? v3236)
+ (let ((val3237 (variable-ref v3236)))
+ (if (macro? val3237)
+ (if (not (syncase-macro-type val3237))
+ val3237
#f)
#f))
#f)
#f))))
(module-define!
(current-module)
- symbol868
- (if existing871
+ symbol3232
+ (if existing3235
(make-extended-syncase-macro
- existing871
- type869
- val870)
- (make-syncase-macro type869 val870))))))
- (local-eval-hook77
- (lambda (x874 mod875)
+ existing3235
+ type3233
+ val3234)
+ (make-syncase-macro type3233 val3234))))))
+ (local-eval-hook2438
+ (lambda (x3238 mod3239)
(primitive-eval
- (list noexpand70
- (let ((atom-key876 (fluid-ref *mode*71)))
- (if (memv atom-key876 (quote (c)))
- ((@ (language tree-il) tree-il->scheme) x874)
- x874))))))
- (top-level-eval-hook76
- (lambda (x877 mod878)
+ (list noexpand2431
+ (let ((atom-key3240 (fluid-ref *mode*2432)))
+ (if (memv atom-key3240 (quote (c)))
+ ((@ (language tree-il) tree-il->scheme) x3238)
+ x3238))))))
+ (top-level-eval-hook2437
+ (lambda (x3241 mod3242)
(primitive-eval
- (list noexpand70
- (let ((atom-key879 (fluid-ref *mode*71)))
- (if (memv atom-key879 (quote (c)))
- ((@ (language tree-il) tree-il->scheme) x877)
- x877))))))
- (fx<75 <)
- (fx=74 =)
- (fx-73 -)
- (fx+72 +)
- (*mode*71 (make-fluid))
- (noexpand70 "noexpand"))
+ (list noexpand2431
+ (let ((atom-key3243 (fluid-ref *mode*2432)))
+ (if (memv atom-key3243 (quote (c)))
+ ((@ (language tree-il) tree-il->scheme) x3241)
+ x3241))))))
+ (fx<2436 <)
+ (fx=2435 =)
+ (fx-2434 -)
+ (fx+2433 +)
+ (*mode*2432 (make-fluid))
+ (noexpand2431 "noexpand"))
(begin
- (global-extend112
+ (global-extend2474
'local-syntax
'letrec-syntax
#t)
- (global-extend112
+ (global-extend2474
'local-syntax
'let-syntax
#f)
- (global-extend112
+ (global-extend2474
'core
'fluid-let-syntax
- (lambda (e880 r881 w882 s883 mod884)
- ((lambda (tmp885)
- ((lambda (tmp886)
- (if (if tmp886
- (apply (lambda (_887 var888 val889 e1890 e2891)
- (valid-bound-ids?139 var888))
- tmp886)
+ (lambda (e3244 r3245 w3246 s3247 mod3248)
+ ((lambda (tmp3249)
+ ((lambda (tmp3250)
+ (if (if tmp3250
+ (apply (lambda (_3251 var3252 val3253 e13254 e23255)
+ (valid-bound-ids?2501 var3252))
+ tmp3250)
#f)
- (apply (lambda (_893 var894 val895 e1896 e2897)
- (let ((names898
- (map (lambda (x899)
- (id-var-name136 x899 w882))
- var894)))
+ (apply (lambda (_3257 var3258 val3259 e13260 e23261)
+ (let ((names3262
+ (map (lambda (x3263)
+ (id-var-name2498 x3263 w3246))
+ var3258)))
(begin
(for-each
- (lambda (id901 n902)
- (let ((atom-key903
- (binding-type106
- (lookup111 n902 r881 mod884))))
- (if (memv atom-key903
+ (lambda (id3265 n3266)
+ (let ((atom-key3267
+ (binding-type2468
+ (lookup2473
+ n3266
+ r3245
+ mod3248))))
+ (if (memv atom-key3267
'(displaced-lexical))
(syntax-violation
'fluid-let-syntax
"identifier out of context"
- e880
- (source-wrap143
- id901
- w882
- s883
- mod884)))))
- var894
- names898)
- (chi-body154
- (cons e1896 e2897)
- (source-wrap143 e880 w882 s883 mod884)
- (extend-env108
- names898
- (let ((trans-r906
- (macros-only-env110 r881)))
- (map (lambda (x907)
+ e3244
+ (source-wrap2505
+ id3265
+ w3246
+ s3247
+ mod3248)))))
+ var3258
+ names3262)
+ (chi-body2516
+ (cons e13260 e23261)
+ (source-wrap2505 e3244 w3246 s3247 mod3248)
+ (extend-env2470
+ names3262
+ (let ((trans-r3270
+ (macros-only-env2472 r3245)))
+ (map (lambda (x3271)
(cons 'macro
- (eval-local-transformer157
- (chi150
- x907
- trans-r906
- w882
- mod884)
- mod884)))
- val895))
- r881)
- w882
- mod884))))
- tmp886)
- ((lambda (_909)
+ (eval-local-transformer2519
+ (chi2512
+ x3271
+ trans-r3270
+ w3246
+ mod3248)
+ mod3248)))
+ val3259))
+ r3245)
+ w3246
+ mod3248))))
+ tmp3250)
+ ((lambda (_3273)
(syntax-violation
'fluid-let-syntax
"bad syntax"
- (source-wrap143 e880 w882 s883 mod884)))
- tmp885)))
+ (source-wrap2505 e3244 w3246 s3247 mod3248)))
+ tmp3249)))
($sc-dispatch
- tmp885
+ tmp3249
'(any #(each (any any)) any . each-any))))
- e880)))
- (global-extend112
+ e3244)))
+ (global-extend2474
'core
'quote
- (lambda (e910 r911 w912 s913 mod914)
- ((lambda (tmp915)
- ((lambda (tmp916)
- (if tmp916
- (apply (lambda (_917 e918)
- (build-data92 s913 (strip160 e918 w912)))
- tmp916)
- ((lambda (_919)
+ (lambda (e3274 r3275 w3276 s3277 mod3278)
+ ((lambda (tmp3279)
+ ((lambda (tmp3280)
+ (if tmp3280
+ (apply (lambda (_3281 e3282)
+ (build-data2454 s3277 (strip2522 e3282 w3276)))
+ tmp3280)
+ ((lambda (_3283)
(syntax-violation
'quote
"bad syntax"
- (source-wrap143 e910 w912 s913 mod914)))
- tmp915)))
- ($sc-dispatch tmp915 (quote (any any)))))
- e910)))
- (global-extend112
+ (source-wrap2505 e3274 w3276 s3277 mod3278)))
+ tmp3279)))
+ ($sc-dispatch tmp3279 (quote (any any)))))
+ e3274)))
+ (global-extend2474
'core
'syntax
- (letrec ((regen927
- (lambda (x928)
- (let ((atom-key929 (car x928)))
- (if (memv atom-key929 (quote (ref)))
- (build-lexical-reference83
+ (letrec ((regen3291
+ (lambda (x3292)
+ (let ((atom-key3293 (car x3292)))
+ (if (memv atom-key3293 (quote (ref)))
+ (build-lexical-reference2445
'value
#f
- (cadr x928)
- (cadr x928))
- (if (memv atom-key929 (quote (primitive)))
- (build-primref91 #f (cadr x928))
- (if (memv atom-key929 (quote (quote)))
- (build-data92 #f (cadr x928))
- (if (memv atom-key929 (quote (lambda)))
- (build-lambda90
+ (cadr x3292)
+ (cadr x3292))
+ (if (memv atom-key3293 (quote (primitive)))
+ (build-primref2453 #f (cadr x3292))
+ (if (memv atom-key3293 (quote (quote)))
+ (build-data2454 #f (cadr x3292))
+ (if (memv atom-key3293 (quote (lambda)))
+ (build-lambda2452
#f
- (cadr x928)
- (cadr x928)
+ (cadr x3292)
+ (cadr x3292)
#f
- (regen927 (caddr x928)))
- (build-application81
+ (regen3291 (caddr x3292)))
+ (build-application2443
#f
- (build-primref91 #f (car x928))
- (map regen927 (cdr x928))))))))))
- (gen-vector926
- (lambda (x930)
- (if (eq? (car x930) (quote list))
- (cons (quote vector) (cdr x930))
- (if (eq? (car x930) (quote quote))
- (list (quote quote) (list->vector (cadr x930)))
- (list (quote list->vector) x930)))))
- (gen-append925
- (lambda (x931 y932)
- (if (equal? y932 (quote (quote ())))
- x931
- (list (quote append) x931 y932))))
- (gen-cons924
- (lambda (x933 y934)
- (let ((atom-key935 (car y934)))
- (if (memv atom-key935 (quote (quote)))
- (if (eq? (car x933) (quote quote))
+ (build-primref2453 #f (car x3292))
+ (map regen3291 (cdr x3292))))))))))
+ (gen-vector3290
+ (lambda (x3294)
+ (if (eq? (car x3294) (quote list))
+ (cons (quote vector) (cdr x3294))
+ (if (eq? (car x3294) (quote quote))
+ (list (quote quote) (list->vector (cadr x3294)))
+ (list (quote list->vector) x3294)))))
+ (gen-append3289
+ (lambda (x3295 y3296)
+ (if (equal? y3296 (quote (quote ())))
+ x3295
+ (list (quote append) x3295 y3296))))
+ (gen-cons3288
+ (lambda (x3297 y3298)
+ (let ((atom-key3299 (car y3298)))
+ (if (memv atom-key3299 (quote (quote)))
+ (if (eq? (car x3297) (quote quote))
(list 'quote
- (cons (cadr x933) (cadr y934)))
- (if (eq? (cadr y934) (quote ()))
- (list (quote list) x933)
- (list (quote cons) x933 y934)))
- (if (memv atom-key935 (quote (list)))
- (cons (quote list) (cons x933 (cdr y934)))
- (list (quote cons) x933 y934))))))
- (gen-map923
- (lambda (e936 map-env937)
- (let ((formals938 (map cdr map-env937))
- (actuals939
- (map (lambda (x940) (list (quote ref) (car x940)))
- map-env937)))
- (if (eq? (car e936) (quote ref))
- (car actuals939)
+ (cons (cadr x3297) (cadr y3298)))
+ (if (eq? (cadr y3298) (quote ()))
+ (list (quote list) x3297)
+ (list (quote cons) x3297 y3298)))
+ (if (memv atom-key3299 (quote (list)))
+ (cons (quote list) (cons x3297 (cdr y3298)))
+ (list (quote cons) x3297 y3298))))))
+ (gen-map3287
+ (lambda (e3300 map-env3301)
+ (let ((formals3302 (map cdr map-env3301))
+ (actuals3303
+ (map (lambda (x3304)
+ (list (quote ref) (car x3304)))
+ map-env3301)))
+ (if (eq? (car e3300) (quote ref))
+ (car actuals3303)
(if (and-map
- (lambda (x941)
- (if (eq? (car x941) (quote ref))
- (memq (cadr x941) formals938)
+ (lambda (x3305)
+ (if (eq? (car x3305) (quote ref))
+ (memq (cadr x3305) formals3302)
#f))
- (cdr e936))
+ (cdr e3300))
(cons 'map
- (cons (list (quote primitive) (car e936))
- (map (let ((r942 (map cons
- formals938
- actuals939)))
- (lambda (x943)
- (cdr (assq (cadr x943) r942))))
- (cdr e936))))
+ (cons (list (quote primitive) (car e3300))
+ (map (let ((r3306 (map cons
+ formals3302
+ actuals3303)))
+ (lambda (x3307)
+ (cdr (assq (cadr x3307)
+ r3306))))
+ (cdr e3300))))
(cons 'map
- (cons (list (quote lambda) formals938 e936)
- actuals939)))))))
- (gen-mappend922
- (lambda (e944 map-env945)
+ (cons (list (quote lambda) formals3302 e3300)
+ actuals3303)))))))
+ (gen-mappend3286
+ (lambda (e3308 map-env3309)
(list 'apply
'(primitive append)
- (gen-map923 e944 map-env945))))
- (gen-ref921
- (lambda (src946 var947 level948 maps949)
- (if (fx=74 level948 0)
- (values var947 maps949)
- (if (null? maps949)
+ (gen-map3287 e3308 map-env3309))))
+ (gen-ref3285
+ (lambda (src3310 var3311 level3312 maps3313)
+ (if (fx=2435 level3312 0)
+ (values var3311 maps3313)
+ (if (null? maps3313)
(syntax-violation
'syntax
"missing ellipsis"
- src946)
+ src3310)
(call-with-values
(lambda ()
- (gen-ref921
- src946
- var947
- (fx-73 level948 1)
- (cdr maps949)))
- (lambda (outer-var950 outer-maps951)
- (let ((b952 (assq outer-var950 (car maps949))))
- (if b952
- (values (cdr b952) maps949)
- (let ((inner-var953 (gen-var161 (quote tmp))))
+ (gen-ref3285
+ src3310
+ var3311
+ (fx-2434 level3312 1)
+ (cdr maps3313)))
+ (lambda (outer-var3314 outer-maps3315)
+ (let ((b3316 (assq outer-var3314 (car maps3313))))
+ (if b3316
+ (values (cdr b3316) maps3313)
+ (let ((inner-var3317
+ (gen-var2523 (quote tmp))))
(values
- inner-var953
- (cons (cons (cons outer-var950
- inner-var953)
- (car maps949))
- outer-maps951)))))))))))
- (gen-syntax920
- (lambda (src954 e955 r956 maps957 ellipsis?958 mod959)
- (if (id?114 e955)
- (let ((label960 (id-var-name136 e955 (quote (())))))
- (let ((b961 (lookup111 label960 r956 mod959)))
- (if (eq? (binding-type106 b961) (quote syntax))
+ inner-var3317
+ (cons (cons (cons outer-var3314
+ inner-var3317)
+ (car maps3313))
+ outer-maps3315)))))))))))
+ (gen-syntax3284
+ (lambda (src3318
+ e3319
+ r3320
+ maps3321
+ ellipsis?3322
+ mod3323)
+ (if (id?2476 e3319)
+ (let ((label3324 (id-var-name2498 e3319 (quote (())))))
+ (let ((b3325 (lookup2473 label3324 r3320 mod3323)))
+ (if (eq? (binding-type2468 b3325) (quote syntax))
(call-with-values
(lambda ()
- (let ((var.lev962 (binding-value107 b961)))
- (gen-ref921
- src954
- (car var.lev962)
- (cdr var.lev962)
- maps957)))
- (lambda (var963 maps964)
- (values (list (quote ref) var963) maps964)))
- (if (ellipsis?958 e955)
+ (let ((var.lev3326 (binding-value2469 b3325)))
+ (gen-ref3285
+ src3318
+ (car var.lev3326)
+ (cdr var.lev3326)
+ maps3321)))
+ (lambda (var3327 maps3328)
+ (values (list (quote ref) var3327) maps3328)))
+ (if (ellipsis?3322 e3319)
(syntax-violation
'syntax
"misplaced ellipsis"
- src954)
- (values (list (quote quote) e955) maps957)))))
- ((lambda (tmp965)
- ((lambda (tmp966)
- (if (if tmp966
- (apply (lambda (dots967 e968)
- (ellipsis?958 dots967))
- tmp966)
+ src3318)
+ (values (list (quote quote) e3319) maps3321)))))
+ ((lambda (tmp3329)
+ ((lambda (tmp3330)
+ (if (if tmp3330
+ (apply (lambda (dots3331 e3332)
+ (ellipsis?3322 dots3331))
+ tmp3330)
#f)
- (apply (lambda (dots969 e970)
- (gen-syntax920
- src954
- e970
- r956
- maps957
- (lambda (x971) #f)
- mod959))
- tmp966)
- ((lambda (tmp972)
- (if (if tmp972
- (apply (lambda (x973 dots974 y975)
- (ellipsis?958 dots974))
- tmp972)
+ (apply (lambda (dots3333 e3334)
+ (gen-syntax3284
+ src3318
+ e3334
+ r3320
+ maps3321
+ (lambda (x3335) #f)
+ mod3323))
+ tmp3330)
+ ((lambda (tmp3336)
+ (if (if tmp3336
+ (apply (lambda (x3337 dots3338 y3339)
+ (ellipsis?3322 dots3338))
+ tmp3336)
#f)
- (apply (lambda (x976 dots977 y978)
- (letrec ((f979 (lambda (y980 k981)
- ((lambda (tmp985)
- ((lambda (tmp986)
- (if (if tmp986
- (apply (lambda (dots987
- y988)
- (ellipsis?958
- dots987))
- tmp986)
- #f)
- (apply (lambda (dots989
- y990)
- (f979 y990
- (lambda (maps991)
- (call-with-values
- (lambda ()
- (k981 (cons '()
- maps991)))
- (lambda (x992
- maps993)
- (if (null? (car maps993))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- src954)
- (values
- (gen-mappend922
- x992
- (car maps993))
- (cdr maps993))))))))
- tmp986)
- ((lambda (_994)
- (call-with-values
- (lambda ()
- (gen-syntax920
- src954
- y980
- r956
- maps957
- ellipsis?958
- mod959))
- (lambda (y995
- maps996)
- (call-with-values
- (lambda ()
- (k981 maps996))
- (lambda (x997
- maps998)
- (values
- (gen-append925
- x997
- y995)
- maps998))))))
- tmp985)))
- ($sc-dispatch
- tmp985
- '(any .
- any))))
- y980))))
- (f979 y978
- (lambda (maps982)
- (call-with-values
- (lambda ()
- (gen-syntax920
- src954
- x976
- r956
- (cons '()
- maps982)
- ellipsis?958
- mod959))
- (lambda (x983 maps984)
- (if (null? (car maps984))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- src954)
- (values
- (gen-map923
- x983
- (car maps984))
- (cdr maps984)))))))))
- tmp972)
- ((lambda (tmp999)
- (if tmp999
- (apply (lambda (x1000 y1001)
+ (apply (lambda (x3340 dots3341 y3342)
+ (letrec ((f3343 (lambda (y3344
+ k3345)
+ ((lambda (tmp3349)
+ ((lambda (tmp3350)
+ (if (if tmp3350
+ (apply (lambda (dots3351
+ y3352)
+ (ellipsis?3322
+ dots3351))
+ tmp3350)
+ #f)
+ (apply (lambda (dots3353
+ y3354)
+ (f3343 y3354
+ (lambda (maps3355)
+ (call-with-values
+ (lambda ()
+ (k3345 (cons '()
+ maps3355)))
+ (lambda (x3356
+ maps3357)
+ (if (null? (car maps3357))
+ (syntax-violation
+ 'syntax
+ "extra ellipsis"
+ src3318)
+ (values
+ (gen-mappend3286
+ x3356
+ (car maps3357))
+ (cdr maps3357))))))))
+ tmp3350)
+ ((lambda (_3358)
+ (call-with-values
+ (lambda ()
+ (gen-syntax3284
+ src3318
+ y3344
+ r3320
+ maps3321
+ ellipsis?3322
+ mod3323))
+ (lambda (y3359
+ maps3360)
+ (call-with-values
+ (lambda ()
+ (k3345 maps3360))
+ (lambda (x3361
+ maps3362)
+ (values
+ (gen-append3289
+ x3361
+ y3359)
+ maps3362))))))
+ tmp3349)))
+ ($sc-dispatch
+ tmp3349
+ '(any .
+ any))))
+ y3344))))
+ (f3343 y3342
+ (lambda (maps3346)
+ (call-with-values
+ (lambda ()
+ (gen-syntax3284
+ src3318
+ x3340
+ r3320
+ (cons '()
+ maps3346)
+ ellipsis?3322
+ mod3323))
+ (lambda (x3347
+ maps3348)
+ (if (null? (car maps3348))
+ (syntax-violation
+ 'syntax
+ "extra ellipsis"
+ src3318)
+ (values
+ (gen-map3287
+ x3347
+ (car maps3348))
+ (cdr maps3348)))))))))
+ tmp3336)
+ ((lambda (tmp3363)
+ (if tmp3363
+ (apply (lambda (x3364 y3365)
(call-with-values
(lambda ()
- (gen-syntax920
- src954
- x1000
- r956
- maps957
- ellipsis?958
- mod959))
- (lambda (x1002 maps1003)
+ (gen-syntax3284
+ src3318
+ x3364
+ r3320
+ maps3321
+ ellipsis?3322
+ mod3323))
+ (lambda (x3366 maps3367)
(call-with-values
(lambda ()
- (gen-syntax920
- src954
- y1001
- r956
- maps1003
- ellipsis?958
- mod959))
- (lambda (y1004
- maps1005)
+ (gen-syntax3284
+ src3318
+ y3365
+ r3320
+ maps3367
+ ellipsis?3322
+ mod3323))
+ (lambda (y3368
+ maps3369)
(values
- (gen-cons924
- x1002
- y1004)
- maps1005))))))
- tmp999)
- ((lambda (tmp1006)
- (if tmp1006
- (apply (lambda (e11007 e21008)
+ (gen-cons3288
+ x3366
+ y3368)
+ maps3369))))))
+ tmp3363)
+ ((lambda (tmp3370)
+ (if tmp3370
+ (apply (lambda (e13371 e23372)
(call-with-values
(lambda ()
- (gen-syntax920
- src954
- (cons e11007
- e21008)
- r956
- maps957
- ellipsis?958
- mod959))
- (lambda (e1010
- maps1011)
+ (gen-syntax3284
+ src3318
+ (cons e13371
+ e23372)
+ r3320
+ maps3321
+ ellipsis?3322
+ mod3323))
+ (lambda (e3374
+ maps3375)
(values
- (gen-vector926
- e1010)
- maps1011))))
- tmp1006)
- ((lambda (_1012)
+ (gen-vector3290
+ e3374)
+ maps3375))))
+ tmp3370)
+ ((lambda (_3376)
(values
- (list (quote quote) e955)
- maps957))
- tmp965)))
+ (list (quote quote) e3319)
+ maps3321))
+ tmp3329)))
($sc-dispatch
- tmp965
+ tmp3329
'#(vector (any . each-any))))))
($sc-dispatch
- tmp965
+ tmp3329
'(any . any)))))
($sc-dispatch
- tmp965
+ tmp3329
'(any any . any)))))
- ($sc-dispatch tmp965 (quote (any any)))))
- e955)))))
- (lambda (e1013 r1014 w1015 s1016 mod1017)
- (let ((e1018 (source-wrap143 e1013 w1015 s1016 mod1017)))
- ((lambda (tmp1019)
- ((lambda (tmp1020)
- (if tmp1020
- (apply (lambda (_1021 x1022)
+ ($sc-dispatch tmp3329 (quote (any any)))))
+ e3319)))))
+ (lambda (e3377 r3378 w3379 s3380 mod3381)
+ (let ((e3382 (source-wrap2505 e3377 w3379 s3380 mod3381)))
+ ((lambda (tmp3383)
+ ((lambda (tmp3384)
+ (if tmp3384
+ (apply (lambda (_3385 x3386)
(call-with-values
(lambda ()
- (gen-syntax920
- e1018
- x1022
- r1014
+ (gen-syntax3284
+ e3382
+ x3386
+ r3378
'()
- ellipsis?159
- mod1017))
- (lambda (e1023 maps1024) (regen927 e1023))))
- tmp1020)
- ((lambda (_1025)
+ ellipsis?2521
+ mod3381))
+ (lambda (e3387 maps3388) (regen3291 e3387))))
+ tmp3384)
+ ((lambda (_3389)
(syntax-violation
'syntax
"bad `syntax' form"
- e1018))
- tmp1019)))
- ($sc-dispatch tmp1019 (quote (any any)))))
- e1018)))))
- (global-extend112
+ e3382))
+ tmp3383)))
+ ($sc-dispatch tmp3383 (quote (any any)))))
+ e3382)))))
+ (global-extend2474
'core
'lambda
- (lambda (e1026 r1027 w1028 s1029 mod1030)
- ((lambda (tmp1031)
- ((lambda (tmp1032)
- (if tmp1032
- (apply (lambda (_1033 c1034)
- (chi-lambda-clause155
- (source-wrap143 e1026 w1028 s1029 mod1030)
+ (lambda (e3390 r3391 w3392 s3393 mod3394)
+ ((lambda (tmp3395)
+ ((lambda (tmp3396)
+ (if tmp3396
+ (apply (lambda (_3397 c3398)
+ (chi-lambda-clause2517
+ (source-wrap2505 e3390 w3392 s3393 mod3394)
#f
- c1034
- r1027
- w1028
- mod1030
- (lambda (names1035
- vars1036
- docstring1037
- body1038)
- (build-lambda90
- s1029
- names1035
- vars1036
- docstring1037
- body1038))))
- tmp1032)
+ c3398
+ r3391
+ w3392
+ mod3394
+ (lambda (names3399
+ vars3400
+ docstring3401
+ body3402)
+ (build-lambda2452
+ s3393
+ names3399
+ vars3400
+ docstring3401
+ body3402))))
+ tmp3396)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1031)))
- ($sc-dispatch tmp1031 (quote (any . any)))))
- e1026)))
- (global-extend112
+ tmp3395)))
+ ($sc-dispatch tmp3395 (quote (any . any)))))
+ e3390)))
+ (global-extend2474
'core
'let
- (letrec ((chi-let1039
- (lambda (e1040
- r1041
- w1042
- s1043
- mod1044
- constructor1045
- ids1046
- vals1047
- exps1048)
- (if (not (valid-bound-ids?139 ids1046))
+ (letrec ((chi-let3403
+ (lambda (e3404
+ r3405
+ w3406
+ s3407
+ mod3408
+ constructor3409
+ ids3410
+ vals3411
+ exps3412)
+ (if (not (valid-bound-ids?2501 ids3410))
(syntax-violation
'let
"duplicate bound variable"
- e1040)
- (let ((labels1049 (gen-labels120 ids1046))
- (new-vars1050 (map gen-var161 ids1046)))
- (let ((nw1051
- (make-binding-wrap131
- ids1046
- labels1049
- w1042))
- (nr1052
- (extend-var-env109
- labels1049
- new-vars1050
- r1041)))
- (constructor1045
- s1043
- (map syntax->datum ids1046)
- new-vars1050
- (map (lambda (x1053)
- (chi150 x1053 r1041 w1042 mod1044))
- vals1047)
- (chi-body154
- exps1048
- (source-wrap143 e1040 nw1051 s1043 mod1044)
- nr1052
- nw1051
- mod1044))))))))
- (lambda (e1054 r1055 w1056 s1057 mod1058)
- ((lambda (tmp1059)
- ((lambda (tmp1060)
- (if (if tmp1060
- (apply (lambda (_1061 id1062 val1063 e11064 e21065)
- (and-map id?114 id1062))
- tmp1060)
+ e3404)
+ (let ((labels3413 (gen-labels2482 ids3410))
+ (new-vars3414 (map gen-var2523 ids3410)))
+ (let ((nw3415
+ (make-binding-wrap2493
+ ids3410
+ labels3413
+ w3406))
+ (nr3416
+ (extend-var-env2471
+ labels3413
+ new-vars3414
+ r3405)))
+ (constructor3409
+ s3407
+ (map syntax->datum ids3410)
+ new-vars3414
+ (map (lambda (x3417)
+ (chi2512 x3417 r3405 w3406 mod3408))
+ vals3411)
+ (chi-body2516
+ exps3412
+ (source-wrap2505 e3404 nw3415 s3407 mod3408)
+ nr3416
+ nw3415
+ mod3408))))))))
+ (lambda (e3418 r3419 w3420 s3421 mod3422)
+ ((lambda (tmp3423)
+ ((lambda (tmp3424)
+ (if (if tmp3424
+ (apply (lambda (_3425 id3426 val3427 e13428 e23429)
+ (and-map id?2476 id3426))
+ tmp3424)
#f)
- (apply (lambda (_1067 id1068 val1069 e11070 e21071)
- (chi-let1039
- e1054
- r1055
- w1056
- s1057
- mod1058
- build-let94
- id1068
- val1069
- (cons e11070 e21071)))
- tmp1060)
- ((lambda (tmp1075)
- (if (if tmp1075
- (apply (lambda (_1076
- f1077
- id1078
- val1079
- e11080
- e21081)
- (if (id?114 f1077)
- (and-map id?114 id1078)
+ (apply (lambda (_3431 id3432 val3433 e13434 e23435)
+ (chi-let3403
+ e3418
+ r3419
+ w3420
+ s3421
+ mod3422
+ build-let2456
+ id3432
+ val3433
+ (cons e13434 e23435)))
+ tmp3424)
+ ((lambda (tmp3439)
+ (if (if tmp3439
+ (apply (lambda (_3440
+ f3441
+ id3442
+ val3443
+ e13444
+ e23445)
+ (if (id?2476 f3441)
+ (and-map id?2476 id3442)
#f))
- tmp1075)
+ tmp3439)
#f)
- (apply (lambda (_1083
- f1084
- id1085
- val1086
- e11087
- e21088)
- (chi-let1039
- e1054
- r1055
- w1056
- s1057
- mod1058
- build-named-let95
- (cons f1084 id1085)
- val1086
- (cons e11087 e21088)))
- tmp1075)
- ((lambda (_1092)
+ (apply (lambda (_3447
+ f3448
+ id3449
+ val3450
+ e13451
+ e23452)
+ (chi-let3403
+ e3418
+ r3419
+ w3420
+ s3421
+ mod3422
+ build-named-let2457
+ (cons f3448 id3449)
+ val3450
+ (cons e13451 e23452)))
+ tmp3439)
+ ((lambda (_3456)
(syntax-violation
'let
"bad let"
- (source-wrap143 e1054 w1056 s1057 mod1058)))
- tmp1059)))
+ (source-wrap2505 e3418 w3420 s3421 mod3422)))
+ tmp3423)))
($sc-dispatch
- tmp1059
+ tmp3423
'(any any #(each (any any)) any . each-any)))))
($sc-dispatch
- tmp1059
+ tmp3423
'(any #(each (any any)) any . each-any))))
- e1054))))
- (global-extend112
+ e3418))))
+ (global-extend2474
'core
'letrec
- (lambda (e1093 r1094 w1095 s1096 mod1097)
- ((lambda (tmp1098)
- ((lambda (tmp1099)
- (if (if tmp1099
- (apply (lambda (_1100 id1101 val1102 e11103 e21104)
- (and-map id?114 id1101))
- tmp1099)
+ (lambda (e3457 r3458 w3459 s3460 mod3461)
+ ((lambda (tmp3462)
+ ((lambda (tmp3463)
+ (if (if tmp3463
+ (apply (lambda (_3464 id3465 val3466 e13467 e23468)
+ (and-map id?2476 id3465))
+ tmp3463)
#f)
- (apply (lambda (_1106 id1107 val1108 e11109 e21110)
- (let ((ids1111 id1107))
- (if (not (valid-bound-ids?139 ids1111))
+ (apply (lambda (_3470 id3471 val3472 e13473 e23474)
+ (let ((ids3475 id3471))
+ (if (not (valid-bound-ids?2501 ids3475))
(syntax-violation
'letrec
"duplicate bound variable"
- e1093)
- (let ((labels1113 (gen-labels120 ids1111))
- (new-vars1114 (map gen-var161 ids1111)))
- (let ((w1115 (make-binding-wrap131
- ids1111
- labels1113
- w1095))
- (r1116 (extend-var-env109
- labels1113
- new-vars1114
- r1094)))
- (build-letrec96
- s1096
- (map syntax->datum ids1111)
- new-vars1114
- (map (lambda (x1117)
- (chi150 x1117 r1116 w1115 mod1097))
- val1108)
- (chi-body154
- (cons e11109 e21110)
- (source-wrap143
- e1093
- w1115
- s1096
- mod1097)
- r1116
- w1115
- mod1097)))))))
- tmp1099)
- ((lambda (_1120)
+ e3457)
+ (let ((labels3477 (gen-labels2482 ids3475))
+ (new-vars3478 (map gen-var2523 ids3475)))
+ (let ((w3479 (make-binding-wrap2493
+ ids3475
+ labels3477
+ w3459))
+ (r3480 (extend-var-env2471
+ labels3477
+ new-vars3478
+ r3458)))
+ (build-letrec2458
+ s3460
+ (map syntax->datum ids3475)
+ new-vars3478
+ (map (lambda (x3481)
+ (chi2512
+ x3481
+ r3480
+ w3479
+ mod3461))
+ val3472)
+ (chi-body2516
+ (cons e13473 e23474)
+ (source-wrap2505
+ e3457
+ w3479
+ s3460
+ mod3461)
+ r3480
+ w3479
+ mod3461)))))))
+ tmp3463)
+ ((lambda (_3484)
(syntax-violation
'letrec
"bad letrec"
- (source-wrap143 e1093 w1095 s1096 mod1097)))
- tmp1098)))
+ (source-wrap2505 e3457 w3459 s3460 mod3461)))
+ tmp3462)))
($sc-dispatch
- tmp1098
+ tmp3462
'(any #(each (any any)) any . each-any))))
- e1093)))
- (global-extend112
+ e3457)))
+ (global-extend2474
'core
'set!
- (lambda (e1121 r1122 w1123 s1124 mod1125)
- ((lambda (tmp1126)
- ((lambda (tmp1127)
- (if (if tmp1127
- (apply (lambda (_1128 id1129 val1130) (id?114 id1129))
- tmp1127)
+ (lambda (e3485 r3486 w3487 s3488 mod3489)
+ ((lambda (tmp3490)
+ ((lambda (tmp3491)
+ (if (if tmp3491
+ (apply (lambda (_3492 id3493 val3494) (id?2476 id3493))
+ tmp3491)
#f)
- (apply (lambda (_1131 id1132 val1133)
- (let ((val1134 (chi150 val1133 r1122 w1123 mod1125))
- (n1135 (id-var-name136 id1132 w1123)))
- (let ((b1136 (lookup111 n1135 r1122 mod1125)))
- (let ((atom-key1137 (binding-type106 b1136)))
- (if (memv atom-key1137 (quote (lexical)))
- (build-lexical-assignment84
- s1124
- (syntax->datum id1132)
- (binding-value107 b1136)
- val1134)
- (if (memv atom-key1137 (quote (global)))
- (build-global-assignment87
- s1124
- n1135
- val1134
- mod1125)
- (if (memv atom-key1137
+ (apply (lambda (_3495 id3496 val3497)
+ (let ((val3498
+ (chi2512 val3497 r3486 w3487 mod3489))
+ (n3499 (id-var-name2498 id3496 w3487)))
+ (let ((b3500 (lookup2473 n3499 r3486 mod3489)))
+ (let ((atom-key3501 (binding-type2468 b3500)))
+ (if (memv atom-key3501 (quote (lexical)))
+ (build-lexical-assignment2446
+ s3488
+ (syntax->datum id3496)
+ (binding-value2469 b3500)
+ val3498)
+ (if (memv atom-key3501 (quote (global)))
+ (build-global-assignment2449
+ s3488
+ n3499
+ val3498
+ mod3489)
+ (if (memv atom-key3501
'(displaced-lexical))
(syntax-violation
'set!
"identifier out of context"
- (wrap142 id1132 w1123 mod1125))
+ (wrap2504 id3496 w3487 mod3489))
(syntax-violation
'set!
"bad set!"
- (source-wrap143
- e1121
- w1123
- s1124
- mod1125)))))))))
- tmp1127)
- ((lambda (tmp1138)
- (if tmp1138
- (apply (lambda (_1139 head1140 tail1141 val1142)
+ (source-wrap2505
+ e3485
+ w3487
+ s3488
+ mod3489)))))))))
+ tmp3491)
+ ((lambda (tmp3502)
+ (if tmp3502
+ (apply (lambda (_3503 head3504 tail3505 val3506)
(call-with-values
(lambda ()
- (syntax-type148
- head1140
- r1122
+ (syntax-type2510
+ head3504
+ r3486
'(())
#f
#f
- mod1125
+ mod3489
#t))
- (lambda (type1143
- value1144
- ee1145
- ww1146
- ss1147
- modmod1148)
- (if (memv type1143 (quote (module-ref)))
- (let ((val1149
- (chi150
- val1142
- r1122
- w1123
- mod1125)))
+ (lambda (type3507
+ value3508
+ ee3509
+ ww3510
+ ss3511
+ modmod3512)
+ (if (memv type3507 (quote (module-ref)))
+ (let ((val3513
+ (chi2512
+ val3506
+ r3486
+ w3487
+ mod3489)))
(call-with-values
(lambda ()
- (value1144
- (cons head1140 tail1141)))
- (lambda (id1151 mod1152)
- (build-global-assignment87
- s1124
- id1151
- val1149
- mod1152))))
- (build-application81
- s1124
- (chi150
+ (value3508
+ (cons head3504 tail3505)))
+ (lambda (id3515 mod3516)
+ (build-global-assignment2449
+ s3488
+ id3515
+ val3513
+ mod3516))))
+ (build-application2443
+ s3488
+ (chi2512
(list '#(syntax-object
setter
((top)
@@ -6189,6 +6407,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -6310,6 +6529,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -6421,6 +6641,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -6428,47 +6649,47 @@
((top) (top))
("i" "i")))
(hygiene guile))
- head1140)
- r1122
- w1123
- mod1125)
- (map (lambda (e1153)
- (chi150
- e1153
- r1122
- w1123
- mod1125))
+ head3504)
+ r3486
+ w3487
+ mod3489)
+ (map (lambda (e3517)
+ (chi2512
+ e3517
+ r3486
+ w3487
+ mod3489))
(append
- tail1141
- (list val1142))))))))
- tmp1138)
- ((lambda (_1155)
+ tail3505
+ (list val3506))))))))
+ tmp3502)
+ ((lambda (_3519)
(syntax-violation
'set!
"bad set!"
- (source-wrap143 e1121 w1123 s1124 mod1125)))
- tmp1126)))
+ (source-wrap2505 e3485 w3487 s3488 mod3489)))
+ tmp3490)))
($sc-dispatch
- tmp1126
+ tmp3490
'(any (any . each-any) any)))))
- ($sc-dispatch tmp1126 (quote (any any any)))))
- e1121)))
- (global-extend112
+ ($sc-dispatch tmp3490 (quote (any any any)))))
+ e3485)))
+ (global-extend2474
'module-ref
'@
- (lambda (e1156)
- ((lambda (tmp1157)
- ((lambda (tmp1158)
- (if (if tmp1158
- (apply (lambda (_1159 mod1160 id1161)
- (if (and-map id?114 mod1160)
- (id?114 id1161)
+ (lambda (e3520)
+ ((lambda (tmp3521)
+ ((lambda (tmp3522)
+ (if (if tmp3522
+ (apply (lambda (_3523 mod3524 id3525)
+ (if (and-map id?2476 mod3524)
+ (id?2476 id3525)
#f))
- tmp1158)
+ tmp3522)
#f)
- (apply (lambda (_1163 mod1164 id1165)
+ (apply (lambda (_3527 mod3528 id3529)
(values
- (syntax->datum id1165)
+ (syntax->datum id3529)
(syntax->datum
(cons '#(syntax-object
public
@@ -6580,6 +6801,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -6701,6 +6923,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -6812,36 +7035,37 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
((top) (top))
("i" "i")))
(hygiene guile))
- mod1164))))
- tmp1158)
+ mod3528))))
+ tmp3522)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1157)))
- ($sc-dispatch tmp1157 (quote (any each-any any)))))
- e1156)))
- (global-extend112
+ tmp3521)))
+ ($sc-dispatch tmp3521 (quote (any each-any any)))))
+ e3520)))
+ (global-extend2474
'module-ref
'@@
- (lambda (e1167)
- ((lambda (tmp1168)
- ((lambda (tmp1169)
- (if (if tmp1169
- (apply (lambda (_1170 mod1171 id1172)
- (if (and-map id?114 mod1171)
- (id?114 id1172)
+ (lambda (e3531)
+ ((lambda (tmp3532)
+ ((lambda (tmp3533)
+ (if (if tmp3533
+ (apply (lambda (_3534 mod3535 id3536)
+ (if (and-map id?2476 mod3535)
+ (id?2476 id3536)
#f))
- tmp1169)
+ tmp3533)
#f)
- (apply (lambda (_1174 mod1175 id1176)
+ (apply (lambda (_3538 mod3539 id3540)
(values
- (syntax->datum id1176)
+ (syntax->datum id3540)
(syntax->datum
(cons '#(syntax-object
private
@@ -6953,6 +7177,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -7074,6 +7299,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -7185,90 +7411,91 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
((top) (top))
("i" "i")))
(hygiene guile))
- mod1175))))
- tmp1169)
+ mod3539))))
+ tmp3533)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1168)))
- ($sc-dispatch tmp1168 (quote (any each-any any)))))
- e1167)))
- (global-extend112
+ tmp3532)))
+ ($sc-dispatch tmp3532 (quote (any each-any any)))))
+ e3531)))
+ (global-extend2474
'core
'if
- (lambda (e1178 r1179 w1180 s1181 mod1182)
- ((lambda (tmp1183)
- ((lambda (tmp1184)
- (if tmp1184
- (apply (lambda (_1185 test1186 then1187)
- (build-conditional82
- s1181
- (chi150 test1186 r1179 w1180 mod1182)
- (chi150 then1187 r1179 w1180 mod1182)
- (build-void80 #f)))
- tmp1184)
- ((lambda (tmp1188)
- (if tmp1188
- (apply (lambda (_1189 test1190 then1191 else1192)
- (build-conditional82
- s1181
- (chi150 test1190 r1179 w1180 mod1182)
- (chi150 then1191 r1179 w1180 mod1182)
- (chi150 else1192 r1179 w1180 mod1182)))
- tmp1188)
+ (lambda (e3542 r3543 w3544 s3545 mod3546)
+ ((lambda (tmp3547)
+ ((lambda (tmp3548)
+ (if tmp3548
+ (apply (lambda (_3549 test3550 then3551)
+ (build-conditional2444
+ s3545
+ (chi2512 test3550 r3543 w3544 mod3546)
+ (chi2512 then3551 r3543 w3544 mod3546)
+ (build-void2442 #f)))
+ tmp3548)
+ ((lambda (tmp3552)
+ (if tmp3552
+ (apply (lambda (_3553 test3554 then3555 else3556)
+ (build-conditional2444
+ s3545
+ (chi2512 test3554 r3543 w3544 mod3546)
+ (chi2512 then3555 r3543 w3544 mod3546)
+ (chi2512 else3556 r3543 w3544 mod3546)))
+ tmp3552)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1183)))
- ($sc-dispatch tmp1183 (quote (any any any any))))))
- ($sc-dispatch tmp1183 (quote (any any any)))))
- e1178)))
- (global-extend112
+ tmp3547)))
+ ($sc-dispatch tmp3547 (quote (any any any any))))))
+ ($sc-dispatch tmp3547 (quote (any any any)))))
+ e3542)))
+ (global-extend2474
'begin
'begin
'())
- (global-extend112
+ (global-extend2474
'define
'define
'())
- (global-extend112
+ (global-extend2474
'define-syntax
'define-syntax
'())
- (global-extend112
+ (global-extend2474
'eval-when
'eval-when
'())
- (global-extend112
+ (global-extend2474
'core
'syntax-case
- (letrec ((gen-syntax-case1196
- (lambda (x1197 keys1198 clauses1199 r1200 mod1201)
- (if (null? clauses1199)
- (build-application81
+ (letrec ((gen-syntax-case3560
+ (lambda (x3561 keys3562 clauses3563 r3564 mod3565)
+ (if (null? clauses3563)
+ (build-application2443
#f
- (build-primref91 #f (quote syntax-violation))
- (list (build-data92 #f #f)
- (build-data92
+ (build-primref2453 #f (quote syntax-violation))
+ (list (build-data2454 #f #f)
+ (build-data2454
#f
"source expression failed to match any pattern")
- x1197))
- ((lambda (tmp1202)
- ((lambda (tmp1203)
- (if tmp1203
- (apply (lambda (pat1204 exp1205)
- (if (if (id?114 pat1204)
+ x3561))
+ ((lambda (tmp3566)
+ ((lambda (tmp3567)
+ (if tmp3567
+ (apply (lambda (pat3568 exp3569)
+ (if (if (id?2476 pat3568)
(and-map
- (lambda (x1206)
- (not (free-id=?137
- pat1204
- x1206)))
+ (lambda (x3570)
+ (not (free-id=?2499
+ pat3568
+ x3570)))
(cons '#(syntax-object
...
((top)
@@ -7404,6 +7631,7 @@
build-conditional
build-application
build-void
+ decorate-source
get-global-definition-hook
put-global-definition-hook
gensym-hook
@@ -7525,6 +7753,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -7636,6 +7865,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -7643,620 +7873,623 @@
((top) (top))
("i" "i")))
(hygiene guile))
- keys1198))
+ keys3562))
#f)
- (let ((labels1207
- (list (gen-label119)))
- (var1208 (gen-var161 pat1204)))
- (build-application81
+ (let ((labels3571
+ (list (gen-label2481)))
+ (var3572
+ (gen-var2523 pat3568)))
+ (build-application2443
#f
- (build-lambda90
+ (build-lambda2452
#f
- (list (syntax->datum pat1204))
- (list var1208)
+ (list (syntax->datum pat3568))
+ (list var3572)
#f
- (chi150
- exp1205
- (extend-env108
- labels1207
+ (chi2512
+ exp3569
+ (extend-env2470
+ labels3571
(list (cons 'syntax
- (cons var1208
+ (cons var3572
0)))
- r1200)
- (make-binding-wrap131
- (list pat1204)
- labels1207
+ r3564)
+ (make-binding-wrap2493
+ (list pat3568)
+ labels3571
'(()))
- mod1201))
- (list x1197)))
- (gen-clause1195
- x1197
- keys1198
- (cdr clauses1199)
- r1200
- pat1204
+ mod3565))
+ (list x3561)))
+ (gen-clause3559
+ x3561
+ keys3562
+ (cdr clauses3563)
+ r3564
+ pat3568
#t
- exp1205
- mod1201)))
- tmp1203)
- ((lambda (tmp1209)
- (if tmp1209
- (apply (lambda (pat1210 fender1211 exp1212)
- (gen-clause1195
- x1197
- keys1198
- (cdr clauses1199)
- r1200
- pat1210
- fender1211
- exp1212
- mod1201))
- tmp1209)
- ((lambda (_1213)
+ exp3569
+ mod3565)))
+ tmp3567)
+ ((lambda (tmp3573)
+ (if tmp3573
+ (apply (lambda (pat3574 fender3575 exp3576)
+ (gen-clause3559
+ x3561
+ keys3562
+ (cdr clauses3563)
+ r3564
+ pat3574
+ fender3575
+ exp3576
+ mod3565))
+ tmp3573)
+ ((lambda (_3577)
(syntax-violation
'syntax-case
"invalid clause"
- (car clauses1199)))
- tmp1202)))
- ($sc-dispatch tmp1202 (quote (any any any))))))
- ($sc-dispatch tmp1202 (quote (any any)))))
- (car clauses1199)))))
- (gen-clause1195
- (lambda (x1214
- keys1215
- clauses1216
- r1217
- pat1218
- fender1219
- exp1220
- mod1221)
+ (car clauses3563)))
+ tmp3566)))
+ ($sc-dispatch tmp3566 (quote (any any any))))))
+ ($sc-dispatch tmp3566 (quote (any any)))))
+ (car clauses3563)))))
+ (gen-clause3559
+ (lambda (x3578
+ keys3579
+ clauses3580
+ r3581
+ pat3582
+ fender3583
+ exp3584
+ mod3585)
(call-with-values
(lambda ()
- (convert-pattern1193 pat1218 keys1215))
- (lambda (p1222 pvars1223)
- (if (not (distinct-bound-ids?140 (map car pvars1223)))
+ (convert-pattern3557 pat3582 keys3579))
+ (lambda (p3586 pvars3587)
+ (if (not (distinct-bound-ids?2502
+ (map car pvars3587)))
(syntax-violation
'syntax-case
"duplicate pattern variable"
- pat1218)
+ pat3582)
(if (not (and-map
- (lambda (x1224)
- (not (ellipsis?159 (car x1224))))
- pvars1223))
+ (lambda (x3588)
+ (not (ellipsis?2521 (car x3588))))
+ pvars3587))
(syntax-violation
'syntax-case
"misplaced ellipsis"
- pat1218)
- (let ((y1225 (gen-var161 (quote tmp))))
- (build-application81
+ pat3582)
+ (let ((y3589 (gen-var2523 (quote tmp))))
+ (build-application2443
#f
- (build-lambda90
+ (build-lambda2452
#f
(list (quote tmp))
- (list y1225)
+ (list y3589)
#f
- (let ((y1226 (build-lexical-reference83
+ (let ((y3590 (build-lexical-reference2445
'value
#f
'tmp
- y1225)))
- (build-conditional82
+ y3589)))
+ (build-conditional2444
#f
- ((lambda (tmp1227)
- ((lambda (tmp1228)
- (if tmp1228
- (apply (lambda () y1226)
- tmp1228)
- ((lambda (_1229)
- (build-conditional82
+ ((lambda (tmp3591)
+ ((lambda (tmp3592)
+ (if tmp3592
+ (apply (lambda () y3590)
+ tmp3592)
+ ((lambda (_3593)
+ (build-conditional2444
#f
- y1226
- (build-dispatch-call1194
- pvars1223
- fender1219
- y1226
- r1217
- mod1221)
- (build-data92 #f #f)))
- tmp1227)))
+ y3590
+ (build-dispatch-call3558
+ pvars3587
+ fender3583
+ y3590
+ r3581
+ mod3585)
+ (build-data2454 #f #f)))
+ tmp3591)))
($sc-dispatch
- tmp1227
+ tmp3591
'#(atom #t))))
- fender1219)
- (build-dispatch-call1194
- pvars1223
- exp1220
- y1226
- r1217
- mod1221)
- (gen-syntax-case1196
- x1214
- keys1215
- clauses1216
- r1217
- mod1221))))
- (list (if (eq? p1222 (quote any))
- (build-application81
+ fender3583)
+ (build-dispatch-call3558
+ pvars3587
+ exp3584
+ y3590
+ r3581
+ mod3585)
+ (gen-syntax-case3560
+ x3578
+ keys3579
+ clauses3580
+ r3581
+ mod3585))))
+ (list (if (eq? p3586 (quote any))
+ (build-application2443
#f
- (build-primref91 #f (quote list))
- (list x1214))
- (build-application81
+ (build-primref2453 #f (quote list))
+ (list x3578))
+ (build-application2443
#f
- (build-primref91
+ (build-primref2453
#f
'$sc-dispatch)
- (list x1214
- (build-data92
+ (list x3578
+ (build-data2454
#f
- p1222)))))))))))))
- (build-dispatch-call1194
- (lambda (pvars1230 exp1231 y1232 r1233 mod1234)
- (let ((ids1235 (map car pvars1230))
- (levels1236 (map cdr pvars1230)))
- (let ((labels1237 (gen-labels120 ids1235))
- (new-vars1238 (map gen-var161 ids1235)))
- (build-application81
+ p3586)))))))))))))
+ (build-dispatch-call3558
+ (lambda (pvars3594 exp3595 y3596 r3597 mod3598)
+ (let ((ids3599 (map car pvars3594))
+ (levels3600 (map cdr pvars3594)))
+ (let ((labels3601 (gen-labels2482 ids3599))
+ (new-vars3602 (map gen-var2523 ids3599)))
+ (build-application2443
#f
- (build-primref91 #f (quote apply))
- (list (build-lambda90
+ (build-primref2453 #f (quote apply))
+ (list (build-lambda2452
#f
- (map syntax->datum ids1235)
- new-vars1238
+ (map syntax->datum ids3599)
+ new-vars3602
#f
- (chi150
- exp1231
- (extend-env108
- labels1237
- (map (lambda (var1239 level1240)
+ (chi2512
+ exp3595
+ (extend-env2470
+ labels3601
+ (map (lambda (var3603 level3604)
(cons 'syntax
- (cons var1239 level1240)))
- new-vars1238
- (map cdr pvars1230))
- r1233)
- (make-binding-wrap131
- ids1235
- labels1237
+ (cons var3603 level3604)))
+ new-vars3602
+ (map cdr pvars3594))
+ r3597)
+ (make-binding-wrap2493
+ ids3599
+ labels3601
'(()))
- mod1234))
- y1232))))))
- (convert-pattern1193
- (lambda (pattern1241 keys1242)
- (letrec ((cvt1243
- (lambda (p1244 n1245 ids1246)
- (if (id?114 p1244)
- (if (bound-id-member?141 p1244 keys1242)
+ mod3598))
+ y3596))))))
+ (convert-pattern3557
+ (lambda (pattern3605 keys3606)
+ (letrec ((cvt3607
+ (lambda (p3608 n3609 ids3610)
+ (if (id?2476 p3608)
+ (if (bound-id-member?2503 p3608 keys3606)
(values
- (vector (quote free-id) p1244)
- ids1246)
+ (vector (quote free-id) p3608)
+ ids3610)
(values
'any
- (cons (cons p1244 n1245) ids1246)))
- ((lambda (tmp1247)
- ((lambda (tmp1248)
- (if (if tmp1248
- (apply (lambda (x1249 dots1250)
- (ellipsis?159
- dots1250))
- tmp1248)
+ (cons (cons p3608 n3609) ids3610)))
+ ((lambda (tmp3611)
+ ((lambda (tmp3612)
+ (if (if tmp3612
+ (apply (lambda (x3613 dots3614)
+ (ellipsis?2521
+ dots3614))
+ tmp3612)
#f)
- (apply (lambda (x1251 dots1252)
+ (apply (lambda (x3615 dots3616)
(call-with-values
(lambda ()
- (cvt1243
- x1251
- (fx+72 n1245 1)
- ids1246))
- (lambda (p1253 ids1254)
+ (cvt3607
+ x3615
+ (fx+2433 n3609 1)
+ ids3610))
+ (lambda (p3617 ids3618)
(values
- (if (eq? p1253
+ (if (eq? p3617
'any)
'each-any
(vector
'each
- p1253))
- ids1254))))
- tmp1248)
- ((lambda (tmp1255)
- (if tmp1255
- (apply (lambda (x1256 y1257)
+ p3617))
+ ids3618))))
+ tmp3612)
+ ((lambda (tmp3619)
+ (if tmp3619
+ (apply (lambda (x3620 y3621)
(call-with-values
(lambda ()
- (cvt1243
- y1257
- n1245
- ids1246))
- (lambda (y1258
- ids1259)
+ (cvt3607
+ y3621
+ n3609
+ ids3610))
+ (lambda (y3622
+ ids3623)
(call-with-values
(lambda ()
- (cvt1243
- x1256
- n1245
- ids1259))
- (lambda (x1260
- ids1261)
+ (cvt3607
+ x3620
+ n3609
+ ids3623))
+ (lambda (x3624
+ ids3625)
(values
- (cons x1260
- y1258)
- ids1261))))))
- tmp1255)
- ((lambda (tmp1262)
- (if tmp1262
+ (cons x3624
+ y3622)
+ ids3625))))))
+ tmp3619)
+ ((lambda (tmp3626)
+ (if tmp3626
(apply (lambda ()
(values
'()
- ids1246))
- tmp1262)
- ((lambda (tmp1263)
- (if tmp1263
- (apply (lambda (x1264)
+ ids3610))
+ tmp3626)
+ ((lambda (tmp3627)
+ (if tmp3627
+ (apply (lambda (x3628)
(call-with-values
(lambda ()
- (cvt1243
- x1264
- n1245
- ids1246))
- (lambda (p1266
- ids1267)
+ (cvt3607
+ x3628
+ n3609
+ ids3610))
+ (lambda (p3630
+ ids3631)
(values
(vector
'vector
- p1266)
- ids1267))))
- tmp1263)
- ((lambda (x1268)
+ p3630)
+ ids3631))))
+ tmp3627)
+ ((lambda (x3632)
(values
(vector
'atom
- (strip160
- p1244
+ (strip2522
+ p3608
'(())))
- ids1246))
- tmp1247)))
+ ids3610))
+ tmp3611)))
($sc-dispatch
- tmp1247
+ tmp3611
'#(vector
each-any)))))
($sc-dispatch
- tmp1247
+ tmp3611
'()))))
($sc-dispatch
- tmp1247
+ tmp3611
'(any . any)))))
($sc-dispatch
- tmp1247
+ tmp3611
'(any any))))
- p1244)))))
- (cvt1243 pattern1241 0 (quote ()))))))
- (lambda (e1269 r1270 w1271 s1272 mod1273)
- (let ((e1274 (source-wrap143 e1269 w1271 s1272 mod1273)))
- ((lambda (tmp1275)
- ((lambda (tmp1276)
- (if tmp1276
- (apply (lambda (_1277 val1278 key1279 m1280)
+ p3608)))))
+ (cvt3607 pattern3605 0 (quote ()))))))
+ (lambda (e3633 r3634 w3635 s3636 mod3637)
+ (let ((e3638 (source-wrap2505 e3633 w3635 s3636 mod3637)))
+ ((lambda (tmp3639)
+ ((lambda (tmp3640)
+ (if tmp3640
+ (apply (lambda (_3641 val3642 key3643 m3644)
(if (and-map
- (lambda (x1281)
- (if (id?114 x1281)
- (not (ellipsis?159 x1281))
+ (lambda (x3645)
+ (if (id?2476 x3645)
+ (not (ellipsis?2521 x3645))
#f))
- key1279)
- (let ((x1283 (gen-var161 (quote tmp))))
- (build-application81
- s1272
- (build-lambda90
+ key3643)
+ (let ((x3647 (gen-var2523 (quote tmp))))
+ (build-application2443
+ s3636
+ (build-lambda2452
#f
(list (quote tmp))
- (list x1283)
+ (list x3647)
#f
- (gen-syntax-case1196
- (build-lexical-reference83
+ (gen-syntax-case3560
+ (build-lexical-reference2445
'value
#f
'tmp
- x1283)
- key1279
- m1280
- r1270
- mod1273))
- (list (chi150
- val1278
- r1270
+ x3647)
+ key3643
+ m3644
+ r3634
+ mod3637))
+ (list (chi2512
+ val3642
+ r3634
'(())
- mod1273))))
+ mod3637))))
(syntax-violation
'syntax-case
"invalid literals list"
- e1274)))
- tmp1276)
+ e3638)))
+ tmp3640)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1275)))
+ tmp3639)))
($sc-dispatch
- tmp1275
+ tmp3639
'(any any each-any . each-any))))
- e1274)))))
+ e3638)))))
(set! sc-expand
- (lambda (x1287 . rest1286)
- (if (if (pair? x1287)
- (equal? (car x1287) noexpand70)
+ (lambda (x3651 . rest3650)
+ (if (if (pair? x3651)
+ (equal? (car x3651) noexpand2431)
#f)
- (cadr x1287)
- (let ((m1288 (if (null? rest1286) (quote e) (car rest1286)))
- (esew1289
- (if (let ((t1290 (null? rest1286)))
- (if t1290 t1290 (null? (cdr rest1286))))
+ (cadr x3651)
+ (let ((m3652 (if (null? rest3650) (quote e) (car rest3650)))
+ (esew3653
+ (if (let ((t3654 (null? rest3650)))
+ (if t3654 t3654 (null? (cdr rest3650))))
'(eval)
- (cadr rest1286))))
+ (cadr rest3650))))
(with-fluid*
- *mode*71
- m1288
+ *mode*2432
+ m3652
(lambda ()
- (chi-top149
- x1287
+ (chi-top2511
+ x3651
'()
'((top))
- m1288
- esew1289
+ m3652
+ esew3653
(cons 'hygiene
(module-name (current-module))))))))))
(set! identifier?
- (lambda (x1291) (nonsymbol-id?113 x1291)))
+ (lambda (x3655) (nonsymbol-id?2475 x3655)))
(set! datum->syntax
- (lambda (id1292 datum1293)
- (make-syntax-object97
- datum1293
- (syntax-object-wrap100 id1292)
+ (lambda (id3656 datum3657)
+ (make-syntax-object2459
+ datum3657
+ (syntax-object-wrap2462 id3656)
#f)))
(set! syntax->datum
- (lambda (x1294) (strip160 x1294 (quote (())))))
+ (lambda (x3658) (strip2522 x3658 (quote (())))))
(set! generate-temporaries
- (lambda (ls1295)
+ (lambda (ls3659)
(begin
- (let ((x1296 ls1295))
- (if (not (list? x1296))
+ (let ((x3660 ls3659))
+ (if (not (list? x3660))
(syntax-violation
'generate-temporaries
"invalid argument"
- x1296)))
- (map (lambda (x1297)
- (wrap142 (gensym) (quote ((top))) #f))
- ls1295))))
+ x3660)))
+ (map (lambda (x3661)
+ (wrap2504 (gensym) (quote ((top))) #f))
+ ls3659))))
(set! free-identifier=?
- (lambda (x1298 y1299)
+ (lambda (x3662 y3663)
(begin
- (let ((x1300 x1298))
- (if (not (nonsymbol-id?113 x1300))
+ (let ((x3664 x3662))
+ (if (not (nonsymbol-id?2475 x3664))
(syntax-violation
'free-identifier=?
"invalid argument"
- x1300)))
- (let ((x1301 y1299))
- (if (not (nonsymbol-id?113 x1301))
+ x3664)))
+ (let ((x3665 y3663))
+ (if (not (nonsymbol-id?2475 x3665))
(syntax-violation
'free-identifier=?
"invalid argument"
- x1301)))
- (free-id=?137 x1298 y1299))))
+ x3665)))
+ (free-id=?2499 x3662 y3663))))
(set! bound-identifier=?
- (lambda (x1302 y1303)
+ (lambda (x3666 y3667)
(begin
- (let ((x1304 x1302))
- (if (not (nonsymbol-id?113 x1304))
+ (let ((x3668 x3666))
+ (if (not (nonsymbol-id?2475 x3668))
(syntax-violation
'bound-identifier=?
"invalid argument"
- x1304)))
- (let ((x1305 y1303))
- (if (not (nonsymbol-id?113 x1305))
+ x3668)))
+ (let ((x3669 y3667))
+ (if (not (nonsymbol-id?2475 x3669))
(syntax-violation
'bound-identifier=?
"invalid argument"
- x1305)))
- (bound-id=?138 x1302 y1303))))
+ x3669)))
+ (bound-id=?2500 x3666 y3667))))
(set! syntax-violation
- (lambda (who1309 message1308 form1307 . subform1306)
+ (lambda (who3673 message3672 form3671 . subform3670)
(begin
- (let ((x1310 who1309))
- (if (not ((lambda (x1311)
- (let ((t1312 (not x1311)))
- (if t1312
- t1312
- (let ((t1313 (string? x1311)))
- (if t1313 t1313 (symbol? x1311))))))
- x1310))
+ (let ((x3674 who3673))
+ (if (not ((lambda (x3675)
+ (let ((t3676 (not x3675)))
+ (if t3676
+ t3676
+ (let ((t3677 (string? x3675)))
+ (if t3677 t3677 (symbol? x3675))))))
+ x3674))
(syntax-violation
'syntax-violation
"invalid argument"
- x1310)))
- (let ((x1314 message1308))
- (if (not (string? x1314))
+ x3674)))
+ (let ((x3678 message3672))
+ (if (not (string? x3678))
(syntax-violation
'syntax-violation
"invalid argument"
- x1314)))
+ x3678)))
(scm-error
'syntax-error
'sc-expand
(string-append
- (if who1309 "~a: " "")
+ (if who3673 "~a: " "")
"~a "
- (if (null? subform1306)
+ (if (null? subform3670)
"in ~a"
"in subform `~s' of `~s'"))
- (let ((tail1315
- (cons message1308
- (map (lambda (x1316) (strip160 x1316 (quote (()))))
- (append subform1306 (list form1307))))))
- (if who1309 (cons who1309 tail1315) tail1315))
+ (let ((tail3679
+ (cons message3672
+ (map (lambda (x3680)
+ (strip2522 x3680 (quote (()))))
+ (append subform3670 (list form3671))))))
+ (if who3673 (cons who3673 tail3679) tail3679))
#f))))
- (letrec ((match1321
- (lambda (e1322 p1323 w1324 r1325 mod1326)
- (if (not r1325)
+ (letrec ((match3685
+ (lambda (e3686 p3687 w3688 r3689 mod3690)
+ (if (not r3689)
#f
- (if (eq? p1323 (quote any))
- (cons (wrap142 e1322 w1324 mod1326) r1325)
- (if (syntax-object?98 e1322)
- (match*1320
- (syntax-object-expression99 e1322)
- p1323
- (join-wraps133
- w1324
- (syntax-object-wrap100 e1322))
- r1325
- (syntax-object-module101 e1322))
- (match*1320 e1322 p1323 w1324 r1325 mod1326))))))
- (match*1320
- (lambda (e1327 p1328 w1329 r1330 mod1331)
- (if (null? p1328)
- (if (null? e1327) r1330 #f)
- (if (pair? p1328)
- (if (pair? e1327)
- (match1321
- (car e1327)
- (car p1328)
- w1329
- (match1321
- (cdr e1327)
- (cdr p1328)
- w1329
- r1330
- mod1331)
- mod1331)
+ (if (eq? p3687 (quote any))
+ (cons (wrap2504 e3686 w3688 mod3690) r3689)
+ (if (syntax-object?2460 e3686)
+ (match*3684
+ (syntax-object-expression2461 e3686)
+ p3687
+ (join-wraps2495
+ w3688
+ (syntax-object-wrap2462 e3686))
+ r3689
+ (syntax-object-module2463 e3686))
+ (match*3684 e3686 p3687 w3688 r3689 mod3690))))))
+ (match*3684
+ (lambda (e3691 p3692 w3693 r3694 mod3695)
+ (if (null? p3692)
+ (if (null? e3691) r3694 #f)
+ (if (pair? p3692)
+ (if (pair? e3691)
+ (match3685
+ (car e3691)
+ (car p3692)
+ w3693
+ (match3685
+ (cdr e3691)
+ (cdr p3692)
+ w3693
+ r3694
+ mod3695)
+ mod3695)
#f)
- (if (eq? p1328 (quote each-any))
- (let ((l1332 (match-each-any1318
- e1327
- w1329
- mod1331)))
- (if l1332 (cons l1332 r1330) #f))
- (let ((atom-key1333 (vector-ref p1328 0)))
- (if (memv atom-key1333 (quote (each)))
- (if (null? e1327)
- (match-empty1319 (vector-ref p1328 1) r1330)
- (let ((l1334 (match-each1317
- e1327
- (vector-ref p1328 1)
- w1329
- mod1331)))
- (if l1334
- (letrec ((collect1335
- (lambda (l1336)
- (if (null? (car l1336))
- r1330
- (cons (map car l1336)
- (collect1335
- (map cdr l1336)))))))
- (collect1335 l1334))
+ (if (eq? p3692 (quote each-any))
+ (let ((l3696 (match-each-any3682
+ e3691
+ w3693
+ mod3695)))
+ (if l3696 (cons l3696 r3694) #f))
+ (let ((atom-key3697 (vector-ref p3692 0)))
+ (if (memv atom-key3697 (quote (each)))
+ (if (null? e3691)
+ (match-empty3683 (vector-ref p3692 1) r3694)
+ (let ((l3698 (match-each3681
+ e3691
+ (vector-ref p3692 1)
+ w3693
+ mod3695)))
+ (if l3698
+ (letrec ((collect3699
+ (lambda (l3700)
+ (if (null? (car l3700))
+ r3694
+ (cons (map car l3700)
+ (collect3699
+ (map cdr l3700)))))))
+ (collect3699 l3698))
#f)))
- (if (memv atom-key1333 (quote (free-id)))
- (if (id?114 e1327)
- (if (free-id=?137
- (wrap142 e1327 w1329 mod1331)
- (vector-ref p1328 1))
- r1330
+ (if (memv atom-key3697 (quote (free-id)))
+ (if (id?2476 e3691)
+ (if (free-id=?2499
+ (wrap2504 e3691 w3693 mod3695)
+ (vector-ref p3692 1))
+ r3694
#f)
#f)
- (if (memv atom-key1333 (quote (atom)))
+ (if (memv atom-key3697 (quote (atom)))
(if (equal?
- (vector-ref p1328 1)
- (strip160 e1327 w1329))
- r1330
+ (vector-ref p3692 1)
+ (strip2522 e3691 w3693))
+ r3694
#f)
- (if (memv atom-key1333 (quote (vector)))
- (if (vector? e1327)
- (match1321
- (vector->list e1327)
- (vector-ref p1328 1)
- w1329
- r1330
- mod1331)
+ (if (memv atom-key3697 (quote (vector)))
+ (if (vector? e3691)
+ (match3685
+ (vector->list e3691)
+ (vector-ref p3692 1)
+ w3693
+ r3694
+ mod3695)
#f)))))))))))
- (match-empty1319
- (lambda (p1337 r1338)
- (if (null? p1337)
- r1338
- (if (eq? p1337 (quote any))
- (cons (quote ()) r1338)
- (if (pair? p1337)
- (match-empty1319
- (car p1337)
- (match-empty1319 (cdr p1337) r1338))
- (if (eq? p1337 (quote each-any))
- (cons (quote ()) r1338)
- (let ((atom-key1339 (vector-ref p1337 0)))
- (if (memv atom-key1339 (quote (each)))
- (match-empty1319 (vector-ref p1337 1) r1338)
- (if (memv atom-key1339 (quote (free-id atom)))
- r1338
- (if (memv atom-key1339 (quote (vector)))
- (match-empty1319
- (vector-ref p1337 1)
- r1338)))))))))))
- (match-each-any1318
- (lambda (e1340 w1341 mod1342)
- (if (pair? e1340)
- (let ((l1343 (match-each-any1318
- (cdr e1340)
- w1341
- mod1342)))
- (if l1343
- (cons (wrap142 (car e1340) w1341 mod1342) l1343)
+ (match-empty3683
+ (lambda (p3701 r3702)
+ (if (null? p3701)
+ r3702
+ (if (eq? p3701 (quote any))
+ (cons (quote ()) r3702)
+ (if (pair? p3701)
+ (match-empty3683
+ (car p3701)
+ (match-empty3683 (cdr p3701) r3702))
+ (if (eq? p3701 (quote each-any))
+ (cons (quote ()) r3702)
+ (let ((atom-key3703 (vector-ref p3701 0)))
+ (if (memv atom-key3703 (quote (each)))
+ (match-empty3683 (vector-ref p3701 1) r3702)
+ (if (memv atom-key3703 (quote (free-id atom)))
+ r3702
+ (if (memv atom-key3703 (quote (vector)))
+ (match-empty3683
+ (vector-ref p3701 1)
+ r3702)))))))))))
+ (match-each-any3682
+ (lambda (e3704 w3705 mod3706)
+ (if (pair? e3704)
+ (let ((l3707 (match-each-any3682
+ (cdr e3704)
+ w3705
+ mod3706)))
+ (if l3707
+ (cons (wrap2504 (car e3704) w3705 mod3706) l3707)
#f))
- (if (null? e1340)
+ (if (null? e3704)
'()
- (if (syntax-object?98 e1340)
- (match-each-any1318
- (syntax-object-expression99 e1340)
- (join-wraps133
- w1341
- (syntax-object-wrap100 e1340))
- mod1342)
+ (if (syntax-object?2460 e3704)
+ (match-each-any3682
+ (syntax-object-expression2461 e3704)
+ (join-wraps2495
+ w3705
+ (syntax-object-wrap2462 e3704))
+ mod3706)
#f)))))
- (match-each1317
- (lambda (e1344 p1345 w1346 mod1347)
- (if (pair? e1344)
- (let ((first1348
- (match1321
- (car e1344)
- p1345
- w1346
+ (match-each3681
+ (lambda (e3708 p3709 w3710 mod3711)
+ (if (pair? e3708)
+ (let ((first3712
+ (match3685
+ (car e3708)
+ p3709
+ w3710
'()
- mod1347)))
- (if first1348
- (let ((rest1349
- (match-each1317
- (cdr e1344)
- p1345
- w1346
- mod1347)))
- (if rest1349 (cons first1348 rest1349) #f))
+ mod3711)))
+ (if first3712
+ (let ((rest3713
+ (match-each3681
+ (cdr e3708)
+ p3709
+ w3710
+ mod3711)))
+ (if rest3713 (cons first3712 rest3713) #f))
#f))
- (if (null? e1344)
+ (if (null? e3708)
'()
- (if (syntax-object?98 e1344)
- (match-each1317
- (syntax-object-expression99 e1344)
- p1345
- (join-wraps133
- w1346
- (syntax-object-wrap100 e1344))
- (syntax-object-module101 e1344))
+ (if (syntax-object?2460 e3708)
+ (match-each3681
+ (syntax-object-expression2461 e3708)
+ p3709
+ (join-wraps2495
+ w3710
+ (syntax-object-wrap2462 e3708))
+ (syntax-object-module2463 e3708))
#f))))))
(set! $sc-dispatch
- (lambda (e1350 p1351)
- (if (eq? p1351 (quote any))
- (list e1350)
- (if (syntax-object?98 e1350)
- (match*1320
- (syntax-object-expression99 e1350)
- p1351
- (syntax-object-wrap100 e1350)
+ (lambda (e3714 p3715)
+ (if (eq? p3715 (quote any))
+ (list e3714)
+ (if (syntax-object?2460 e3714)
+ (match*3684
+ (syntax-object-expression2461 e3714)
+ p3715
+ (syntax-object-wrap2462 e3714)
'()
- (syntax-object-module101 e1350))
- (match*1320
- e1350
- p1351
+ (syntax-object-module2463 e3714))
+ (match*3684
+ e3714
+ p3715
'(())
'()
#f)))))))))
@@ -8264,11 +8497,11 @@
(define with-syntax
(make-syncase-macro
'macro
- (lambda (x1352)
- ((lambda (tmp1353)
- ((lambda (tmp1354)
- (if tmp1354
- (apply (lambda (_1355 e11356 e21357)
+ (lambda (x3716)
+ ((lambda (tmp3717)
+ ((lambda (tmp3718)
+ (if tmp3718
+ (apply (lambda (_3719 e13720 e23721)
(cons '#(syntax-object
begin
((top)
@@ -8279,11 +8512,11 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- (cons e11356 e21357)))
- tmp1354)
- ((lambda (tmp1359)
- (if tmp1359
- (apply (lambda (_1360 out1361 in1362 e11363 e21364)
+ (cons e13720 e23721)))
+ tmp3718)
+ ((lambda (tmp3723)
+ (if tmp3723
+ (apply (lambda (_3724 out3725 in3726 e13727 e23728)
(list '#(syntax-object
syntax-case
((top)
@@ -8294,9 +8527,9 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- in1362
+ in3726
'()
- (list out1361
+ (list out3725
(cons '#(syntax-object
begin
((top)
@@ -8314,11 +8547,11 @@
#((top))
#("i")))
(hygiene guile))
- (cons e11363 e21364)))))
- tmp1359)
- ((lambda (tmp1366)
- (if tmp1366
- (apply (lambda (_1367 out1368 in1369 e11370 e21371)
+ (cons e13727 e23728)))))
+ tmp3723)
+ ((lambda (tmp3730)
+ (if tmp3730
+ (apply (lambda (_3731 out3732 in3733 e13734 e23735)
(list '#(syntax-object
syntax-case
((top)
@@ -8346,9 +8579,9 @@
#((top))
#("i")))
(hygiene guile))
- in1369)
+ in3733)
'()
- (list out1368
+ (list out3732
(cons '#(syntax-object
begin
((top)
@@ -8370,35 +8603,35 @@
#((top))
#("i")))
(hygiene guile))
- (cons e11370 e21371)))))
- tmp1366)
+ (cons e13734 e23735)))))
+ tmp3730)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1353)))
+ tmp3717)))
($sc-dispatch
- tmp1353
+ tmp3717
'(any #(each (any any)) any . each-any)))))
($sc-dispatch
- tmp1353
+ tmp3717
'(any ((any any)) any . each-any)))))
($sc-dispatch
- tmp1353
+ tmp3717
'(any () any . each-any))))
- x1352))))
+ x3716))))
(define syntax-rules
(make-syncase-macro
'macro
- (lambda (x1375)
- ((lambda (tmp1376)
- ((lambda (tmp1377)
- (if tmp1377
- (apply (lambda (_1378
- k1379
- keyword1380
- pattern1381
- template1382)
+ (lambda (x3739)
+ ((lambda (tmp3740)
+ ((lambda (tmp3741)
+ (if tmp3741
+ (apply (lambda (_3742
+ k3743
+ keyword3744
+ pattern3745
+ template3746)
(list '#(syntax-object
lambda
((top)
@@ -8439,8 +8672,8 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- (cons k1379
- (map (lambda (tmp1385 tmp1384)
+ (cons k3743
+ (map (lambda (tmp3749 tmp3748)
(list (cons '#(syntax-object
dummy
((top)
@@ -8470,7 +8703,7 @@
#("i")))
(hygiene
guile))
- tmp1384)
+ tmp3748)
(list '#(syntax-object
syntax
((top)
@@ -8500,34 +8733,34 @@
#("i")))
(hygiene
guile))
- tmp1385)))
- template1382
- pattern1381))))))
- tmp1377)
+ tmp3749)))
+ template3746
+ pattern3745))))))
+ tmp3741)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1376)))
+ tmp3740)))
($sc-dispatch
- tmp1376
+ tmp3740
'(any each-any . #(each ((any . any) any))))))
- x1375))))
+ x3739))))
(define let*
(make-extended-syncase-macro
(module-ref (current-module) (quote let*))
'macro
- (lambda (x1386)
- ((lambda (tmp1387)
- ((lambda (tmp1388)
- (if (if tmp1388
- (apply (lambda (let*1389 x1390 v1391 e11392 e21393)
- (and-map identifier? x1390))
- tmp1388)
+ (lambda (x3750)
+ ((lambda (tmp3751)
+ ((lambda (tmp3752)
+ (if (if tmp3752
+ (apply (lambda (let*3753 x3754 v3755 e13756 e23757)
+ (and-map identifier? x3754))
+ tmp3752)
#f)
- (apply (lambda (let*1395 x1396 v1397 e11398 e21399)
- (letrec ((f1400 (lambda (bindings1401)
- (if (null? bindings1401)
+ (apply (lambda (let*3759 x3760 v3761 e13762 e23763)
+ (letrec ((f3764 (lambda (bindings3765)
+ (if (null? bindings3765)
(cons '#(syntax-object
let
((top)
@@ -8551,12 +8784,12 @@
#("i")))
(hygiene guile))
(cons '()
- (cons e11398 e21399)))
- ((lambda (tmp1405)
- ((lambda (tmp1406)
- (if tmp1406
- (apply (lambda (body1407
- binding1408)
+ (cons e13762 e23763)))
+ ((lambda (tmp3769)
+ ((lambda (tmp3770)
+ (if tmp3770
+ (apply (lambda (body3771
+ binding3772)
(list '#(syntax-object
let
((top)
@@ -8604,51 +8837,51 @@
#("i")))
(hygiene
guile))
- (list binding1408)
- body1407))
- tmp1406)
+ (list binding3772)
+ body3771))
+ tmp3770)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1405)))
+ tmp3769)))
($sc-dispatch
- tmp1405
+ tmp3769
'(any any))))
- (list (f1400 (cdr bindings1401))
- (car bindings1401)))))))
- (f1400 (map list x1396 v1397))))
- tmp1388)
+ (list (f3764 (cdr bindings3765))
+ (car bindings3765)))))))
+ (f3764 (map list x3760 v3761))))
+ tmp3752)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1387)))
+ tmp3751)))
($sc-dispatch
- tmp1387
+ tmp3751
'(any #(each (any any)) any . each-any))))
- x1386))))
+ x3750))))
(define do
(make-extended-syncase-macro
(module-ref (current-module) (quote do))
'macro
- (lambda (orig-x1409)
- ((lambda (tmp1410)
- ((lambda (tmp1411)
- (if tmp1411
- (apply (lambda (_1412
- var1413
- init1414
- step1415
- e01416
- e11417
- c1418)
- ((lambda (tmp1419)
- ((lambda (tmp1420)
- (if tmp1420
- (apply (lambda (step1421)
- ((lambda (tmp1422)
- ((lambda (tmp1423)
- (if tmp1423
+ (lambda (orig-x3773)
+ ((lambda (tmp3774)
+ ((lambda (tmp3775)
+ (if tmp3775
+ (apply (lambda (_3776
+ var3777
+ init3778
+ step3779
+ e03780
+ e13781
+ c3782)
+ ((lambda (tmp3783)
+ ((lambda (tmp3784)
+ (if tmp3784
+ (apply (lambda (step3785)
+ ((lambda (tmp3786)
+ ((lambda (tmp3787)
+ (if tmp3787
(apply (lambda ()
(list '#(syntax-object
let
@@ -8729,8 +8962,8 @@
(hygiene
guile))
(map list
- var1413
- init1414)
+ var3777
+ init3778)
(list '#(syntax-object
if
((top)
@@ -8809,7 +9042,7 @@
#("i")))
(hygiene
guile))
- e01416)
+ e03780)
(cons '#(syntax-object
begin
((top)
@@ -8850,7 +9083,7 @@
(hygiene
guile))
(append
- c1418
+ c3782
(list (cons '#(syntax-object
doloop
((top)
@@ -8890,12 +9123,12 @@
#("i")))
(hygiene
guile))
- step1421)))))))
- tmp1423)
- ((lambda (tmp1428)
- (if tmp1428
- (apply (lambda (e11429
- e21430)
+ step3785)))))))
+ tmp3787)
+ ((lambda (tmp3792)
+ (if tmp3792
+ (apply (lambda (e13793
+ e23794)
(list '#(syntax-object
let
((top)
@@ -8989,8 +9222,8 @@
(hygiene
guile))
(map list
- var1413
- init1414)
+ var3777
+ init3778)
(list '#(syntax-object
if
((top)
@@ -9037,7 +9270,7 @@
#("i")))
(hygiene
guile))
- e01416
+ e03780
(cons '#(syntax-object
begin
((top)
@@ -9084,8 +9317,8 @@
#("i")))
(hygiene
guile))
- (cons e11429
- e21430))
+ (cons e13793
+ e23794))
(cons '#(syntax-object
begin
((top)
@@ -9133,7 +9366,7 @@
(hygiene
guile))
(append
- c1418
+ c3782
(list (cons '#(syntax-object
doloop
((top)
@@ -9180,75 +9413,75 @@
#("i")))
(hygiene
guile))
- step1421)))))))
- tmp1428)
+ step3785)))))))
+ tmp3792)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1422)))
+ tmp3786)))
($sc-dispatch
- tmp1422
+ tmp3786
'(any . each-any)))))
- ($sc-dispatch tmp1422 (quote ()))))
- e11417))
- tmp1420)
+ ($sc-dispatch tmp3786 (quote ()))))
+ e13781))
+ tmp3784)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1419)))
- ($sc-dispatch tmp1419 (quote each-any))))
- (map (lambda (v1437 s1438)
- ((lambda (tmp1439)
- ((lambda (tmp1440)
- (if tmp1440
- (apply (lambda () v1437) tmp1440)
- ((lambda (tmp1441)
- (if tmp1441
- (apply (lambda (e1442) e1442)
- tmp1441)
- ((lambda (_1443)
+ tmp3783)))
+ ($sc-dispatch tmp3783 (quote each-any))))
+ (map (lambda (v3801 s3802)
+ ((lambda (tmp3803)
+ ((lambda (tmp3804)
+ (if tmp3804
+ (apply (lambda () v3801) tmp3804)
+ ((lambda (tmp3805)
+ (if tmp3805
+ (apply (lambda (e3806) e3806)
+ tmp3805)
+ ((lambda (_3807)
(syntax-violation
'do
"bad step expression"
- orig-x1409
- s1438))
- tmp1439)))
- ($sc-dispatch tmp1439 (quote (any))))))
- ($sc-dispatch tmp1439 (quote ()))))
- s1438))
- var1413
- step1415)))
- tmp1411)
+ orig-x3773
+ s3802))
+ tmp3803)))
+ ($sc-dispatch tmp3803 (quote (any))))))
+ ($sc-dispatch tmp3803 (quote ()))))
+ s3802))
+ var3777
+ step3779)))
+ tmp3775)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1410)))
+ tmp3774)))
($sc-dispatch
- tmp1410
+ tmp3774
'(any #(each (any any . any))
(any . each-any)
.
each-any))))
- orig-x1409))))
+ orig-x3773))))
(define quasiquote
(make-extended-syncase-macro
(module-ref (current-module) (quote quasiquote))
'macro
- (letrec ((quasicons1446
- (lambda (x1450 y1451)
- ((lambda (tmp1452)
- ((lambda (tmp1453)
- (if tmp1453
- (apply (lambda (x1454 y1455)
- ((lambda (tmp1456)
- ((lambda (tmp1457)
- (if tmp1457
- (apply (lambda (dy1458)
- ((lambda (tmp1459)
- ((lambda (tmp1460)
- (if tmp1460
- (apply (lambda (dx1461)
+ (letrec ((quasicons3810
+ (lambda (x3814 y3815)
+ ((lambda (tmp3816)
+ ((lambda (tmp3817)
+ (if tmp3817
+ (apply (lambda (x3818 y3819)
+ ((lambda (tmp3820)
+ ((lambda (tmp3821)
+ (if tmp3821
+ (apply (lambda (dy3822)
+ ((lambda (tmp3823)
+ ((lambda (tmp3824)
+ (if tmp3824
+ (apply (lambda (dx3825)
(list '#(syntax-object
quote
((top)
@@ -9297,11 +9530,11 @@
"i")))
(hygiene
guile))
- (cons dx1461
- dy1458)))
- tmp1460)
- ((lambda (_1462)
- (if (null? dy1458)
+ (cons dx3825
+ dy3822)))
+ tmp3824)
+ ((lambda (_3826)
+ (if (null? dy3822)
(list '#(syntax-object
list
((top)
@@ -9350,7 +9583,7 @@
"i")))
(hygiene
guile))
- x1454)
+ x3818)
(list '#(syntax-object
cons
((top)
@@ -9399,11 +9632,11 @@
"i")))
(hygiene
guile))
- x1454
- y1455)))
- tmp1459)))
+ x3818
+ y3819)))
+ tmp3823)))
($sc-dispatch
- tmp1459
+ tmp3823
'(#(free-id
#(syntax-object
quote
@@ -9446,11 +9679,11 @@
(hygiene
guile)))
any))))
- x1454))
- tmp1457)
- ((lambda (tmp1463)
- (if tmp1463
- (apply (lambda (stuff1464)
+ x3818))
+ tmp3821)
+ ((lambda (tmp3827)
+ (if tmp3827
+ (apply (lambda (stuff3828)
(cons '#(syntax-object
list
((top)
@@ -9491,10 +9724,10 @@
"i")))
(hygiene
guile))
- (cons x1454
- stuff1464)))
- tmp1463)
- ((lambda (else1465)
+ (cons x3818
+ stuff3828)))
+ tmp3827)
+ ((lambda (else3829)
(list '#(syntax-object
cons
((top)
@@ -9526,11 +9759,11 @@
"i"
"i")))
(hygiene guile))
- x1454
- y1455))
- tmp1456)))
+ x3818
+ y3819))
+ tmp3820)))
($sc-dispatch
- tmp1456
+ tmp3820
'(#(free-id
#(syntax-object
list
@@ -9559,7 +9792,7 @@
.
any)))))
($sc-dispatch
- tmp1456
+ tmp3820
'(#(free-id
#(syntax-object
quote
@@ -9583,25 +9816,25 @@
#("i" "i" "i" "i")))
(hygiene guile)))
any))))
- y1455))
- tmp1453)
+ y3819))
+ tmp3817)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1452)))
- ($sc-dispatch tmp1452 (quote (any any)))))
- (list x1450 y1451))))
- (quasiappend1447
- (lambda (x1466 y1467)
- ((lambda (tmp1468)
- ((lambda (tmp1469)
- (if tmp1469
- (apply (lambda (x1470 y1471)
- ((lambda (tmp1472)
- ((lambda (tmp1473)
- (if tmp1473
- (apply (lambda () x1470) tmp1473)
- ((lambda (_1474)
+ tmp3816)))
+ ($sc-dispatch tmp3816 (quote (any any)))))
+ (list x3814 y3815))))
+ (quasiappend3811
+ (lambda (x3830 y3831)
+ ((lambda (tmp3832)
+ ((lambda (tmp3833)
+ (if tmp3833
+ (apply (lambda (x3834 y3835)
+ ((lambda (tmp3836)
+ ((lambda (tmp3837)
+ (if tmp3837
+ (apply (lambda () x3834) tmp3837)
+ ((lambda (_3838)
(list '#(syntax-object
append
((top)
@@ -9630,11 +9863,11 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- x1470
- y1471))
- tmp1472)))
+ x3834
+ y3835))
+ tmp3836)))
($sc-dispatch
- tmp1472
+ tmp3836
'(#(free-id
#(syntax-object
quote
@@ -9658,22 +9891,22 @@
#("i" "i" "i" "i")))
(hygiene guile)))
()))))
- y1471))
- tmp1469)
+ y3835))
+ tmp3833)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1468)))
- ($sc-dispatch tmp1468 (quote (any any)))))
- (list x1466 y1467))))
- (quasivector1448
- (lambda (x1475)
- ((lambda (tmp1476)
- ((lambda (x1477)
- ((lambda (tmp1478)
- ((lambda (tmp1479)
- (if tmp1479
- (apply (lambda (x1480)
+ tmp3832)))
+ ($sc-dispatch tmp3832 (quote (any any)))))
+ (list x3830 y3831))))
+ (quasivector3812
+ (lambda (x3839)
+ ((lambda (tmp3840)
+ ((lambda (x3841)
+ ((lambda (tmp3842)
+ ((lambda (tmp3843)
+ (if tmp3843
+ (apply (lambda (x3844)
(list '#(syntax-object
quote
((top)
@@ -9699,11 +9932,11 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- (list->vector x1480)))
- tmp1479)
- ((lambda (tmp1482)
- (if tmp1482
- (apply (lambda (x1483)
+ (list->vector x3844)))
+ tmp3843)
+ ((lambda (tmp3846)
+ (if tmp3846
+ (apply (lambda (x3847)
(cons '#(syntax-object
vector
((top)
@@ -9732,9 +9965,9 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- x1483))
- tmp1482)
- ((lambda (_1485)
+ x3847))
+ tmp3846)
+ ((lambda (_3849)
(list '#(syntax-object
list->vector
((top)
@@ -9760,10 +9993,10 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- x1477))
- tmp1478)))
+ x3841))
+ tmp3842)))
($sc-dispatch
- tmp1478
+ tmp3842
'(#(free-id
#(syntax-object
list
@@ -9783,7 +10016,7 @@
.
each-any)))))
($sc-dispatch
- tmp1478
+ tmp3842
'(#(free-id
#(syntax-object
quote
@@ -9801,18 +10034,18 @@
#("i" "i" "i" "i")))
(hygiene guile)))
each-any))))
- x1477))
- tmp1476))
- x1475)))
- (quasi1449
- (lambda (p1486 lev1487)
- ((lambda (tmp1488)
- ((lambda (tmp1489)
- (if tmp1489
- (apply (lambda (p1490)
- (if (= lev1487 0)
- p1490
- (quasicons1446
+ x3841))
+ tmp3840))
+ x3839)))
+ (quasi3813
+ (lambda (p3850 lev3851)
+ ((lambda (tmp3852)
+ ((lambda (tmp3853)
+ (if tmp3853
+ (apply (lambda (p3854)
+ (if (= lev3851 0)
+ p3854
+ (quasicons3810
'(#(syntax-object
quote
((top)
@@ -9847,18 +10080,18 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile)))
- (quasi1449 (list p1490) (- lev1487 1)))))
- tmp1489)
- ((lambda (tmp1491)
- (if (if tmp1491
- (apply (lambda (args1492) (= lev1487 0))
- tmp1491)
+ (quasi3813 (list p3854) (- lev3851 1)))))
+ tmp3853)
+ ((lambda (tmp3855)
+ (if (if tmp3855
+ (apply (lambda (args3856) (= lev3851 0))
+ tmp3855)
#f)
- (apply (lambda (args1493)
+ (apply (lambda (args3857)
(syntax-violation
'unquote
"unquote takes exactly one argument"
- p1486
+ p3850
(cons '#(syntax-object
unquote
((top)
@@ -9879,17 +10112,17 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- args1493)))
- tmp1491)
- ((lambda (tmp1494)
- (if tmp1494
- (apply (lambda (p1495 q1496)
- (if (= lev1487 0)
- (quasiappend1447
- p1495
- (quasi1449 q1496 lev1487))
- (quasicons1446
- (quasicons1446
+ args3857)))
+ tmp3855)
+ ((lambda (tmp3858)
+ (if tmp3858
+ (apply (lambda (p3859 q3860)
+ (if (= lev3851 0)
+ (quasiappend3811
+ p3859
+ (quasi3813 q3860 lev3851))
+ (quasicons3810
+ (quasicons3810
'(#(syntax-object
quote
((top)
@@ -9936,22 +10169,22 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile)))
- (quasi1449
- (list p1495)
- (- lev1487 1)))
- (quasi1449 q1496 lev1487))))
- tmp1494)
- ((lambda (tmp1497)
- (if (if tmp1497
- (apply (lambda (args1498 q1499)
- (= lev1487 0))
- tmp1497)
+ (quasi3813
+ (list p3859)
+ (- lev3851 1)))
+ (quasi3813 q3860 lev3851))))
+ tmp3858)
+ ((lambda (tmp3861)
+ (if (if tmp3861
+ (apply (lambda (args3862 q3863)
+ (= lev3851 0))
+ tmp3861)
#f)
- (apply (lambda (args1500 q1501)
+ (apply (lambda (args3864 q3865)
(syntax-violation
'unquote-splicing
"unquote-splicing takes exactly one argument"
- p1486
+ p3850
(cons '#(syntax-object
unquote-splicing
((top)
@@ -9981,12 +10214,12 @@
"i"
"i")))
(hygiene guile))
- args1500)))
- tmp1497)
- ((lambda (tmp1502)
- (if tmp1502
- (apply (lambda (p1503)
- (quasicons1446
+ args3864)))
+ tmp3861)
+ ((lambda (tmp3866)
+ (if tmp3866
+ (apply (lambda (p3867)
+ (quasicons3810
'(#(syntax-object
quote
((top)
@@ -10045,30 +10278,30 @@
"i"
"i")))
(hygiene guile)))
- (quasi1449
- (list p1503)
- (+ lev1487 1))))
- tmp1502)
- ((lambda (tmp1504)
- (if tmp1504
- (apply (lambda (p1505 q1506)
- (quasicons1446
- (quasi1449
- p1505
- lev1487)
- (quasi1449
- q1506
- lev1487)))
- tmp1504)
- ((lambda (tmp1507)
- (if tmp1507
- (apply (lambda (x1508)
- (quasivector1448
- (quasi1449
- x1508
- lev1487)))
- tmp1507)
- ((lambda (p1510)
+ (quasi3813
+ (list p3867)
+ (+ lev3851 1))))
+ tmp3866)
+ ((lambda (tmp3868)
+ (if tmp3868
+ (apply (lambda (p3869 q3870)
+ (quasicons3810
+ (quasi3813
+ p3869
+ lev3851)
+ (quasi3813
+ q3870
+ lev3851)))
+ tmp3868)
+ ((lambda (tmp3871)
+ (if tmp3871
+ (apply (lambda (x3872)
+ (quasivector3812
+ (quasi3813
+ x3872
+ lev3851)))
+ tmp3871)
+ ((lambda (p3874)
(list '#(syntax-object
quote
((top)
@@ -10101,16 +10334,16 @@
"i")))
(hygiene
guile))
- p1510))
- tmp1488)))
+ p3874))
+ tmp3852)))
($sc-dispatch
- tmp1488
+ tmp3852
'#(vector each-any)))))
($sc-dispatch
- tmp1488
+ tmp3852
'(any . any)))))
($sc-dispatch
- tmp1488
+ tmp3852
'(#(free-id
#(syntax-object
quasiquote
@@ -10130,7 +10363,7 @@
(hygiene guile)))
any)))))
($sc-dispatch
- tmp1488
+ tmp3852
'((#(free-id
#(syntax-object
unquote-splicing
@@ -10153,7 +10386,7 @@
.
any)))))
($sc-dispatch
- tmp1488
+ tmp3852
'((#(free-id
#(syntax-object
unquote-splicing
@@ -10175,7 +10408,7 @@
.
any)))))
($sc-dispatch
- tmp1488
+ tmp3852
'(#(free-id
#(syntax-object
unquote
@@ -10193,7 +10426,7 @@
.
any)))))
($sc-dispatch
- tmp1488
+ tmp3852
'(#(free-id
#(syntax-object
unquote
@@ -10206,44 +10439,44 @@
#("i" "i" "i" "i")))
(hygiene guile)))
any))))
- p1486))))
- (lambda (x1511)
- ((lambda (tmp1512)
- ((lambda (tmp1513)
- (if tmp1513
- (apply (lambda (_1514 e1515) (quasi1449 e1515 0))
- tmp1513)
+ p3850))))
+ (lambda (x3875)
+ ((lambda (tmp3876)
+ ((lambda (tmp3877)
+ (if tmp3877
+ (apply (lambda (_3878 e3879) (quasi3813 e3879 0))
+ tmp3877)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1512)))
- ($sc-dispatch tmp1512 (quote (any any)))))
- x1511)))))
+ tmp3876)))
+ ($sc-dispatch tmp3876 (quote (any any)))))
+ x3875)))))
(define include
(make-syncase-macro
'macro
- (lambda (x1516)
- (letrec ((read-file1517
- (lambda (fn1518 k1519)
- (let ((p1520 (open-input-file fn1518)))
- (letrec ((f1521 (lambda (x1522)
- (if (eof-object? x1522)
+ (lambda (x3880)
+ (letrec ((read-file3881
+ (lambda (fn3882 k3883)
+ (let ((p3884 (open-input-file fn3882)))
+ (letrec ((f3885 (lambda (x3886)
+ (if (eof-object? x3886)
(begin
- (close-input-port p1520)
+ (close-input-port p3884)
'())
- (cons (datum->syntax k1519 x1522)
- (f1521 (read p1520)))))))
- (f1521 (read p1520)))))))
- ((lambda (tmp1523)
- ((lambda (tmp1524)
- (if tmp1524
- (apply (lambda (k1525 filename1526)
- (let ((fn1527 (syntax->datum filename1526)))
- ((lambda (tmp1528)
- ((lambda (tmp1529)
- (if tmp1529
- (apply (lambda (exp1530)
+ (cons (datum->syntax k3883 x3886)
+ (f3885 (read p3884)))))))
+ (f3885 (read p3884)))))))
+ ((lambda (tmp3887)
+ ((lambda (tmp3888)
+ (if tmp3888
+ (apply (lambda (k3889 filename3890)
+ (let ((fn3891 (syntax->datum filename3890)))
+ ((lambda (tmp3892)
+ ((lambda (tmp3893)
+ (if tmp3893
+ (apply (lambda (exp3894)
(cons '#(syntax-object
begin
((top)
@@ -10270,73 +10503,73 @@
#((top))
#("i")))
(hygiene guile))
- exp1530))
- tmp1529)
+ exp3894))
+ tmp3893)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1528)))
- ($sc-dispatch tmp1528 (quote each-any))))
- (read-file1517 fn1527 k1525))))
- tmp1524)
+ tmp3892)))
+ ($sc-dispatch tmp3892 (quote each-any))))
+ (read-file3881 fn3891 k3889))))
+ tmp3888)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1523)))
- ($sc-dispatch tmp1523 (quote (any any)))))
- x1516)))))
+ tmp3887)))
+ ($sc-dispatch tmp3887 (quote (any any)))))
+ x3880)))))
(define unquote
(make-syncase-macro
'macro
- (lambda (x1532)
- ((lambda (tmp1533)
- ((lambda (tmp1534)
- (if tmp1534
- (apply (lambda (_1535 e1536)
+ (lambda (x3896)
+ ((lambda (tmp3897)
+ ((lambda (tmp3898)
+ (if tmp3898
+ (apply (lambda (_3899 e3900)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- x1532))
- tmp1534)
+ x3896))
+ tmp3898)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1533)))
- ($sc-dispatch tmp1533 (quote (any any)))))
- x1532))))
+ tmp3897)))
+ ($sc-dispatch tmp3897 (quote (any any)))))
+ x3896))))
(define unquote-splicing
(make-syncase-macro
'macro
- (lambda (x1537)
- ((lambda (tmp1538)
- ((lambda (tmp1539)
- (if tmp1539
- (apply (lambda (_1540 e1541)
+ (lambda (x3901)
+ ((lambda (tmp3902)
+ ((lambda (tmp3903)
+ (if tmp3903
+ (apply (lambda (_3904 e3905)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- x1537))
- tmp1539)
+ x3901))
+ tmp3903)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1538)))
- ($sc-dispatch tmp1538 (quote (any any)))))
- x1537))))
+ tmp3902)))
+ ($sc-dispatch tmp3902 (quote (any any)))))
+ x3901))))
(define case
(make-extended-syncase-macro
(module-ref (current-module) (quote case))
'macro
- (lambda (x1542)
- ((lambda (tmp1543)
- ((lambda (tmp1544)
- (if tmp1544
- (apply (lambda (_1545 e1546 m11547 m21548)
- ((lambda (tmp1549)
- ((lambda (body1550)
+ (lambda (x3906)
+ ((lambda (tmp3907)
+ ((lambda (tmp3908)
+ (if tmp3908
+ (apply (lambda (_3909 e3910 m13911 m23912)
+ ((lambda (tmp3913)
+ ((lambda (body3914)
(list '#(syntax-object
let
((top)
@@ -10365,16 +10598,16 @@
#((top))
#("i")))
(hygiene guile))
- e1546))
- body1550))
- tmp1549))
- (letrec ((f1551 (lambda (clause1552 clauses1553)
- (if (null? clauses1553)
- ((lambda (tmp1555)
- ((lambda (tmp1556)
- (if tmp1556
- (apply (lambda (e11557
- e21558)
+ e3910))
+ body3914))
+ tmp3913))
+ (letrec ((f3915 (lambda (clause3916 clauses3917)
+ (if (null? clauses3917)
+ ((lambda (tmp3919)
+ ((lambda (tmp3920)
+ (if tmp3920
+ (apply (lambda (e13921
+ e23922)
(cons '#(syntax-object
begin
((top)
@@ -10422,14 +10655,14 @@
#("i")))
(hygiene
guile))
- (cons e11557
- e21558)))
- tmp1556)
- ((lambda (tmp1560)
- (if tmp1560
- (apply (lambda (k1561
- e11562
- e21563)
+ (cons e13921
+ e23922)))
+ tmp3920)
+ ((lambda (tmp3924)
+ (if tmp3924
+ (apply (lambda (k3925
+ e13926
+ e23927)
(list '#(syntax-object
if
((top)
@@ -10630,7 +10863,7 @@
#("i")))
(hygiene
guile))
- k1561))
+ k3925))
(cons '#(syntax-object
begin
((top)
@@ -10681,24 +10914,24 @@
#("i")))
(hygiene
guile))
- (cons e11562
- e21563))))
- tmp1560)
- ((lambda (_1566)
+ (cons e13926
+ e23927))))
+ tmp3924)
+ ((lambda (_3930)
(syntax-violation
'case
"bad clause"
- x1542
- clause1552))
- tmp1555)))
+ x3906
+ clause3916))
+ tmp3919)))
($sc-dispatch
- tmp1555
+ tmp3919
'(each-any
any
.
each-any)))))
($sc-dispatch
- tmp1555
+ tmp3919
'(#(free-id
#(syntax-object
else
@@ -10724,15 +10957,15 @@
any
.
each-any))))
- clause1552)
- ((lambda (tmp1567)
- ((lambda (rest1568)
- ((lambda (tmp1569)
- ((lambda (tmp1570)
- (if tmp1570
- (apply (lambda (k1571
- e11572
- e21573)
+ clause3916)
+ ((lambda (tmp3931)
+ ((lambda (rest3932)
+ ((lambda (tmp3933)
+ ((lambda (tmp3934)
+ (if tmp3934
+ (apply (lambda (k3935
+ e13936
+ e23937)
(list '#(syntax-object
if
((top)
@@ -10949,7 +11182,7 @@
#("i")))
(hygiene
guile))
- k1571))
+ k3935))
(cons '#(syntax-object
begin
((top)
@@ -11004,46 +11237,46 @@
#("i")))
(hygiene
guile))
- (cons e11572
- e21573))
- rest1568))
- tmp1570)
- ((lambda (_1576)
+ (cons e13936
+ e23937))
+ rest3932))
+ tmp3934)
+ ((lambda (_3940)
(syntax-violation
'case
"bad clause"
- x1542
- clause1552))
- tmp1569)))
+ x3906
+ clause3916))
+ tmp3933)))
($sc-dispatch
- tmp1569
+ tmp3933
'(each-any
any
.
each-any))))
- clause1552))
- tmp1567))
- (f1551 (car clauses1553)
- (cdr clauses1553)))))))
- (f1551 m11547 m21548))))
- tmp1544)
+ clause3916))
+ tmp3931))
+ (f3915 (car clauses3917)
+ (cdr clauses3917)))))))
+ (f3915 m13911 m23912))))
+ tmp3908)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1543)))
+ tmp3907)))
($sc-dispatch
- tmp1543
+ tmp3907
'(any any any . each-any))))
- x1542))))
+ x3906))))
(define identifier-syntax
(make-syncase-macro
'macro
- (lambda (x1577)
- ((lambda (tmp1578)
- ((lambda (tmp1579)
- (if tmp1579
- (apply (lambda (_1580 e1581)
+ (lambda (x3941)
+ ((lambda (tmp3942)
+ ((lambda (tmp3943)
+ (if tmp3943
+ (apply (lambda (_3944 e3945)
(list '#(syntax-object
lambda
((top)
@@ -11132,8 +11365,8 @@
#((top))
#("i")))
(hygiene guile))
- e1581))
- (list (cons _1580
+ e3945))
+ (list (cons _3944
'(#(syntax-object
x
((top)
@@ -11173,7 +11406,7 @@
#((top))
#("i")))
(hygiene guile))
- (cons e1581
+ (cons e3945
'(#(syntax-object
x
((top)
@@ -11201,11 +11434,11 @@
#("i")))
(hygiene
guile)))))))))
- tmp1579)
+ tmp3943)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1578)))
- ($sc-dispatch tmp1578 (quote (any any)))))
- x1577))))
+ tmp3942)))
+ ($sc-dispatch tmp3942 (quote (any any)))))
+ x3941))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 5f5e86b0f..cbbcabd72 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -337,39 +337,46 @@
)
+(define (decorate-source e s)
+ (if (and (pair? e) s)
+ (set-source-properties! e s))
+ e)
+
;;; output constructors
(define build-void
(lambda (source)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-void) source))
- (else '(if #f #f)))))
+ (else (decorate-source '(if #f #f) source)))))
(define build-application
(lambda (source fun-exp arg-exps)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
- (else `(,fun-exp . ,arg-exps)))))
+ (else (decorate-source `(,fun-exp . ,arg-exps) source)))))
(define build-conditional
(lambda (source test-exp then-exp else-exp)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-conditional)
source test-exp then-exp else-exp))
- (else (if (equal? else-exp '(if #f #f))
- `(if ,test-exp ,then-exp)
- `(if ,test-exp ,then-exp ,else-exp))))))
+ (else (decorate-source
+ (if (equal? else-exp '(if #f #f))
+ `(if ,test-exp ,then-exp)
+ `(if ,test-exp ,then-exp ,else-exp))
+ source)))))
(define build-lexical-reference
(lambda (type source name var)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lexical-ref) source name var))
- (else var))))
+ (else (decorate-source var source)))))
(define build-lexical-assignment
(lambda (source name var exp)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lexical-set) source name var exp))
- (else `(set! ,var ,exp)))))
+ (else (decorate-source `(set! ,var ,exp) source)))))
;; Before modules are booted, we can't expand into data structures from
;; (language tree-il) -- we need to give the evaluator the
@@ -403,11 +410,11 @@
(lambda (mod var public?)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-module-ref) source mod var public?))
- (else (list (if public? '@ '@@) mod var))))
+ (else (decorate-source (list (if public? '@ '@@) mod var) source))))
(lambda (var)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-toplevel-ref) source var))
- (else var))))))
+ (else (decorate-source var source)))))))
(define build-global-assignment
(lambda (source var exp mod)
@@ -416,11 +423,11 @@
(lambda (mod var public?)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
- (else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
+ (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var) ,exp) source))))
(lambda (var)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-toplevel-set) source var exp))
- (else `(set! ,var ,exp)))))))
+ (else (decorate-source `(set! ,var ,exp) source)))))))
;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
;; from working. Hack around it.
@@ -439,7 +446,7 @@
((c)
(maybe-name-value! var exp)
((@ (language tree-il) make-toplevel-define) source var exp))
- (else `(define ,var ,exp)))))
+ (else (decorate-source `(define ,var ,exp) source)))))
(define build-lambda
(lambda (src ids vars docstring exp)
@@ -447,25 +454,29 @@
((c) ((@ (language tree-il) make-lambda) src ids vars
(if docstring `((documentation . ,docstring)) '())
exp))
- (else `(lambda ,vars ,@(if docstring (list docstring) '())
- ,exp)))))
+ (else (decorate-source
+ `(lambda ,vars ,@(if docstring (list docstring) '())
+ ,exp)
+ src)))))
(define build-primref
(lambda (src name)
(if (equal? (module-name (current-module)) '(guile))
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-toplevel-ref) src name))
- (else name))
+ (else (decorate-source name src)))
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
- (else `(@@ (guile) ,name))))))
+ (else (decorate-source `(@@ (guile) ,name) src))))))
(define (build-data src exp)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-const) src exp))
- (else (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- (list 'quote exp)))))
+ (else (decorate-source
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp))
+ src))))
(define build-sequence
(lambda (src exps)
@@ -473,7 +484,7 @@
(car exps)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-sequence) src exps))
- (else `(begin ,@exps))))))
+ (else (decorate-source `(begin ,@exps) src))))))
(define build-let
(lambda (src ids vars val-exps body-exp)
@@ -483,7 +494,9 @@
((c)
(for-each maybe-name-value! ids val-exps)
((@ (language tree-il) make-let) src ids vars val-exps body-exp))
- (else `(let ,(map list vars val-exps) ,body-exp))))))
+ (else (decorate-source
+ `(let ,(map list vars val-exps) ,body-exp)
+ src))))))
(define build-named-let
(lambda (src ids vars val-exps body-exp)
@@ -500,7 +513,9 @@
(list f-name) (list f) (list proc)
(build-application src (build-lexical-reference 'fun src f-name f)
val-exps))))
- (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
+ (else (decorate-source
+ `(let ,f ,(map list vars val-exps) ,body-exp)
+ src))))))
(define build-letrec
(lambda (src ids vars val-exps body-exp)
@@ -510,7 +525,9 @@
((c)
(for-each maybe-name-value! ids val-exps)
((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
- (else `(letrec ,(map list vars val-exps) ,body-exp))))))
+ (else (decorate-source
+ `(letrec ,(map list vars val-exps) ,body-exp)
+ src))))))
;; FIXME: wingo: use make-lexical ?
(define-syntax build-lexical-var