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