module/slib/scaexpp.scm

   1 ;;; "scaexpp.scm" syntax-case macros
   2 ;;; Copyright (C) 1992 R. Kent Dybvig
   3 ;;;
   4 ;;; Permission to copy this software, in whole or in part, to use this
   5 ;;; software for any lawful purpose, and to redistribute this software
   6 ;;; is granted subject to the restriction that all copies made of this
   7 ;;; software must include this copyright notice in full.  This software
   8 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
   9 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
  10 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
  11 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
  12 ;;; NATURE WHATSOEVER.
  13
  14 ;;; Written by Robert Hieb & Kent Dybvig
  15
  16 ;;; This file was munged by a simple minded sed script since it left
  17 ;;; its original authors' hands.  See syncase.sh for the horrid details.
  18
  19 (begin ((lambda ()
  20 (letrec ((lambda-var-list (lambda (vars)
  21 ((letrec ((lvl (lambda (vars ls)
  22 (if (pair? vars)
  23 (lvl (cdr vars)
  24 (cons (car vars)
  25 ls))
  26 (if (id? vars)
  27 (cons vars
  28 ls)
  29 (if (null?
  30 vars)
  31 ls
  32 (if (syntax-object?
  33 vars)
  34 (lvl (unwrap
  35 vars)
  36 ls)
  37 (cons vars
  38 ls))))))))
  39 lvl)
  40 vars
  41 '())))
  42 (gen-var (lambda (id) (gen-sym (id-sym-name id))))
  43 (gen-sym (lambda (sym)
  44 (syncase:new-symbol-hook (symbol->string sym))))
  45 (strip (lambda (x)
  46 (if (syntax-object? x)
  47 (strip (syntax-object-expression x))
  48 (if (pair? x)
  49 ((lambda (a d)
  50 (if (if (eq? a (car x))
  51 (eq? d (cdr x))
  52 #f)
  53 x
  54 (cons a d)))
  55 (strip (car x))
  56 (strip (cdr x)))
  57 (if (vector? x)
  58 ((lambda (old)
  59 ((lambda (new)
  60 (if (syncase:andmap eq? old new)
  61 x
  62 (list->vector new)))
  63 (map strip old)))
  64 (vector->list x))
  65 x)))))
  66 (regen (lambda (x)
  67 ((lambda (g000139)
  68 (if (memv g000139 '(ref))
  69 (syncase:build-lexical-reference (cadr x))
  70 (if (memv g000139 '(primitive))
  71 (syncase:build-global-reference (cadr x))
  72 (if (memv g000139 '(id))
  73 (syncase:build-identifier (cadr x))
  74 (if (memv g000139 '(quote))
  75 (syncase:build-data (cadr x))
  76 (if (memv
  77 g000139
  78 '(lambda))
  79 (syncase:build-lambda
  80 (cadr x)
  81 (regen (caddr x)))
  82 (begin g000139
  83 (syncase:build-application
  84 (syncase:build-global-reference
  85 (car x))
  86 (map regen
  87 (cdr x))))))))))
  88 (car x))))
  89 (gen-vector (lambda (x)
  90 (if (eq? (car x) 'list)
  91 (syncase:list* 'vector (cdr x))
  92 (if (eq? (car x) 'quote)
  93 (list
  94 'quote
  95 (list->vector (cadr x)))
  96 (list 'list->vector x)))))
  97 (gen-append (lambda (x y)
  98 (if (equal? y ''())
  99 x
 100 (list 'append x y))))
 101 (gen-cons (lambda (x y)
 102 (if (eq? (car y) 'list)
 103 (syncase:list* 'list x (cdr y))
 104 (if (if (eq? (car x) 'quote)
 105 (eq? (car y) 'quote)
 106 #f)
 107 (list
 108 'quote
 109 (cons (cadr x) (cadr y)))
 110 (if (equal? y ''())
 111 (list 'list x)
 112 (list 'cons x y))))))
 113 (gen-map (lambda (e map-env)
 114 ((lambda (formals actuals)
 115 (if (eq? (car e) 'ref)
 116 (car actuals)
 117 (if (syncase:andmap
 118 (lambda (x)
 119 (if (eq? (car x) 'ref)
 120 (memq (cadr x)
 121 formals)
 122 #f))
 123 (cdr e))
 124 (syncase:list*
 125 'map
 126 (list 'primitive (car e))
 127 (map ((lambda (r)
 128 (lambda (x)
 129 (cdr (assq (cadr x)
 130 r))))
 131 (map cons
 132 formals
 133 actuals))
 134 (cdr e)))
 135 (syncase:list*
 136 'map
 137 (list 'lambda formals e)
 138 actuals))))
 139 (map cdr map-env)
 140 (map (lambda (x) (list 'ref (car x)))
 141 map-env))))
 142 (gen-ref (lambda (var level maps k)
 143 (if (= level 0)
 144 (k var maps)
 145 (gen-ref
 146 var
 147 (- level 1)
 148 (cdr maps)
 149 (lambda (outer-var outer-maps)
 150 ((lambda (b)
 151 (if b
 152 (k (cdr b) maps)
 153 ((lambda (inner-var)
 154 (k inner-var
 155 (cons (cons (cons outer-var
 156 inner-var)
 157 (car maps))
 158 outer-maps)))
 159 (gen-sym var))))
 160 (assq outer-var (car maps))))))))
 161 (chi-syntax (lambda (src exp r w)
 162 ((letrec ((gen (lambda (e maps k)
 163 (if (id? e)
 164 ((lambda (n)
 165 ((lambda (b)
 166 (if (eq? (binding-type
 167 b)
 168 'syntax)
 169 ((lambda (level)
 170 (if (< (length
 171 maps)
 172 level)
 173 (syntax-error
 174 src
 175 "missing ellipsis in")
 176 (gen-ref
 177 n
 178 level
 179 maps
 180 (lambda (x
 181 maps)
 182 (k (list
 183 'ref
 184 x)
 185 maps)))))
 186 (binding-value
 187 b))
 188 (if (ellipsis?
 189 (wrap e
 190 w))
 191 (syntax-error
 192 src
 193 "invalid context for ... in")
 194 (k (list
 195 'id
 196 (wrap e
 197 w))
 198 maps))))
 199 (lookup
 200 n
 201 e
 202 r)))
 203 (id-var-name
 204 e
 205 w))
 206 ((lambda (g000141)
 207 ((lambda (g000142)
 208 ((lambda (g000140)
 209 (if (not (eq? g000140
 210 'no))
 211 ((lambda (_dots1
 212 _dots2)
 213 (if (if (ellipsis?
 214 (wrap _dots1
 215 w))
 216 (ellipsis?
 217 (wrap _dots2
 218 w))
 219 #f)
 220 (k (list
 221 'id
 222 (wrap _dots1
 223 w))
 224 maps)
 225 (g000142)))
 226 (car g000140)
 227 (cadr g000140))
 228 (g000142)))
 229 (syntax-dispatch
 230 g000141
 231 '(pair (any)
 232 pair
 233 (any)
 234 atom)
 235 (vector))))
 236 (lambda ()
 237 ((lambda (g000144)
 238 ((lambda (g000145)
 239 ((lambda (g000143)
 240 (if (not (eq? g000143
 241 'no))
 242 ((lambda (_x
 243 _dots
 244 _y)
 245 (if (ellipsis?
 246 (wrap _dots
 247 w))
 248 (gen _y
 249 maps
 250 (lambda (y
 251 maps)
 252 (gen _x
 253 (cons '()
 254 maps)
 255 (lambda (x
 256 maps)
 257 (if (null?
 258 (car maps))
 259 (syntax-error
 260 src
 261 "extra ellipsis in")
 262 (k (gen-append
 263 (gen-map
 264 x
 265 (car maps))
 266 y)
 267 (cdr maps)))))))
 268 (g000145)))
 269 (car g000143)
 270 (cadr g000143)
 271 (caddr
 272 g000143))
 273 (g000145)))
 274 (syntax-dispatch
 275 g000144
 276 '(pair (any)
 277 pair
 278 (any)
 279 any)
 280 (vector))))
 281 (lambda ()
 282 ((lambda (g000147)
 283 ((lambda (g000146)
 284 (if (not (eq? g000146
 285 'no))
 286 ((lambda (_x
 287 _y)
 288 (gen _x
 289 maps
 290 (lambda (x
 291 maps)
 292 (gen _y
 293 maps
 294 (lambda (y
 295 maps)
 296 (k (gen-cons
 297 x
 298 y)
 299 maps))))))
 300 (car g000146)
 301 (cadr g000146))
 302 ((lambda (g000149)
 303 ((lambda (g000148)
 304 (if (not (eq? g000148
 305 'no))
 306 ((lambda (_e1
 307 _e2)
 308 (gen (cons _e1
 309 _e2)
 310 maps
 311 (lambda (e
 312 maps)
 313 (k (gen-vector
 314 e)
 315 maps))))
 316 (car g000148)
 317 (cadr g000148))
 318 ((lambda (g000151)
 319 ((lambda (g000150)
 320 (if (not (eq? g000150
 321 'no))
 322 ((lambda (__)
 323 (k (list
 324 'quote
 325 (wrap e
 326 w))
 327 maps))
 328 (car g000150))
 329 (syntax-error
 330 g000151)))
 331 (syntax-dispatch
 332 g000151
 333 '(any)
 334 (vector))))
 335 g000149)))
 336 (syntax-dispatch
 337 g000149
 338 '(vector
 339 pair
 340 (any)
 341 each
 342 any)
 343 (vector))))
 344 g000147)))
 345 (syntax-dispatch
 346 g000147
 347 '(pair (any)
 348 any)
 349 (vector))))
 350 g000144))))
 351 g000141))))
 352 e)))))
 353 gen)
 354 exp
 355 '()
 356 (lambda (e maps) (regen e)))))
 357 (ellipsis? (lambda (x)
 358 ;; I dont know what this is supposed to do, and removing it seemed harmless.
 359 ;; (if (if (top-level-bound? 'dp) dp #f)
 360 ;; (break)
 361 ;; (syncase:void))
 362 (if (identifier? x)
 363 (free-id=? x '...)
 364 #f)))
 365 (chi-syntax-definition (lambda (e w)
 366 ((lambda (g000153)
 367 ((lambda (g000154)
 368 ((lambda (g000152)
 369 (if (not (eq? g000152
 370 'no))
 371 ((lambda (__
 372 _name
 373 _val)
 374 (if (id? _name)
 375 (list _name
 376 _val)
 377 (g000154)))
 378 (car g000152)
 379 (cadr g000152)
 380 (caddr
 381 g000152))
 382 (g000154)))
 383 (syntax-dispatch
 384 g000153
 385 '(pair (any)
 386 pair
 387 (any)
 388 pair
 389 (any)
 390 atom)
 391 (vector))))
 392 (lambda ()
 393 (syntax-error
 394 g000153))))
 395 (wrap e w))))
 396 (chi-definition (lambda (e w)
 397 ((lambda (g000156)
 398 ((lambda (g000157)
 399 ((lambda (g000155)
 400 (if (not (eq? g000155
 401 'no))
 402 (apply
 403 (lambda (__
 404 _name
 405 _args
 406 _e1
 407 _e2)
 408 (if (if (id? _name)
 409 (valid-bound-ids?
 410 (lambda-var-list
 411 _args))
 412 #f)
 413 (list _name
 414 (cons '#(syntax-object
 415 lambda
 416 (top))
 417 (cons _args
 418 (cons _e1
 419 _e2))))
 420 (g000157)))
 421 g000155)
 422 (g000157)))
 423 (syntax-dispatch
 424 g000156
 425 '(pair (any)
 426 pair
 427 (pair (any) any)
 428 pair
 429 (any)
 430 each
 431 any)
 432 (vector))))
 433 (lambda ()
 434 ((lambda (g000159)
 435 ((lambda (g000158)
 436 (if (not (eq? g000158
 437 'no))
 438 ((lambda (__
 439 _name
 440 _val)
 441 (list _name
 442 _val))
 443 (car g000158)
 444 (cadr g000158)
 445 (caddr
 446 g000158))
 447 ((lambda (g000161)
 448 ((lambda (g000162)
 449 ((lambda (g000160)
 450 (if (not (eq? g000160
 451 'no))
 452 ((lambda (__
 453 _name)
 454 (if (id? _name)
 455 (list _name
 456 (list '#(syntax-object
 457 syncase:void
 458 (top))))
 459 (g000162)))
 460 (car g000160)
 461 (cadr g000160))
 462 (g000162)))
 463 (syntax-dispatch
 464 g000161
 465 '(pair (any)
 466 pair
 467 (any)
 468 atom)
 469 (vector))))
 470 (lambda ()
 471 (syntax-error
 472 g000161))))
 473 g000159)))
 474 (syntax-dispatch
 475 g000159
 476 '(pair (any)
 477 pair
 478 (any)
 479 pair
 480 (any)
 481 atom)
 482 (vector))))
 483 g000156))))
 484 (wrap e w))))
 485 (chi-sequence (lambda (e w)
 486 ((lambda (g000164)
 487 ((lambda (g000163)
 488 (if (not (eq? g000163 'no))
 489 ((lambda (__ _e) _e)
 490 (car g000163)
 491 (cadr g000163))
 492 (syntax-error g000164)))
 493 (syntax-dispatch
 494 g000164
 495 '(pair (any) each any)
 496 (vector))))
 497 (wrap e w))))
 498 (chi-macro-def (lambda (def r w)
 499 (syncase:eval-hook (chi def null-env w))))
 500 (chi-local-syntax (lambda (e r w)
 501 ((lambda (g000166)
 502 ((lambda (g000167)
 503 ((lambda (g000165)
 504 (if (not (eq? g000165
 505 'no))
 506 (apply
 507 (lambda (_who
 508 _var
 509 _val
 510 _e1
 511 _e2)
 512 (if (valid-bound-ids?
 513 _var)
 514 ((lambda (new-vars)
 515 ((lambda (new-w)
 516 (chi-body
 517 (cons _e1
 518 _e2)
 519 e
 520 (extend-macro-env
 521 new-vars
 522 ((lambda (w)
 523 (map (lambda (x)
 524 (chi-macro-def
 525 x
 526 r
 527 w))
 528 _val))
 529 (if (free-id=?
 530 _who
 531 '#(syntax-object
 532 letrec-syntax
 533 (top)))
 534 new-w
 535 w))
 536 r)
 537 new-w))
 538 (make-binding-wrap
 539 _var
 540 new-vars
 541 w)))
 542 (map gen-var
 543 _var))
 544 (g000167)))
 545 g000165)
 546 (g000167)))
 547 (syntax-dispatch
 548 g000166
 549 '(pair (any)
 550 pair
 551 (each pair
 552 (any)
 553 pair
 554 (any)
 555 atom)
 556 pair
 557 (any)
 558 each
 559 any)
 560 (vector))))
 561 (lambda ()
 562 ((lambda (g000169)
 563 ((lambda (g000168)
 564 (if (not (eq? g000168
 565 'no))
 566 ((lambda (__)
 567 (syntax-error
 568 (wrap e
 569 w)))
 570 (car g000168))
 571 (syntax-error
 572 g000169)))
 573 (syntax-dispatch
 574 g000169
 575 '(any)
 576 (vector))))
 577 g000166))))
 578 e)))
 579 (chi-body (lambda (body source r w)
 580 (if (null? (cdr body))
 581 (chi (car body) r w)
 582 ((letrec ((parse1 (lambda (body
 583 var-ids
 584 var-vals
 585 macro-ids
 586 macro-vals)
 587 (if (null? body)
 588 (syntax-error
 589 (wrap source
 590 w)
 591 "no expressions in body")
 592 ((letrec ((parse2 (lambda (e)
 593 ((lambda (b)
 594 ((lambda (g000170)
 595 (if (memv
 596 g000170
 597 '(macro))
 598 (parse2
 599 (chi-macro
 600 (binding-value
 601 b)
 602 e
 603 r
 604 empty-wrap
 605 (lambda (e
 606 r
 607 w)
 608 (wrap e
 609 w))))
 610 (if (memv
 611 g000170
 612 '(definition))
 613 (parse1
 614 (cdr body)
 615 (cons (cadr b)
 616 var-ids)
 617 (cons (caddr
 618 b)
 619 var-vals)
 620 macro-ids
 621 macro-vals)
 622 (if (memv
 623 g000170
 624 '(syntax-definition))
 625 (parse1
 626 (cdr body)
 627 var-ids
 628 var-vals
 629 (cons (cadr b)
 630 macro-ids)
 631 (cons (caddr
 632 b)
 633 macro-vals))
 634 (if (memv
 635 g000170
 636 '(sequence))
 637 (parse1
 638 (append
 639 (cdr b)
 640 (cdr body))
 641 var-ids
 642 var-vals
 643 macro-ids
 644 macro-vals)
 645 (begin g000170
 646 (if (valid-bound-ids?
 647 (append
 648 var-ids
 649 macro-ids))
 650 ((lambda (new-var-names
 651 new-macro-names)
 652 ((lambda (w)
 653 ((lambda (r)
 654 (syncase:build-letrec
 655 new-var-names
 656 (map (lambda (x)
 657 (chi x
 658 r
 659 w))
 660 var-vals)
 661 (syncase:build-sequence
 662 (map (lambda (x)
 663 (chi x
 664 r
 665 w))
 666 body))))
 667 (extend-macro-env
 668 new-macro-names
 669 (map (lambda (x)
 670 (chi-macro-def
 671 x
 672 r
 673 w))
 674 macro-vals)
 675 (extend-var-env
 676 new-var-names
 677 r))))
 678 (make-binding-wrap
 679 (append
 680 macro-ids
 681 var-ids)
 682 (append
 683 new-macro-names
 684 new-var-names)
 685 empty-wrap)))
 686 (map gen-var
 687 var-ids)
 688 (map gen-var
 689 macro-ids))
 690 (syntax-error
 691 (wrap source
 692 w)
 693 "invalid identifier"))))))))
 694 (car b)))
 695 (syntax-type
 696 e
 697 r
 698 empty-wrap)))))
 699 parse2)
 700 (car body))))))
 701 parse1)
 702 (map (lambda (x) (wrap x w)) body)
 703 '()
 704 '()
 705 '()
 706 '()))))
 707 (syntax-type (lambda (e r w)
 708 (if (syntax-object? e)
 709 (syntax-type
 710 (syntax-object-expression e)
 711 r
 712 (join-wraps
 713 (syntax-object-wrap e)
 714 w))
 715 (if (if (pair? e)
 716 (identifier? (car e))
 717 #f)
 718 ((lambda (n)
 719 ((lambda (b)
 720 ((lambda (g000171)
 721 (if (memv
 722 g000171
 723 '(special))
 724 (if (memv
 725 n
 726 '(define))
 727 (cons 'definition
 728 (chi-definition
 729 e
 730 w))
 731 (if (memv
 732 n
 733 '(define-syntax))
 734 (cons 'syntax-definition
 735 (chi-syntax-definition
 736 e
 737 w))
 738 (if (memv
 739 n
 740 '(begin))
 741 (cons 'sequence
 742 (chi-sequence
 743 e
 744 w))
 745 (begin n
 746 (syncase:void)))))
 747 (begin g000171
 748 b)))
 749 (binding-type b)))
 750 (lookup n (car e) r)))
 751 (id-var-name (car e) w))
 752 '(other)))))
 753 (chi-args (lambda (args r w source source-w)
 754 (if (pair? args)
 755 (cons (chi (car args) r w)
 756 (chi-args
 757 (cdr args)
 758 r
 759 w
 760 source
 761 source-w))
 762 (if (null? args)
 763 '()
 764 (if (syntax-object? args)
 765 (chi-args
 766 (syntax-object-expression
 767 args)
 768 r
 769 (join-wraps
 770 w
 771 (syntax-object-wrap
 772 args))
 773 source
 774 source-w)
 775 (syntax-error
 776 (wrap source source-w)))))))
 777 (chi-ref (lambda (e name binding w)
 778 ((lambda (g000172)
 779 (if (memv g000172 '(lexical))
 780 (syncase:build-lexical-reference name)
 781 (if (memv
 782 g000172
 783 '(global global-unbound))
 784 (syncase:build-global-reference name)
 785 (begin g000172
 786 (id-error
 787 (wrap e w))))))
 788 (binding-type binding))))
 789 (chi-macro (letrec ((check-macro-output (lambda (x)
 790 (if (pair?
 791 x)
 792 (begin (check-macro-output
 793 (car x))
 794 (check-macro-output
 795 (cdr x)))
 796 ((lambda (g000173)
 797 (if g000173
 798 g000173
 799 (if (vector?
 800 x)
 801 ((lambda (n)
 802 ((letrec ((g000174 (lambda (i)
 803 (if (= i
 804 n)
 805 (syncase:void)
 806 (begin (check-macro-output
 807 (vector-ref
 808 x
 809 i))
 810 (g000174
 811 (+ i
 812 1)))))))
 813 g000174)
 814 0))
 815 (vector-length
 816 x))
 817 (if (symbol?
 818 x)
 819 (syntax-error
 820 x
 821 "encountered raw symbol")
 822 (syncase:void)))))
 823 (syntax-object?
 824 x))))))
 825 (lambda (p e r w k)
 826 ((lambda (mw)
 827 ((lambda (x)
 828 (check-macro-output x)
 829 (k x r mw))
 830 (p (wrap e (join-wraps mw w)))))
 831 (new-mark-wrap)))))
 832 (chi-pair (lambda (e r w k)
 833 ((lambda (first rest)
 834 (if (id? first)
 835 ((lambda (n)
 836 ((lambda (b)
 837 ((lambda (g000175)
 838 (if (memv
 839 g000175
 840 '(core))
 841 ((binding-value b)
 842 e
 843 r
 844 w)
 845 (if (memv
 846 g000175
 847 '(macro))
 848 (chi-macro
 849 (binding-value
 850 b)
 851 e
 852 r
 853 w
 854 k)
 855 (if (memv
 856 g000175
 857 '(special))
 858 ((binding-value
 859 b)
 860 e
 861 r
 862 w
 863 k)
 864 (begin g000175
 865 (syncase:build-application
 866 (chi-ref
 867 first
 868 n
 869 b
 870 w)
 871 (chi-args
 872 rest
 873 r
 874 w
 875 e
 876 w)))))))
 877 (binding-type b)))
 878 (lookup n first r)))
 879 (id-var-name first w))
 880 (syncase:build-application
 881 (chi first r w)
 882 (chi-args rest r w e w))))
 883 (car e)
 884 (cdr e))))
 885 (chi (lambda (e r w)
 886 (if (symbol? e)
 887 ((lambda (n)
 888 (chi-ref e n (lookup n e r) w))
 889 (id-var-name e w))
 890 (if (pair? e)
 891 (chi-pair e r w chi)
 892 (if (syntax-object? e)
 893 (chi (syntax-object-expression e)
 894 r
 895 (join-wraps
 896 w
 897 (syntax-object-wrap e)))
 898 (if ((lambda (g000176)
 899 (if g000176
 900 g000176
 901 ((lambda (g000177)
 902 (if g000177
 903 g000177
 904 ((lambda (g000178)
 905 (if g000178
 906 g000178
 907 (char?
 908 e)))
 909 (string? e))))
 910 (number? e))))
 911 (boolean? e))
 912 (syncase:build-data e)
 913 (syntax-error (wrap e w))))))))
 914 (chi-top (lambda (e r w)
 915 (if (pair? e)
 916 (chi-pair e r w chi-top)
 917 (if (syntax-object? e)
 918 (chi-top
 919 (syntax-object-expression e)
 920 r
 921 (join-wraps
 922 w
 923 (syntax-object-wrap e)))
 924 (chi e r w)))))
 925 (wrap (lambda (x w)
 926 (if (null? w)
 927 x
 928 (if (syntax-object? x)
 929 (make-syntax-object
 930 (syntax-object-expression x)
 931 (join-wraps
 932 w
 933 (syntax-object-wrap x)))
 934 (if (null? x)
 935 x
 936 (make-syntax-object x w))))))
 937 (unwrap (lambda (x)
 938 (if (syntax-object? x)
 939 ((lambda (e w)
 940 (if (pair? e)
 941 (cons (wrap (car e) w)
 942 (wrap (cdr e) w))
 943 (if (vector? e)
 944 (list->vector
 945 (map (lambda (x)
 946 (wrap x w))
 947 (vector->list e)))
 948 e)))
 949 (syntax-object-expression x)
 950 (syntax-object-wrap x))
 951 x)))
 952 (bound-id-member? (lambda (x list)
 953 (if (not (null? list))
 954 ((lambda (g000179)
 955 (if g000179
 956 g000179
 957 (bound-id-member?
 958 x
 959 (cdr list))))
 960 (bound-id=? x (car list)))
 961 #f)))
 962 (valid-bound-ids? (lambda (ids)
 963 (if ((letrec ((all-ids? (lambda (ids)
 964 ((lambda (g000181)
 965 (if g000181
 966 g000181
 967 (if (id? (car ids))
 968 (all-ids?
 969 (cdr ids))
 970 #f)))
 971 (null?
 972 ids)))))
 973 all-ids?)
 974 ids)
 975 ((letrec ((unique? (lambda (ids)
 976 ((lambda (g000180)
 977 (if g000180
 978 g000180
 979 (if (not (bound-id-member?
 980 (car ids)
 981 (cdr ids)))
 982 (unique?
 983 (cdr ids))
 984 #f)))
 985 (null?
 986 ids)))))
 987 unique?)
 988 ids)
 989 #f)))
 990 (bound-id=? (lambda (i j)
 991 (if (eq? (id-sym-name i)
 992 (id-sym-name j))
 993 ((lambda (i j)
 994 (if (eq? (car i) (car j))
 995 (same-marks?
 996 (cdr i)
 997 (cdr j))
 998 #f))
 999 (id-var-name&marks i empty-wrap)
1000 (id-var-name&marks j empty-wrap))
1001 #f)))
1002 (free-id=? (lambda (i j)
1003 (if (eq? (id-sym-name i) (id-sym-name j))
1004 (eq? (id-var-name i empty-wrap)
1005 (id-var-name j empty-wrap))
1006 #f)))
1007 (id-var-name&marks (lambda (id w)
1008 (if (null? w)
1009 (if (symbol? id)
1010 (list id)
1011 (id-var-name&marks
1012 (syntax-object-expression
1013 id)
1014 (syntax-object-wrap
1015 id)))
1016 ((lambda (n&m first)
1017 (if (pair? first)
1018 ((lambda (n)
1019 ((letrec ((search (lambda (rib)
1020 (if (null?
1021 rib)
1022 n&m
1023 (if (if (eq? (caar rib)
1024 n)
1025 (same-marks?
1026 (cdr n&m)
1027 (cddar
1028 rib))
1029 #f)
1030 (cdar rib)
1031 (search
1032 (cdr rib)))))))
1033 search)
1034 first))
1035 (car n&m))
1036 (cons (car n&m)
1037 (if ((lambda (g000182)
1038 (if g000182
1039 g000182
1040 (not (eqv? first
1041 (cadr n&m)))))
1042 (null?
1043 (cdr n&m)))
1044 (cons first
1045 (cdr n&m))
1046 (cddr n&m)))))
1047 (id-var-name&marks
1048 id
1049 (cdr w))
1050 (car w)))))
1051 (id-var-name (lambda (id w)
1052 (if (null? w)
1053 (if (symbol? id)
1054 id
1055 (id-var-name
1056 (syntax-object-expression
1057 id)
1058 (syntax-object-wrap id)))
1059 (if (pair? (car w))
1060 (car (id-var-name&marks id w))
1061 (id-var-name id (cdr w))))))
1062 (same-marks? (lambda (x y)
1063 (if (null? x)
1064 (null? y)
1065 (if (not (null? y))
1066 (if (eqv? (car x) (car y))
1067 (same-marks?
1068 (cdr x)
1069 (cdr y))
1070 #f)
1071 #f))))
1072 (join-wraps2 (lambda (w1 w2)
1073 ((lambda (x w1)
1074 (if (null? w1)
1075 (if (if (not (pair? x))
1076 (eqv? x (car w2))
1077 #f)
1078 (cdr w2)
1079 (cons x w2))
1080 (cons x (join-wraps2 w1 w2))))
1081 (car w1)
1082 (cdr w1))))
1083 (join-wraps1 (lambda (w1 w2)
1084 (if (null? w1)
1085 w2
1086 (cons (car w1)
1087 (join-wraps1 (cdr w1) w2)))))
1088 (join-wraps (lambda (w1 w2)
1089 (if (null? w2)
1090 w1
1091 (if (null? w1)
1092 w2
1093 (if (pair? (car w2))
1094 (join-wraps1 w1 w2)
1095 (join-wraps2 w1 w2))))))
1096 (make-wrap-rib (lambda (ids new-names w)
1097 (if (null? ids)
1098 '()
1099 (cons ((lambda (n&m)
1100 (cons (car n&m)
1101 (cons (car new-names)
1102 (cdr n&m))))
1103 (id-var-name&marks
1104 (car ids)
1105 w))
1106 (make-wrap-rib
1107 (cdr ids)
1108 (cdr new-names)
1109 w)))))
1110 (make-binding-wrap (lambda (ids new-names w)
1111 (if (null? ids)
1112 w
1113 (cons (make-wrap-rib
1114 ids
1115 new-names
1116 w)
1117 w))))
1118 (new-mark-wrap (lambda ()
1119 (set! current-mark
1120 (+ current-mark 1))
1121 (list current-mark)))
1122 (current-mark 0)
1123 (top-wrap '(top))
1124 (empty-wrap '())
1125 (id-sym-name (lambda (x)
1126 (if (symbol? x)
1127 x
1128 (syntax-object-expression x))))
1129 (id? (lambda (x)
1130 ((lambda (g000183)
1131 (if g000183
1132 g000183
1133 (if (syntax-object? x)
1134 (symbol?
1135 (syntax-object-expression x))
1136 #f)))
1137 (symbol? x))))
1138 (global-extend (lambda (type sym val)
1139 (extend-global-env
1140 sym
1141 (cons type val))))
1142 (lookup (lambda (name id r)
1143 (if (eq? name (id-sym-name id))
1144 (global-lookup name)
1145 ((letrec ((search (lambda (r name)
1146 (if (null? r)
1147 '(displaced-lexical)
1148 (if (pair?
1149 (car r))
1150 (if (eq? (caar r)
1151 name)
1152 (cdar r)
1153 (search
1154 (cdr r)
1155 name))
1156 (if (eq? (car r)
1157 name)
1158 '(lexical)
1159 (search
1160 (cdr r)
1161 name)))))))
1162 search)
1163 r
1164 name))))
1165 (extend-syntax-env (lambda (vars vals r)
1166 (if (null? vars)
1167 r
1168 (cons (cons (car vars)
1169 (cons 'syntax
1170 (car vals)))
1171 (extend-syntax-env
1172 (cdr vars)
1173 (cdr vals)
1174 r)))))
1175 (extend-var-env append)
1176 (extend-macro-env (lambda (vars vals r)
1177 (if (null? vars)
1178 r
1179 (cons (cons (car vars)
1180 (cons 'macro
1181 (car vals)))
1182 (extend-macro-env
1183 (cdr vars)
1184 (cdr vals)
1185 r)))))
1186 (null-env '())
1187 (global-lookup (lambda (sym)
1188 ((lambda (g000184)
1189 (if g000184
1190 g000184
1191 '(global-unbound)))
1192 (syncase:get-global-definition-hook sym))))
1193 (extend-global-env (lambda (sym binding)
1194 (syncase:put-global-definition-hook
1195 sym
1196 binding)))
1197 (binding-value cdr)
1198 (binding-type car)
1199 (arg-check (lambda (pred? x who)
1200 (if (not (pred? x))
1201 (syncase:error-hook who "invalid argument" x)
1202 (syncase:void))))
1203 (id-error (lambda (x)
1204 (syntax-error
1205 x
1206 "invalid context for identifier")))
1207 (scope-error (lambda (id)
1208 (syntax-error
1209 id
1210 "invalid context for bound identifier")))
1211 (syntax-object-wrap (lambda (x) (vector-ref x 2)))
1212 (syntax-object-expression (lambda (x) (vector-ref x 1)))
1213 (make-syntax-object (lambda (expression wrap)
1214 (vector
1215 'syntax-object
1216 expression
1217 wrap)))
1218 (syntax-object? (lambda (x)
1219 (if (vector? x)
1220 (if (= (vector-length x) 3)
1221 (eq? (vector-ref x 0)
1222 'syntax-object)
1223 #f)
1224 #f))))
1225 (global-extend 'core 'letrec-syntax chi-local-syntax)
1226 (global-extend 'core 'let-syntax chi-local-syntax)
1227 (global-extend
1228 'core
1229 'quote
1230 (lambda (e r w)
1231 ((lambda (g000136)
1232 ((lambda (g000135)
1233 (if (not (eq? g000135 'no))
1234 ((lambda (__ _e) (syncase:build-data (strip _e)))
1235 (car g000135)
1236 (cadr g000135))
1237 ((lambda (g000138)
1238 ((lambda (g000137)
1239 (if (not (eq? g000137 'no))
1240 ((lambda (__)
1241 (syntax-error (wrap e w)))
1242 (car g000137))
1243 (syntax-error g000138)))
1244 (syntax-dispatch
1245 g000138
1246 '(any)
1247 (vector))))
1248 g000136)))
1249 (syntax-dispatch
1250 g000136
1251 '(pair (any) pair (any) atom)
1252 (vector))))
1253 e)))
1254 (global-extend
1255 'core
1256 'syntax
1257 (lambda (e r w)
1258 ((lambda (g000132)
1259 ((lambda (g000131)
1260 (if (not (eq? g000131 'no))
1261 ((lambda (__ _x) (chi-syntax e _x r w))
1262 (car g000131)
1263 (cadr g000131))
1264 ((lambda (g000134)
1265 ((lambda (g000133)
1266 (if (not (eq? g000133 'no))
1267 ((lambda (__)
1268 (syntax-error (wrap e w)))
1269 (car g000133))
1270 (syntax-error g000134)))
1271 (syntax-dispatch
1272 g000134
1273 '(any)
1274 (vector))))
1275 g000132)))
1276 (syntax-dispatch
1277 g000132
1278 '(pair (any) pair (any) atom)
1279 (vector))))
1280 e)))
1281 (global-extend
1282 'core
1283 'syntax-lambda
1284 (lambda (e r w)
1285 ((lambda (g000127)
1286 ((lambda (g000128)
1287 ((lambda (g000126)
1288 (if (not (eq? g000126 'no))
1289 ((lambda (__ _id _level _exp)
1290 (if (if (valid-bound-ids? _id)
1291 (map (lambda (x)
1292 (if (integer? x)
1293 (if (exact? x)
1294 (not (negative?
1295 x))
1296 #f)
1297 #f))
1298 (map unwrap _level))
1299 #f)
1300 ((lambda (new-vars)
1301 (syncase:build-lambda
1302 new-vars
1303 (chi _exp
1304 (extend-syntax-env
1305 new-vars
1306 (map unwrap
1307 _level)
1308 r)
1309 (make-binding-wrap
1310 _id
1311 new-vars
1312 w))))
1313 (map gen-var _id))
1314 (g000128)))
1315 (car g000126)
1316 (cadr g000126)
1317 (caddr g000126)
1318 (cadddr g000126))
1319 (g000128)))
1320 (syntax-dispatch
1321 g000127
1322 '(pair (any)
1323 pair
1324 (each pair (any) pair (any) atom)
1325 pair
1326 (any)
1327 atom)
1328 (vector))))
1329 (lambda ()
1330 ((lambda (g000130)
1331 ((lambda (g000129)
1332 (if (not (eq? g000129 'no))
1333 ((lambda (__)
1334 (syntax-error (wrap e w)))
1335 (car g000129))
1336 (syntax-error g000130)))
1337 (syntax-dispatch
1338 g000130
1339 '(any)
1340 (vector))))
1341 g000127))))
1342 e)))
1343 (global-extend
1344 'core
1345 'lambda
1346 (lambda (e r w)
1347 ((lambda (g000121)
1348 ((lambda (g000120)
1349 (if (not (eq? g000120 'no))
1350 ((lambda (__ _id _e1 _e2)
1351 (if (not (valid-bound-ids? _id))
1352 (syntax-error
1353 (wrap e w)
1354 "invalid parameter list")
1355 ((lambda (new-vars)
1356 (syncase:build-lambda
1357 new-vars
1358 (chi-body
1359 (cons _e1 _e2)
1360 e
1361 (extend-var-env
1362 new-vars
1363 r)
1364 (make-binding-wrap
1365 _id
1366 new-vars
1367 w))))
1368 (map gen-var _id))))
1369 (car g000120)
1370 (cadr g000120)
1371 (caddr g000120)
1372 (cadddr g000120))
1373 ((lambda (g000123)
1374 ((lambda (g000122)
1375 (if (not (eq? g000122 'no))
1376 ((lambda (__ _ids _e1 _e2)
1377 ((lambda (old-ids)
1378 (if (not (valid-bound-ids?
1379 (lambda-var-list
1380 _ids)))
1381 (syntax-error
1382 (wrap e w)
1383 "invalid parameter list")
1384 ((lambda (new-vars)
1385 (syncase:build-improper-lambda
1386 (reverse
1387 (cdr new-vars))
1388 (car new-vars)
1389 (chi-body
1390 (cons _e1
1391 _e2)
1392 e
1393 (extend-var-env
1394 new-vars
1395 r)
1396 (make-binding-wrap
1397 old-ids
1398 new-vars
1399 w))))
1400 (map gen-var
1401 old-ids))))
1402 (lambda-var-list _ids)))
1403 (car g000122)
1404 (cadr g000122)
1405 (caddr g000122)
1406 (cadddr g000122))
1407 ((lambda (g000125)
1408 ((lambda (g000124)
1409 (if (not (eq? g000124
1410 'no))
1411 ((lambda (__)
1412 (syntax-error
1413 (wrap e w)))
1414 (car g000124))
1415 (syntax-error
1416 g000125)))
1417 (syntax-dispatch
1418 g000125
1419 '(any)
1420 (vector))))
1421 g000123)))
1422 (syntax-dispatch
1423 g000123
1424 '(pair (any)
1425 pair
1426 (any)
1427 pair
1428 (any)
1429 each
1430 any)
1431 (vector))))
1432 g000121)))
1433 (syntax-dispatch
1434 g000121
1435 '(pair (any)
1436 pair
1437 (each any)
1438 pair
1439 (any)
1440 each
1441 any)
1442 (vector))))
1443 e)))
1444 (global-extend
1445 'core
1446 'letrec
1447 (lambda (e r w)
1448 ((lambda (g000116)
1449 ((lambda (g000117)
1450 ((lambda (g000115)
1451 (if (not (eq? g000115 'no))
1452 (apply
1453 (lambda (__ _id _val _e1 _e2)
1454 (if (valid-bound-ids? _id)
1455 ((lambda (new-vars)
1456 ((lambda (w r)
1457 (syncase:build-letrec
1458 new-vars
1459 (map (lambda (x)
1460 (chi x
1461 r
1462 w))
1463 _val)
1464 (chi-body
1465 (cons _e1 _e2)
1466 e
1467 r
1468 w)))
1469 (make-binding-wrap
1470 _id
1471 new-vars
1472 w)
1473 (extend-var-env
1474 new-vars
1475 r)))
1476 (map gen-var _id))
1477 (g000117)))
1478 g000115)
1479 (g000117)))
1480 (syntax-dispatch
1481 g000116
1482 '(pair (any)
1483 pair
1484 (each pair (any) pair (any) atom)
1485 pair
1486 (any)
1487 each
1488 any)
1489 (vector))))
1490 (lambda ()
1491 ((lambda (g000119)
1492 ((lambda (g000118)
1493 (if (not (eq? g000118 'no))
1494 ((lambda (__)
1495 (syntax-error (wrap e w)))
1496 (car g000118))
1497 (syntax-error g000119)))
1498 (syntax-dispatch
1499 g000119
1500 '(any)
1501 (vector))))
1502 g000116))))
1503 e)))
1504 (global-extend
1505 'core
1506 'if
1507 (lambda (e r w)
1508 ((lambda (g000110)
1509 ((lambda (g000109)
1510 (if (not (eq? g000109 'no))
1511 ((lambda (__ _test _then)
1512 (syncase:build-conditional
1513 (chi _test r w)
1514 (chi _then r w)
1515 (chi (list '#(syntax-object
1516 syncase:void
1517 (top)))
1518 r
1519 empty-wrap)))
1520 (car g000109)
1521 (cadr g000109)
1522 (caddr g000109))
1523 ((lambda (g000112)
1524 ((lambda (g000111)
1525 (if (not (eq? g000111 'no))
1526 ((lambda (__ _test _then _else)
1527 (syncase:build-conditional
1528 (chi _test r w)
1529 (chi _then r w)
1530 (chi _else r w)))
1531 (car g000111)
1532 (cadr g000111)
1533 (caddr g000111)
1534 (cadddr g000111))
1535 ((lambda (g000114)
1536 ((lambda (g000113)
1537 (if (not (eq? g000113
1538 'no))
1539 ((lambda (__)
1540 (syntax-error
1541 (wrap e w)))
1542 (car g000113))
1543 (syntax-error
1544 g000114)))
1545 (syntax-dispatch
1546 g000114
1547 '(any)
1548 (vector))))
1549 g000112)))
1550 (syntax-dispatch
1551 g000112
1552 '(pair (any)
1553 pair
1554 (any)
1555 pair
1556 (any)
1557 pair
1558 (any)
1559 atom)
1560 (vector))))
1561 g000110)))
1562 (syntax-dispatch
1563 g000110
1564 '(pair (any) pair (any) pair (any) atom)
1565 (vector))))
1566 e)))
1567 (global-extend
1568 'core
1569 'set!
1570 (lambda (e r w)
1571 ((lambda (g000104)
1572 ((lambda (g000105)
1573 ((lambda (g000103)
1574 (if (not (eq? g000103 'no))
1575 ((lambda (__ _id _val)
1576 (if (id? _id)
1577 ((lambda (val n)
1578 ((lambda (g000108)
1579 (if (memv
1580 g000108
1581 '(lexical))
1582 (syncase:build-lexical-assignment
1583 n
1584 val)
1585 (if (memv
1586 g000108
1587 '(global
1588 global-unbound))
1589 (syncase:build-global-assignment
1590 n
1591 val)
1592 (begin g000108
1593 (id-error
1594 (wrap _id
1595 w))))))
1596 (binding-type
1597 (lookup n _id r))))
1598 (chi _val r w)
1599 (id-var-name _id w))
1600 (g000105)))
1601 (car g000103)
1602 (cadr g000103)
1603 (caddr g000103))
1604 (g000105)))
1605 (syntax-dispatch
1606 g000104
1607 '(pair (any) pair (any) pair (any) atom)
1608 (vector))))
1609 (lambda ()
1610 ((lambda (g000107)
1611 ((lambda (g000106)
1612 (if (not (eq? g000106 'no))
1613 ((lambda (__)
1614 (syntax-error (wrap e w)))
1615 (car g000106))
1616 (syntax-error g000107)))
1617 (syntax-dispatch
1618 g000107
1619 '(any)
1620 (vector))))
1621 g000104))))
1622 e)))
1623 (global-extend
1624 'special
1625 'begin
1626 (lambda (e r w k)
1627 ((lambda (body)
1628 (if (null? body)
1629 (if (eqv? k chi-top)
1630 (chi (list '#(syntax-object syncase:void (top)))
1631 r
1632 empty-wrap)
1633 (syntax-error
1634 (wrap e w)
1635 "no expressions in body of"))
1636 (syncase:build-sequence
1637 ((letrec ((dobody (lambda (body)
1638 (if (null? body)
1639 '()
1640 ((lambda (first)
1641 (cons first
1642 (dobody
1643 (cdr body))))
1644 (k (car body)
1645 r
1646 empty-wrap))))))
1647 dobody)
1648 body))))
1649 (chi-sequence e w))))
1650 (global-extend
1651 'special
1652 'define
1653 (lambda (e r w k)
1654 (if (eqv? k chi-top)
1655 ((lambda (n&v)
1656 ((lambda (n)
1657 (global-extend 'global n '())
1658 (syncase:build-global-definition
1659 n
1660 (chi (cadr n&v) r empty-wrap)))
1661 (id-var-name (car n&v) empty-wrap)))
1662 (chi-definition e w))
1663 (syntax-error
1664 (wrap e w)
1665 "invalid context for definition"))))
1666 (global-extend
1667 'special
1668 'define-syntax
1669 (lambda (e r w k)
1670 (if (eqv? k chi-top)
1671 ((lambda (n&v)
1672 (global-extend
1673 'macro
1674 (id-var-name (car n&v) empty-wrap)
1675 (chi-macro-def (cadr n&v) r empty-wrap))
1676 (chi (list '#(syntax-object syncase:void (top)))
1677 r
1678 empty-wrap))
1679 (chi-syntax-definition e w))
1680 (syntax-error
1681 (wrap e w)
1682 "invalid context for definition"))))
1683 (set! expand-syntax
1684 (lambda (x) (chi-top x null-env top-wrap)))
1685 (set! implicit-identifier
1686 (lambda (id sym)
1687 (arg-check id? id 'implicit-identifier)
1688 (arg-check symbol? sym 'implicit-identifier)
1689 (if (syntax-object? id)
1690 (wrap sym (syntax-object-wrap id))
1691 sym)))
1692 (set! syntax-object->datum (lambda (x) (strip x)))
1693 (set! generate-temporaries
1694 (lambda (ls)
1695 (arg-check list? ls 'generate-temporaries)
1696 (map (lambda (x) (wrap (syncase:new-symbol-hook "g") top-wrap)) ls)))
1697 (set! free-identifier=?
1698 (lambda (x y)
1699 (arg-check id? x 'free-identifier=?)
1700 (arg-check id? y 'free-identifier=?)
1701 (free-id=? x y)))
1702 (set! bound-identifier=?
1703 (lambda (x y)
1704 (arg-check id? x 'bound-identifier=?)
1705 (arg-check id? y 'bound-identifier=?)
1706 (bound-id=? x y)))
1707 (set! identifier? (lambda (x) (id? x)))
1708 (set! syntax-error
1709 (lambda (object . messages)
1710 (for-each
1711 (lambda (x) (arg-check string? x 'syntax-error))
1712 messages)
1713 ((lambda (message)
1714 (syncase:error-hook 'expand-syntax message (strip object)))
1715 (if (null? messages)
1716 "invalid syntax"
1717 (apply string-append messages)))))
1718 (set! syncase:install-global-transformer
1719 (lambda (sym p) (global-extend 'macro sym p)))
1720 ((lambda ()
1721 (letrec ((match (lambda (e p k w r)
1722 (if (eq? r 'no)
1723 r
1724 ((lambda (g000100)
1725 (if (memv g000100 '(any))
1726 (cons (wrap e w) r)
1727 (if (memv
1728 g000100
1729 '(free-id))
1730 (if (if (identifier?
1731 e)
1732 (free-id=?
1733 (wrap e w)
1734 (vector-ref
1735 k
1736 (cdr p)))
1737 #f)
1738 r
1739 'no)
1740 (begin g000100
1741 (if (syntax-object?
1742 e)
1743 (match*
1744 (syntax-object-expression
1745 e)
1746 p
1747 k
1748 (join-wraps
1749 w
1750 (syntax-object-wrap
1751 e))
1752 r)
1753 (match*
1754 e
1755 p
1756 k
1757 w
1758 r))))))
1759 (car p)))))
1760 (match* (lambda (e p k w r)
1761 ((lambda (g000101)
1762 (if (memv g000101 '(pair))
1763 (if (pair? e)
1764 (match
1765 (car e)
1766 (cadr p)
1767 k
1768 w
1769 (match
1770 (cdr e)
1771 (cddr p)
1772 k
1773 w
1774 r))
1775 'no)
1776 (if (memv g000101 '(each))
1777 (if (eq? (cadr p) 'any)
1778 ((lambda (l)
1779 (if (eq? l 'no)
1780 l
1781 (cons l r)))
1782 (match-each-any
1783 e
1784 w))
1785 (if (null? e)
1786 (match-empty
1787 (cdr p)
1788 r)
1789 ((lambda (l)
1790 (if (eq? l
1791 'no)
1792 l
1793 ((letrec ((collect (lambda (l)
1794 (if (null?
1795 (car l))
1796 r
1797 (cons (map car
1798 l)
1799 (collect
1800 (map cdr
1801 l)))))))
1802 collect)
1803 l)))
1804 (match-each
1805 e
1806 (cdr p)
1807 k
1808 w))))
1809 (if (memv
1810 g000101
1811 '(atom))
1812 (if (equal?
1813 (cdr p)
1814 e)
1815 r
1816 'no)
1817 (if (memv
1818 g000101
1819 '(vector))
1820 (if (vector? e)
1821 (match
1822 (vector->list
1823 e)
1824 (cdr p)
1825 k
1826 w
1827 r)
1828 'no)
1829 (begin g000101
1830 (syncase:void)))))))
1831 (car p))))
1832 (match-empty (lambda (p r)
1833 ((lambda (g000102)
1834 (if (memv g000102 '(any))
1835 (cons '() r)
1836 (if (memv
1837 g000102
1838 '(each))
1839 (match-empty
1840 (cdr p)
1841 r)
1842 (if (memv
1843 g000102
1844 '(pair))
1845 (match-empty
1846 (cadr p)
1847 (match-empty
1848 (cddr p)
1849 r))
1850 (if (memv
1851 g000102
1852 '(free-id
1853 atom))
1854 r
1855 (if (memv
1856 g000102
1857 '(vector))
1858 (match-empty
1859 (cdr p)
1860 r)
1861 (begin g000102
1862 (syncase:void))))))))
1863 (car p))))
1864 (match-each-any (lambda (e w)
1865 (if (pair? e)
1866 ((lambda (l)
1867 (if (eq? l 'no)
1868 l
1869 (cons (wrap (car e)
1870 w)
1871 l)))
1872 (match-each-any
1873 (cdr e)
1874 w))
1875 (if (null? e)
1876 '()
1877 (if (syntax-object?
1878 e)
1879 (match-each-any
1880 (syntax-object-expression
1881 e)
1882 (join-wraps
1883 w
1884 (syntax-object-wrap
1885 e)))
1886 'no)))))
1887 (match-each (lambda (e p k w)
1888 (if (pair? e)
1889 ((lambda (first)
1890 (if (eq? first 'no)
1891 first
1892 ((lambda (rest)
1893 (if (eq? rest
1894 'no)
1895 rest
1896 (cons first
1897 rest)))
1898 (match-each
1899 (cdr e)
1900 p
1901 k
1902 w))))
1903 (match (car e) p k w '()))
1904 (if (null? e)
1905 '()
1906 (if (syntax-object? e)
1907 (match-each
1908 (syntax-object-expression
1909 e)
1910 p
1911 k
1912 (join-wraps
1913 w
1914 (syntax-object-wrap
1915 e)))
1916 'no))))))
1917 (set! syntax-dispatch
1918 (lambda (expression pattern keys)
1919 (match
1920 expression
1921 pattern
1922 keys
1923 empty-wrap
1924 '())))))))))
1925 (syncase:install-global-transformer
1926 'let
1927 (lambda (x)
1928 ((lambda (g00095)
1929 ((lambda (g00096)
1930 ((lambda (g00094)
1931 (if (not (eq? g00094 'no))
1932 (apply
1933 (lambda (__ _x _v _e1 _e2)
1934 (if (syncase:andmap identifier? _x)
1935 (cons (cons '#(syntax-object
1936 lambda
1937 (top))
1938 (cons _x
1939 (cons _e1 _e2)))
1940 _v)
1941 (g00096)))
1942 g00094)
1943 (g00096)))
1944 (syntax-dispatch
1945 g00095
1946 '(pair (any)
1947 pair
1948 (each pair (any) pair (any) atom)
1949 pair
1950 (any)
1951 each
1952 any)
1953 (vector))))
1954 (lambda ()
1955 ((lambda (g00098)
1956 ((lambda (g00099)
1957 ((lambda (g00097)
1958 (if (not (eq? g00097 'no))
1959 (apply
1960 (lambda (__ _f _x _v _e1 _e2)
1961 (if (syncase:andmap
1962 identifier?
1963 (cons _f _x))
1964 (cons (list '#(syntax-object
1965 letrec
1966 (top))
1967 (list (list _f
1968 (cons '#(syntax-object
1969 lambda
1970 (top))
1971 (cons _x
1972 (cons _e1
1973 _e2)))))
1974 _f)
1975 _v)
1976 (g00099)))
1977 g00097)
1978 (g00099)))
1979 (syntax-dispatch
1980 g00098
1981 '(pair (any)
1982 pair
1983 (any)
1984 pair
1985 (each pair (any) pair (any) atom)
1986 pair
1987 (any)
1988 each
1989 any)
1990 (vector))))
1991 (lambda () (syntax-error g00098))))
1992 g00095))))
1993 x)))
1994 (syncase:install-global-transformer
1995 'syntax-case
1996 ((lambda ()
1997 (letrec ((syncase:build-dispatch-call (lambda (args body val)
1998 ((lambda (g00046)
1999 ((lambda (g00045)
2000 (if (not (eq? g00045
2001 'no))
2002 body
2003 ((lambda (g00048)
2004 ((lambda (g00047)
2005 (if (not (eq? g00047
2006 'no))
2007 ((lambda (_arg1)
2008 ((lambda (g00066)
2009 ((lambda (g00065)
2010 (if (not (eq? g00065
2011 'no))
2012 ((lambda (_body
2013 _val)
2014 (list (list '#(syntax-object
2015 syntax-lambda
2016 (top))
2017 (list _arg1)
2018 _body)
2019 (list '#(syntax-object
2020 car
2021 (top))
2022 _val)))
2023 (car g00065)
2024 (cadr g00065))
2025 (syntax-error
2026 g00066)))
2027 (syntax-dispatch
2028 g00066
2029 '(pair (any)
2030 pair
2031 (any)
2032 atom)
2033 (vector))))
2034 (list body
2035 val)))
2036 (car g00047))
2037 ((lambda (g00050)
2038 ((lambda (g00049)
2039 (if (not (eq? g00049
2040 'no))
2041 ((lambda (_arg1
2042 _arg2)
2043 ((lambda (g00064)
2044 ((lambda (g00063)
2045 (if (not (eq? g00063
2046 'no))
2047 ((lambda (_body
2048 _val)
2049 (list (list '#(syntax-object
2050 syntax-lambda
2051 (top))
2052 (list _arg1
2053 _arg2)
2054 _body)
2055 (list '#(syntax-object
2056 car
2057 (top))
2058 _val)
2059 (list '#(syntax-object
2060 cadr
2061 (top))
2062 _val)))
2063 (car g00063)
2064 (cadr g00063))
2065 (syntax-error
2066 g00064)))
2067 (syntax-dispatch
2068 g00064
2069 '(pair (any)
2070 pair
2071 (any)
2072 atom)
2073 (vector))))
2074 (list body
2075 val)))
2076 (car g00049)
2077 (cadr g00049))
2078 ((lambda (g00052)
2079 ((lambda (g00051)
2080 (if (not (eq? g00051
2081 'no))
2082 ((lambda (_arg1
2083 _arg2
2084 _arg3)
2085 ((lambda (g00062)
2086 ((lambda (g00061)
2087 (if (not (eq? g00061
2088 'no))
2089 ((lambda (_body
2090 _val)
2091 (list (list '#(syntax-object
2092 syntax-lambda
2093 (top))
2094 (list _arg1
2095 _arg2
2096 _arg3)
2097 _body)
2098 (list '#(syntax-object
2099 car
2100 (top))
2101 _val)
2102 (list '#(syntax-object
2103 cadr
2104 (top))
2105 _val)
2106 (list '#(syntax-object
2107 caddr
2108 (top))
2109 _val)))
2110 (car g00061)
2111 (cadr g00061))
2112 (syntax-error
2113 g00062)))
2114 (syntax-dispatch
2115 g00062
2116 '(pair (any)
2117 pair
2118 (any)
2119 atom)
2120 (vector))))
2121 (list body
2122 val)))
2123 (car g00051)
2124 (cadr g00051)
2125 (caddr
2126 g00051))
2127 ((lambda (g00054)
2128 ((lambda (g00053)
2129 (if (not (eq? g00053
2130 'no))
2131 ((lambda (_arg1
2132 _arg2
2133 _arg3
2134 _arg4)
2135 ((lambda (g00060)
2136 ((lambda (g00059)
2137 (if (not (eq? g00059
2138 'no))
2139 ((lambda (_body
2140 _val)
2141 (list (list '#(syntax-object
2142 syntax-lambda
2143 (top))
2144 (list _arg1
2145 _arg2
2146 _arg3
2147 _arg4)
2148 _body)
2149 (list '#(syntax-object
2150 car
2151 (top))
2152 _val)
2153 (list '#(syntax-object
2154 cadr
2155 (top))
2156 _val)
2157 (list '#(syntax-object
2158 caddr
2159 (top))
2160 _val)
2161 (list '#(syntax-object
2162 cadddr
2163 (top))
2164 _val)))
2165 (car g00059)
2166 (cadr g00059))
2167 (syntax-error
2168 g00060)))
2169 (syntax-dispatch
2170 g00060
2171 '(pair (any)
2172 pair
2173 (any)
2174 atom)
2175 (vector))))
2176 (list body
2177 val)))
2178 (car g00053)
2179 (cadr g00053)
2180 (caddr
2181 g00053)
2182 (cadddr
2183 g00053))
2184 ((lambda (g00056)
2185 ((lambda (g00055)
2186 (if (not (eq? g00055
2187 'no))
2188 ((lambda (_arg)
2189 ((lambda (g00058)
2190 ((lambda (g00057)
2191 (if (not (eq? g00057
2192 'no))
2193 ((lambda (_body
2194 _val)
2195 (list '#(syntax-object
2196 apply
2197 (top))
2198 (list '#(syntax-object
2199 syntax-lambda
2200 (top))
2201 _arg
2202 _body)
2203 _val))
2204 (car g00057)
2205 (cadr g00057))
2206 (syntax-error
2207 g00058)))
2208 (syntax-dispatch
2209 g00058
2210 '(pair (any)
2211 pair
2212 (any)
2213 atom)
2214 (vector))))
2215 (list body
2216 val)))
2217 (car g00055))
2218 (syntax-error
2219 g00056)))
2220 (syntax-dispatch
2221 g00056
2222 '(each any)
2223 (vector))))
2224 g00054)))
2225 (syntax-dispatch
2226 g00054
2227 '(pair (any)
2228 pair
2229 (any)
2230 pair
2231 (any)
2232 pair
2233 (any)
2234 atom)
2235 (vector))))
2236 g00052)))
2237 (syntax-dispatch
2238 g00052
2239 '(pair (any)
2240 pair
2241 (any)
2242 pair
2243 (any)
2244 atom)
2245 (vector))))
2246 g00050)))
2247 (syntax-dispatch
2248 g00050
2249 '(pair (any)
2250 pair
2251 (any)
2252 atom)
2253 (vector))))
2254 g00048)))
2255 (syntax-dispatch
2256 g00048
2257 '(pair (any)
2258 atom)
2259 (vector))))
2260 g00046)))
2261 (syntax-dispatch
2262 g00046
2263 '(atom)
2264 (vector))))
2265 args)))
2266 (extract-bound-syntax-ids (lambda (pattern keys)
2267 ((letrec ((gen (lambda (p
2268 n
2269 ids)
2270 (if (identifier?
2271 p)
2272 (if (key? p
2273 keys)
2274 ids
2275 (cons (list p
2276 n)
2277 ids))
2278 ((lambda (g00068)
2279 ((lambda (g00069)
2280 ((lambda (g00067)
2281 (if (not (eq? g00067
2282 'no))
2283 ((lambda (_x
2284 _dots)
2285 (if (ellipsis?
2286 _dots)
2287 (gen _x
2288 (+ n
2289 1)
2290 ids)
2291 (g00069)))
2292 (car g00067)
2293 (cadr g00067))
2294 (g00069)))
2295 (syntax-dispatch
2296 g00068
2297 '(pair (any)
2298 pair
2299 (any)
2300 atom)
2301 (vector))))
2302 (lambda ()
2303 ((lambda (g00071)
2304 ((lambda (g00070)
2305 (if (not (eq? g00070
2306 'no))
2307 ((lambda (_x
2308 _y)
2309 (gen _x
2310 n
2311 (gen _y
2312 n
2313 ids)))
2314 (car g00070)
2315 (cadr g00070))
2316 ((lambda (g00073)
2317 ((lambda (g00072)
2318 (if (not (eq? g00072
2319 'no))
2320 ((lambda (_x)
2321 (gen _x
2322 n
2323 ids))
2324 (car g00072))
2325 ((lambda (g00075)
2326 ((lambda (g00074)
2327 (if (not (eq? g00074
2328 'no))
2329 ((lambda (_x)
2330 ids)
2331 (car g00074))
2332 (syntax-error
2333 g00075)))
2334 (syntax-dispatch
2335 g00075
2336 '(any)
2337 (vector))))
2338 g00073)))
2339 (syntax-dispatch
2340 g00073
2341 '(vector
2342 each
2343 any)
2344 (vector))))
2345 g00071)))
2346 (syntax-dispatch
2347 g00071
2348 '(pair (any)
2349 any)
2350 (vector))))
2351 g00068))))
2352 p)))))
2353 gen)
2354 pattern
2355 0
2356 '())))
2357 (valid-syntax-pattern? (lambda (pattern keys)
2358 (letrec ((check? (lambda (p
2359 ids)
2360 (if (identifier?
2361 p)
2362 (if (eq? ids
2363 'no)
2364 ids
2365 (if (key? p
2366 keys)
2367 ids
2368 (if (if (not (ellipsis?
2369 p))
2370 (not (memid
2371 p
2372 ids))
2373 #f)
2374 (cons p
2375 ids)
2376 'no)))
2377 ((lambda (g00077)
2378 ((lambda (g00078)
2379 ((lambda (g00076)
2380 (if (not (eq? g00076
2381 'no))
2382 ((lambda (_x
2383 _dots)
2384 (if (ellipsis?
2385 _dots)
2386 (check?
2387 _x
2388 ids)
2389 (g00078)))
2390 (car g00076)
2391 (cadr g00076))
2392 (g00078)))
2393 (syntax-dispatch
2394 g00077
2395 '(pair (any)
2396 pair
2397 (any)
2398 atom)
2399 (vector))))
2400 (lambda ()
2401 ((lambda (g00080)
2402 ((lambda (g00079)
2403 (if (not (eq? g00079
2404 'no))
2405 ((lambda (_x
2406 _y)
2407 (check?
2408 _x
2409 (check?
2410 _y
2411 ids)))
2412 (car g00079)
2413 (cadr g00079))
2414 ((lambda (g00082)
2415 ((lambda (g00081)
2416 (if (not (eq? g00081
2417 'no))
2418 ((lambda (_x)
2419 (check?
2420 _x
2421 ids))
2422 (car g00081))
2423 ((lambda (g00084)
2424 ((lambda (g00083)
2425 (if (not (eq? g00083
2426 'no))
2427 ((lambda (_x)
2428 ids)
2429 (car g00083))
2430 (syntax-error
2431 g00084)))
2432 (syntax-dispatch
2433 g00084
2434 '(any)
2435 (vector))))
2436 g00082)))
2437 (syntax-dispatch
2438 g00082
2439 '(vector
2440 each
2441 any)
2442 (vector))))
2443 g00080)))
2444 (syntax-dispatch
2445 g00080
2446 '(pair (any)
2447 any)
2448 (vector))))
2449 g00077))))
2450 p)))))
2451 (not (eq? (check?
2452 pattern
2453 '())
2454 'no)))))
2455 (valid-keyword? (lambda (k)
2456 (if (identifier? k)
2457 (not (free-identifier=?
2458 k
2459 '...))
2460 #f)))
2461 (convert-syntax-dispatch-pattern (lambda (pattern
2462 keys)
2463 ((letrec ((gen (lambda (p)
2464 (if (identifier?
2465 p)
2466 (if (key? p
2467 keys)
2468 (cons '#(syntax-object
2469 free-id
2470 (top))
2471 (key-index
2472 p
2473 keys))
2474 (list '#(syntax-object
2475 any
2476 (top))))
2477 ((lambda (g00086)
2478 ((lambda (g00087)
2479 ((lambda (g00085)
2480 (if (not (eq? g00085
2481 'no))
2482 ((lambda (_x
2483 _dots)
2484 (if (ellipsis?
2485 _dots)
2486 (cons '#(syntax-object
2487 each
2488 (top))
2489 (gen _x))
2490 (g00087)))
2491 (car g00085)
2492 (cadr g00085))
2493 (g00087)))
2494 (syntax-dispatch
2495 g00086
2496 '(pair (any)
2497 pair
2498 (any)
2499 atom)
2500 (vector))))
2501 (lambda ()
2502 ((lambda (g00089)
2503 ((lambda (g00088)
2504 (if (not (eq? g00088
2505 'no))
2506 ((lambda (_x
2507 _y)
2508 (cons '#(syntax-object
2509 pair
2510 (top))
2511 (cons (gen _x)
2512 (gen _y))))
2513 (car g00088)
2514 (cadr g00088))
2515 ((lambda (g00091)
2516 ((lambda (g00090)
2517 (if (not (eq? g00090
2518 'no))
2519 ((lambda (_x)
2520 (cons '#(syntax-object
2521 vector
2522 (top))
2523 (gen _x)))
2524 (car g00090))
2525 ((lambda (g00093)
2526 ((lambda (g00092)
2527 (if (not (eq? g00092
2528 'no))
2529 ((lambda (_x)
2530 (cons '#(syntax-object
2531 atom
2532 (top))
2533 p))
2534 (car g00092))
2535 (syntax-error
2536 g00093)))
2537 (syntax-dispatch
2538 g00093
2539 '(any)
2540 (vector))))
2541 g00091)))
2542 (syntax-dispatch
2543 g00091
2544 '(vector
2545 each
2546 any)
2547 (vector))))
2548 g00089)))
2549 (syntax-dispatch
2550 g00089
2551 '(pair (any)
2552 any)
2553 (vector))))
2554 g00086))))
2555 p)))))
2556 gen)
2557 pattern)))
2558 (key-index (lambda (p keys)
2559 (- (length keys)
2560 (length (memid p keys)))))
2561 (key? (lambda (p keys)
2562 (if (identifier? p) (memid p keys) #f)))
2563 (memid (lambda (i ids)
2564 (if (not (null? ids))
2565 (if (bound-identifier=? i (car ids))
2566 ids
2567 (memid i (cdr ids)))
2568 #f)))
2569 (ellipsis? (lambda (x)
2570 (if (identifier? x)
2571 (free-identifier=? x '...)
2572 #f))))
2573 (lambda (x)
2574 ((lambda (g00030)
2575 ((lambda (g00031)
2576 ((lambda (g00029)
2577 (if (not (eq? g00029 'no))
2578 ((lambda (__ _val _key)
2579 (if (syncase:andmap valid-keyword? _key)
2580 (list '#(syntax-object
2581 syntax-error
2582 (top))
2583 _val)
2584 (g00031)))
2585 (car g00029)
2586 (cadr g00029)
2587 (caddr g00029))
2588 (g00031)))
2589 (syntax-dispatch
2590 g00030
2591 '(pair (any)
2592 pair
2593 (any)
2594 pair
2595 (each any)
2596 atom)
2597 (vector))))
2598 (lambda ()
2599 ((lambda (g00033)
2600 ((lambda (g00034)
2601 ((lambda (g00032)
2602 (if (not (eq? g00032 'no))
2603 (apply
2604 (lambda (__
2605 _val
2606 _key
2607 _pat
2608 _exp)
2609 (if (if (identifier?
2610 _pat)
2611 (if (syncase:andmap
2612 valid-keyword?
2613 _key)
2614 (syncase:andmap
2615 (lambda (x)
2616 (not (free-identifier=?
2617 _pat
2618 x)))
2619 (cons '...
2620 _key))
2621 #f)
2622 #f)
2623 (list (list '#(syntax-object
2624 syntax-lambda
2625 (top))
2626 (list (list _pat
2627 0))
2628 _exp)
2629 _val)
2630 (g00034)))
2631 g00032)
2632 (g00034)))
2633 (syntax-dispatch
2634 g00033
2635 '(pair (any)
2636 pair
2637 (any)
2638 pair
2639 (each any)
2640 pair
2641 (pair (any) pair (any) atom)
2642 atom)
2643 (vector))))
2644 (lambda ()
2645 ((lambda (g00036)
2646 ((lambda (g00037)
2647 ((lambda (g00035)
2648 (if (not (eq? g00035 'no))
2649 (apply
2650 (lambda (__
2651 _val
2652 _key
2653 _pat
2654 _exp
2655 _e1
2656 _e2
2657 _e3)
2658 (if (if (syncase:andmap
2659 valid-keyword?
2660 _key)
2661 (valid-syntax-pattern?
2662 _pat
2663 _key)
2664 #f)
2665 ((lambda (g00044)
2666 ((lambda (g00043)
2667 (if (not (eq? g00043
2668 'no))
2669 ((lambda (_pattern
2670 _y
2671 _call)
2672 (list '#(syntax-object
2673 let
2674 (top))
2675 (list (list '#(syntax-object
2676 x
2677 (top))
2678 _val))
2679 (list '#(syntax-object
2680 let
2681 (top))
2682 (list (list _y
2683 (list '#(syntax-object
2684 syntax-dispatch
2685 (top))
2686 '#(syntax-object
2687 x
2688 (top))
2689 (list '#(syntax-object
2690 quote
2691 (top))
2692 _pattern)
2693 (list '#(syntax-object
2694 syntax
2695 (top))
2696 (list->vector
2697 _key)))))
2698 (list '#(syntax-object
2699 if
2700 (top))
2701 (list '#(syntax-object
2702 not
2703 (top))
2704 (list '#(syntax-object
2705 eq?
2706 (top))
2707 _y
2708 (list '#(syntax-object
2709 quote
2710 (top))
2711 '#(syntax-object
2712 no
2713 (top)))))
2714 _call
2715 (cons '#(syntax-object
2716 syntax-case
2717 (top))
2718 (cons '#(syntax-object
2719 x
2720 (top))
2721 (cons _key
2722 (map (lambda (__e1
2723 __e2
2724 __e3)
2725 (cons __e1
2726 (cons __e2
2727 __e3)))
2728 _e1
2729 _e2
2730 _e3))))))))
2731 (car g00043)
2732 (cadr g00043)
2733 (caddr
2734 g00043))
2735 (syntax-error
2736 g00044)))
2737 (syntax-dispatch
2738 g00044
2739 '(pair (any)
2740 pair
2741 (any)
2742 pair
2743 (any)
2744 atom)
2745 (vector))))
2746 (list (convert-syntax-dispatch-pattern
2747 _pat
2748 _key)
2749 '#(syntax-object
2750 y
2751 (top))
2752 (syncase:build-dispatch-call
2753 (extract-bound-syntax-ids
2754 _pat
2755 _key)
2756 _exp
2757 '#(syntax-object
2758 y
2759 (top)))))
2760 (g00037)))
2761 g00035)
2762 (g00037)))
2763 (syntax-dispatch
2764 g00036
2765 '(pair (any)
2766 pair
2767 (any)
2768 pair
2769 (each any)
2770 pair
2771 (pair (any)
2772 pair
2773 (any)
2774 atom)
2775 each
2776 pair
2777 (any)
2778 pair
2779 (any)
2780 each
2781 any)
2782 (vector))))
2783 (lambda ()
2784 ((lambda (g00039)
2785 ((lambda (g00040)
2786 ((lambda (g00038)
2787 (if (not (eq? g00038
2788 'no))
2789 (apply
2790 (lambda (__
2791 _val
2792 _key
2793 _pat
2794 _fender
2795 _exp
2796 _e1
2797 _e2
2798 _e3)
2799 (if (if (syncase:andmap
2800 valid-keyword?
2801 _key)
2802 (valid-syntax-pattern?
2803 _pat
2804 _key)
2805 #f)
2806 ((lambda (g00042)
2807 ((lambda (g00041)
2808 (if (not (eq? g00041
2809 'no))
2810 ((lambda (_pattern
2811 _y
2812 _dorest
2813 _call)
2814 (list '#(syntax-object
2815 let
2816 (top))
2817 (list (list '#(syntax-object
2818 x
2819 (top))
2820 _val))
2821 (list '#(syntax-object
2822 let
2823 (top))
2824 (list (list _dorest
2825 (list '#(syntax-object
2826 lambda
2827 (top))
2828 '()
2829 (cons '#(syntax-object
2830 syntax-case
2831 (top))
2832 (cons '#(syntax-object
2833 x
2834 (top))
2835 (cons _key
2836 (map (lambda (__e1
2837 __e2
2838 __e3)
2839 (cons __e1
2840 (cons __e2
2841 __e3)))
2842 _e1
2843 _e2
2844 _e3)))))))
2845 (list '#(syntax-object
2846 let
2847 (top))
2848 (list (list _y
2849 (list '#(syntax-object
2850 syntax-dispatch
2851 (top))
2852 '#(syntax-object
2853 x
2854 (top))
2855 (list '#(syntax-object
2856 quote
2857 (top))
2858 _pattern)
2859 (list '#(syntax-object
2860 syntax
2861 (top))
2862 (list->vector
2863 _key)))))
2864 (list '#(syntax-object
2865 if
2866 (top))
2867 (list '#(syntax-object
2868 not
2869 (top))
2870 (list '#(syntax-object
2871 eq?
2872 (top))
2873 _y
2874 (list '#(syntax-object
2875 quote
2876 (top))
2877 '#(syntax-object
2878 no
2879 (top)))))
2880 _call
2881 (list _dorest))))))
2882 (car g00041)
2883 (cadr g00041)
2884 (caddr
2885 g00041)
2886 (cadddr
2887 g00041))
2888 (syntax-error
2889 g00042)))
2890 (syntax-dispatch
2891 g00042
2892 '(pair (any)
2893 pair
2894 (any)
2895 pair
2896 (any)
2897 pair
2898 (any)
2899 atom)
2900 (vector))))
2901 (list (convert-syntax-dispatch-pattern
2902 _pat
2903 _key)
2904 '#(syntax-object
2905 y
2906 (top))
2907 '#(syntax-object
2908 dorest
2909 (top))
2910 (syncase:build-dispatch-call
2911 (extract-bound-syntax-ids
2912 _pat
2913 _key)
2914 (list '#(syntax-object
2915 if
2916 (top))
2917 _fender
2918 _exp
2919 (list '#(syntax-object
2920 dorest
2921 (top))))
2922 '#(syntax-object
2923 y
2924 (top)))))
2925 (g00040)))
2926 g00038)
2927 (g00040)))
2928 (syntax-dispatch
2929 g00039
2930 '(pair (any)
2931 pair
2932 (any)
2933 pair
2934 (each any)
2935 pair
2936 (pair (any)
2937 pair
2938 (any)
2939 pair
2940 (any)
2941 atom)
2942 each
2943 pair
2944 (any)
2945 pair
2946 (any)
2947 each
2948 any)
2949 (vector))))
2950 (lambda ()
2951 (syntax-error
2952 g00039))))
2953 g00036))))
2954 g00033))))
2955 g00030))))
2956 x)))))))