home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / _eval.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  81.0 KB  |  2,469 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. (##define-macro (global-env-loc x) `(##global-var ,x))
  6. (##define-macro (global-env-ref x) `(##global-var-ref ,x))
  7. (##define-macro (global-env-set! x y) `(##global-var-set! ,x ,y))
  8. (##define-macro (global-env-loc->var x) `(##index->global-var-name ,x))
  9.  
  10. (##define-macro (quasi-list->vector x) `(##quasi-list->vector ,x))
  11. (##define-macro (quasi-append x y) `(##quasi-append ,x ,y))
  12. (##define-macro (quasi-cons x y) `(##quasi-cons ,x ,y))
  13.  
  14. (##define-macro (true? x) x)
  15. (##define-macro (unbound? x) `(##unbound? ,x))
  16. (##define-macro (unspecified-obj) '##undef-object)
  17. (##define-macro (set!-ret-obj) '##unprint-object)
  18.  
  19. (define ##self-var     (##string->uninterned-symbol "<self>"))
  20. (define ##selector-var (##string->uninterned-symbol "<selector>"))
  21. (define ##do-loop-var  (##string->uninterned-symbol "<do-loop>"))
  22.  
  23. (##define-macro (self-var)     '##self-var)
  24. (##define-macro (selector-var) '##selector-var)
  25. (##define-macro (do-loop-var)  '##do-loop-var)
  26.  
  27. (##define-macro (rt-error-unbound-global-var code rte)
  28.   `(##signal '##SIGNAL.GLOBAL-UNBOUND ,code ,rte))
  29.  
  30. (##define-macro (rt-error-non-procedure-send code rte)
  31.   `(##signal '##SIGNAL.NON-PROCEDURE-SEND ,code ,rte))
  32.  
  33. (##define-macro (rt-error-non-procedure-oper code rte)
  34.   `(##signal '##SIGNAL.NON-PROCEDURE-OPERATOR ,code ,rte))
  35.  
  36. (##define-macro (rt-error-too-few-args proc args)
  37.   `(##signal '##SIGNAL.WRONG-NB-ARG ,proc ,args))
  38.  
  39. (##define-macro (rt-error-too-many-args proc args)
  40.   `(##signal '##SIGNAL.WRONG-NB-ARG ,proc ,args))
  41.  
  42. (##define-macro (ct-error-global-env-overflow var)
  43.   `(##signal '##SIGNAL.GLOBAL-ENV-OVERFLOW ,var))
  44.  
  45. (##define-macro (ct-error-syntax msg . args)
  46.   `(##signal '##SIGNAL.SYNTAX-ERROR src ,msg ,@args))
  47.  
  48. ;------------------------------------------------------------------------------
  49.  
  50. ; Macro to create a node of executable code
  51.  
  52. (##define-macro (mk-code code-prc subcodes . lst)
  53.   (let ((n (+ (length subcodes) (length lst))))
  54.     `(let (($code (##make-vector ,(+ n 2) #f)))
  55.        (##vector-set! $code 0 #f)
  56.        (##vector-set! $code 1 ,code-prc)
  57.        ,@(let loop1 ((l subcodes) (i 2) (r '()))
  58.            (if (pair? l)
  59.              (loop1 (cdr l)
  60.                     (+ i 1)
  61.                     (cons `(##vector-set! $code ,i (link-to ,(car l) $code)) r))
  62.              (let loop2 ((l lst) (i i) (r r))
  63.                (if (pair? l)
  64.                  (loop2 (cdr l)
  65.                         (+ i 1)
  66.                         (cons `(##vector-set! $code ,i ,(car l)) r))
  67.                  (reverse r)))))
  68.        $code)))
  69.  
  70. (##define-macro (link-to child parent)
  71.   `(let (($child ,child)) (##vector-set! $child 0 ,parent) $child))
  72.  
  73. (##define-macro (code-link c)     `(##vector-ref ,c 0))
  74. (##define-macro (code-cprc c)     `(##vector-ref ,c 1))
  75. (##define-macro (code-length c)   `(##fixnum.- (##vector-length ,c) 2))
  76. (##define-macro (code-ref c n)    `(##vector-ref ,c (##fixnum.+ ,n 2)))
  77. (##define-macro (code-set! c n x) `(##vector-set! ,c (##fixnum.+ ,n 2) ,x))
  78. (##define-macro (^ n)             `(##vector-ref $code ,(+ n 2)))
  79.  
  80. (define (##mk-code* code-prc lst n)
  81.   (let (($code (##make-vector (##fixnum.+ (##length lst) (##fixnum.+ n 2)) #f)))
  82.     (##vector-set! $code 0 #f)
  83.     (##vector-set! $code 1 code-prc)
  84.     (let loop ((i 0) (l lst))
  85.       (if (##pair? l)
  86.         (begin
  87.           (code-set! $code i (link-to (##car l) $code))
  88.           (loop (##fixnum.+ i 1) (##cdr l)))
  89.         $code))))
  90.  
  91. (##define-macro (code-run c)
  92.   `(let (($$code ,c))
  93.      ((##vector-ref $$code 1) $$code rte)))
  94.  
  95. ; Macro to create the "code procedure" associated with a code node
  96.  
  97. (##define-macro (mk-cprc . def)
  98.   `(lambda ($code rte) ,@def))
  99.  
  100. (##define-macro (mk-gen params . def)
  101.   `(lambda (cte src tail? ,@params) ,@def))
  102.  
  103. (##define-macro (gen proc . args)
  104.   `(,proc cte src tail? ,@args))
  105.  
  106. ;==============================================================================
  107.  
  108. ; Compiler
  109.  
  110. ;------------------------------------------------------------------------------
  111.  
  112. ; Compile time environment manipulation
  113.  
  114. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  115.  
  116. ; Macros to manipulate the compile time environment
  117.  
  118. (##define-macro (mk-loc-access up over) `(##cons ,up ,over))
  119. (##define-macro (loc-access? x) `(##pair? ,x))
  120. (##define-macro (loc-access-up x) `(##car ,x))
  121. (##define-macro (loc-access-over x) `(##cdr ,x))
  122.  
  123. (##define-macro (mk-glo-access var)
  124.   `(or (global-env-loc ,var)
  125.        (ct-error-global-env-overflow ,var)))
  126.  
  127. (##define-macro (glo-access? x)
  128.   `(##not (##pair? ,x)))
  129.  
  130. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  131.  
  132. ; Initial global environment
  133.  
  134. (define ##global-env-macros (##cons (##cons #f #f) '()))
  135. (define ##global-env-decls (##cons '() '()))
  136.  
  137. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  138.  
  139. (define (##make-cte frames)
  140.   (let ((v (##make-vector 3 #f)))
  141.     (##vector-set! v 0 frames)
  142.     (##vector-set! v 1 ##global-env-macros)
  143.     (##vector-set! v 2 ##global-env-decls)
  144.     v))
  145.  
  146. (define (##cte-frames cte) (##vector-ref cte 0))
  147. (define (##cte-macros cte) (##vector-ref cte 1))
  148. (define (##cte-decls cte)  (##vector-ref cte 2))
  149.  
  150. (define (##cte-push-frame cte frame)
  151.   (let ((v (##make-vector 3 #f)))
  152.     (##vector-set! v 0 (##cons frame (##cte-frames cte)))
  153.     (##vector-set! v 1 (##cte-macros cte))
  154.     (##vector-set! v 2 (##cte-decls cte))
  155.     v))
  156.  
  157. (define (##cte-push-macro cte name proc)
  158.   (let ((v (##make-vector 3 #f)))
  159.     (##vector-set! v 0 (##cte-frames cte))
  160.     (##vector-set! v 1 (##cons (##cons name proc) (##cte-macros cte)))
  161.     (##vector-set! v 2 (##cte-decls cte))
  162.     v))
  163.  
  164. (define (##cte-push-decl cte decl)
  165.   (let ((v (##make-vector 3 #f)))
  166.     (##vector-set! v 0 (##cte-frames cte))
  167.     (##vector-set! v 1 (##cte-macros cte))
  168.     (##vector-set! v 2 (##append decl (##cte-decls cte)))
  169.     v))          
  170.  
  171. (define (##cte-add-global-macro name proc)
  172.   (let ((x (##cdr ##global-env-macros)))
  173.     (let ((y (##assq name x)))
  174.       (if y
  175.         (##set-cdr! y proc)
  176.         (##set-cdr! ##global-env-macros
  177.           (##cons (##cons name proc) (##cdr ##global-env-macros)))))))
  178.  
  179. (define (##cte-add-global-decl decl)
  180.   (##set-cdr! ##global-env-decls
  181.     (##append decl (##cdr ##global-env-decls))))
  182.  
  183. (define (##cte-lookup-var cte var)
  184.  
  185.   (define (lookup e up)
  186.     (if e
  187.       (let ((x (##memq var (##car e))))
  188.         (if x
  189.           (mk-loc-access
  190.             up
  191.             (##fixnum.+ (##fixnum.- (##length (##car e)) (##length x)) 1))
  192.           (lookup (##cdr e) (##fixnum.+ up 1))))
  193.       (mk-glo-access var)))
  194.  
  195.   (lookup (##cte-frames cte) 0))
  196.  
  197. (define ##macro? #f)
  198. (set! ##macro?
  199.   (lambda (cte name)
  200.     (and (##symbol? name)
  201.          (##assq name (##cte-macros cte)))))
  202.  
  203. (set! ##macro-expand #f)
  204. (define ##macro-expand
  205.   (lambda (cte src)
  206.     (let ((x (##car src)))
  207.       (touch-vars (x)
  208.         (##apply (##cdr (##assq x (##cte-macros cte)))
  209.                 (##cdr src))))))
  210.  
  211. ;------------------------------------------------------------------------------
  212.  
  213. ; Utilities
  214.  
  215. (define (##self-eval? val)
  216.   (touch-vars (val)
  217.     (or (##complex? val)
  218.         (##string? val)
  219.         (##char? val)
  220.         (##eq? val #f)
  221.         (##eq? val #t))))
  222.  
  223. (define (##variable src x)
  224.   (if (##not (##symbol? x))
  225.     (ct-error-syntax "Identifier expected:" x))
  226.   (if (##memq x
  227.               '(QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING LAMBDA IF SET!
  228.                 COND => ELSE AND OR CASE LET LET* LETREC BEGIN DO DEFINE
  229.                 DELAY FUTURE ##DECLARE ##DEFINE-MACRO ##INCLUDE))
  230.     (ct-error-syntax "Variable name can not be a syntactic keyword:" x)))
  231.  
  232. (define (##shape src x size)
  233.   (let ((n (##proper-length x)))
  234.     (if (or (##not n)
  235.             (if (##fixnum.< 0 size)
  236.               (##not (##fixnum.= n size))
  237.               (##fixnum.< n (##fixnum.- 0 size))))
  238.       (ct-error-syntax "Ill-formed special form:" (##car src)))))
  239.  
  240. (define (##proper-length l)
  241.  
  242.   (define (len l n)
  243.     (cond ((##pair? l) (len (##cdr l) (##fixnum.+ n 1)))
  244.           ((##null? l) n)
  245.           (else        #f)))
  246.  
  247.   (len l 0))
  248.  
  249. (define (##touch-list l)
  250.   (if-touches
  251.     (let loop ((l l))
  252.       (touch-vars (l)
  253.         (if (##pair? l)
  254.           (##cons (##car l) (loop (##cdr l)))
  255.           l)))
  256.     l))
  257.  
  258. (define (##read-expressions cte src filename)
  259.   (if (##string? filename)
  260.  
  261.     (let ((port (##open-input-file filename)))
  262.  
  263.       (define (read-exprs)
  264.         (let ((expr (##read port)))
  265.           (if (##not (##eof-object? expr))
  266.             (##cons expr (read-exprs))
  267.             '())))
  268.  
  269.       (if port
  270.         (let ((exprs (read-exprs)))
  271.           (##close-port port)
  272.           exprs)
  273.         (ct-error-syntax "File not found")))
  274.  
  275.     (ct-error-syntax "Filename expected")))
  276.  
  277. ;------------------------------------------------------------------------------
  278.  
  279. ; Compiler's main entry
  280.  
  281. (define (##compile src frames)
  282.   (let ((cte (##make-cte frames)) (tail? #t))
  283.     (gen ##gen-top
  284.       frames
  285.       (##comp-top (##cte-push-frame cte (##list (self-var))) src tail?))))
  286.  
  287. (define (##comp-top cte src tail?)
  288.   (let ((src (##touch-list src)))
  289.     (cond ((##symbol? src)         (##comp-ref cte src tail?))
  290.           ((##self-eval? src)      (##comp-cst cte src tail?))
  291.           ((##not (##pair? src))   (ct-error-syntax "Ill-formed expression"))
  292.           (else
  293.            (let ((first (##car src)))
  294.              (if (##macro? cte first)
  295.                (##comp-top cte (##macro-expand cte src) tail?)
  296.                (case first
  297.                  ((BEGIN)          (##comp-top-BEGIN cte src tail?))
  298.                  ((DEFINE)         (##comp-top-DEFINE cte src tail?))
  299.                  ((##DECLARE)      (##comp-top-DECLARE cte src tail?))
  300.                  ((##DEFINE-MACRO) (##comp-top-DEFINE-MACRO cte src tail?))
  301.                  ((##INCLUDE)      (##comp-top-INCLUDE cte src tail?))
  302.                  (else             (##comp-aux cte src tail? first)))))))))
  303.  
  304. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  305.  
  306. (define (##comp-top-BEGIN cte src tail?)
  307.   (##shape src src -1)
  308.   (##comp-top-seq cte src tail? (##cdr src)))
  309.  
  310. (define (##comp-top-seq cte src tail? seq)
  311.   (if (##pair? seq)
  312.     (##comp-top-seq-aux cte src tail? seq)
  313.     (gen ##gen-cst (unspecified-obj))))
  314.  
  315. (define (##comp-top-seq-aux cte src tail? seq)
  316.   (let ((rest (##cdr seq)))
  317.     (if (##pair? rest)
  318.       (gen ##gen-seq
  319.         (##comp-top cte (##car seq) #f)
  320.         (##comp-top-seq-aux cte src tail? rest))
  321.       (##comp-top cte (##car seq) tail?))))
  322.  
  323. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  324.  
  325. (define (##comp-top-DEFINE cte src tail?)
  326.   (let ((cte (##make-cte #f)))
  327.     (let ((name (##definition-name src)))
  328.       (let ((ind (##cte-lookup-var cte name)))
  329.         (gen ##gen-glo-def
  330.           name
  331.           ind
  332.           (##comp cte (##definition-value src) #f))))))
  333.  
  334. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  335.  
  336. (define (##comp-top-DECLARE cte src tail?)
  337.   (##shape src src -1)
  338.   (##cte-add-global-decl (##cdr src))
  339.   (gen ##gen-cst (unspecified-obj)))
  340.  
  341. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  342.  
  343. (define (##comp-top-DEFINE-MACRO cte src tail?)
  344.   (let ((name (##definition-name src)))
  345.     (##cte-add-global-macro name (##eval-global (##definition-value src)))
  346.     (gen ##gen-cst name)))
  347.  
  348. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  349.  
  350. (define (##comp-top-INCLUDE cte src tail?)
  351.   (##shape src src 2)
  352.   (##comp-top-seq cte src tail? (##read-expressions cte src (##cadr src))))
  353.  
  354. ;------------------------------------------------------------------------------
  355.  
  356. (define (##comp cte src tail?)
  357.   (let ((src (##touch-list src)))
  358.     (cond ((##symbol? src)         (##comp-ref cte src tail?))
  359.           ((##self-eval? src)      (##comp-cst cte src tail?))
  360.           ((##not (##pair? src))   (ct-error-syntax "Ill-formed expression"))
  361.           (else
  362.            (let ((first (##car src)))
  363.              (if (##macro? cte first)
  364.                (##comp cte (##macro-expand cte src) tail?)
  365.                (case first
  366.                  ((BEGIN)          (##comp-BEGIN cte src tail?))
  367.                  ((DEFINE)         (ct-error-syntax "Ill-placed 'define'"))
  368.                  ((##DECLARE)      (ct-error-syntax "Ill-placed '##declare'"))
  369.                  ((##DEFINE-MACRO) (ct-error-syntax "Ill-placed '##define-macro'"))
  370.                  ((##INCLUDE)      (ct-error-syntax "Ill-placed '##include'"))
  371.                  (else             (##comp-aux cte src tail? first)))))))))
  372.  
  373. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  374.  
  375. (define (##comp-BEGIN cte src tail?)
  376.   (##shape src src -2)
  377.   (##comp-seq cte src tail? (##cdr src)))
  378.  
  379. (define (##comp-seq cte src tail? seq)
  380.   (if (##pair? seq)
  381.     (##comp-seq-aux cte src tail? seq)
  382.     (gen ##gen-cst (unspecified-obj))))
  383.  
  384. (define (##comp-seq-aux cte src tail? seq)
  385.   (let ((rest (##cdr seq)))
  386.     (if (##pair? rest)
  387.       (gen ##gen-seq
  388.         (##comp cte (##car seq) #f)
  389.         (##comp-seq-aux cte src tail? rest))
  390.       (##comp cte (##car seq) tail?))))
  391.  
  392. ;------------------------------------------------------------------------------
  393.  
  394. (define (##comp-aux cte src tail? first)
  395.   (case first
  396.     ((QUOTE)            (##comp-QUOTE cte src tail?))
  397.     ((QUASIQUOTE)       (##comp-QUASIQUOTE cte src tail?))
  398.     ((UNQUOTE)          (ct-error-syntax "Ill-placed 'unquote'"))
  399.     ((UNQUOTE-SPLICING) (ct-error-syntax "Ill-placed 'unquote-splicing'"))
  400.     ((SET!)             (##comp-SET! cte src tail?))
  401.     ((LAMBDA)           (##comp-LAMBDA cte src tail?))
  402.     ((IF)               (##comp-IF cte src tail?))
  403.     ((COND)             (##comp-COND cte src tail?))
  404.     ((AND)              (##comp-AND cte src tail?))
  405.     ((OR)               (##comp-OR cte src tail?))
  406.     ((CASE)             (##comp-CASE cte src tail?))
  407.     ((LET)              (##comp-LET cte src tail?))
  408.     ((LET*)             (##comp-LET* cte src tail?))
  409.     ((LETREC)           (##comp-LETREC cte src tail?))
  410.     ((DO)               (##comp-DO cte src tail?))
  411.     ((DELAY)            (##comp-DELAY cte src tail?))
  412.     ((FUTURE)           (##comp-FUTURE cte src tail?))
  413.     (else               (##comp-app cte src tail?))))
  414.  
  415. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  416.  
  417. (define (##comp-ref cte src tail?)
  418.   (##variable src src)
  419.   (let ((x (##cte-lookup-var cte src)))
  420.     (if (loc-access? x)
  421.       (let ((up (loc-access-up x))
  422.             (over (loc-access-over x)))
  423.         (gen ##gen-loc-ref up over))
  424.       (gen ##gen-glo-ref x))))
  425.  
  426. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  427.  
  428. (define (##comp-cst cte src tail?)
  429.   (gen ##gen-cst src))
  430.  
  431. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  432.  
  433. (define (##comp-QUOTE cte src tail?)
  434.   (##shape src src 2)
  435.   (gen ##gen-cst (##cadr src)))
  436.  
  437. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  438.  
  439. (define (##comp-QUASIQUOTE cte src tail?)
  440.   (##comp-quasi cte src tail? (##touch-list (##cadr src)) 1))
  441.  
  442. (define (##comp-quasi cte src tail? form level)
  443.   (cond ((##eq? level 0)
  444.          (##comp cte form tail?))
  445.         ((##pair? form)
  446.          (let ((x (##car form)))
  447.            (touch-vars (x)
  448.              (case x
  449.                ((QUASIQUOTE)
  450.                 (##comp-quasi-list cte src tail? form (##fixnum.+ level 1)))
  451.                ((UNQUOTE)
  452.                 (if (##eq? level 1)
  453.                   (##comp cte (##cadr form) tail?)
  454.                   (##comp-quasi-list cte src tail? form (##fixnum.- level 1))))
  455.                ((UNQUOTE-SPLICING)
  456.                 (if (##eq? level 1)
  457.                   (ct-error-syntax "Ill-placed 'unquote-splicing'"))
  458.                 (##comp-quasi-list cte src tail? form (##fixnum.- level 1)))
  459.                (else
  460.                 (##comp-quasi-list cte src tail? form level))))))
  461.         ((##vector? form)
  462.          (gen ##gen-quasi-list->vector
  463.            (##comp-quasi-list cte src #f (##vector->list form) level)))
  464.         (else
  465.          (gen ##gen-cst form))))
  466.  
  467. (define (##comp-quasi-list cte src tail? l level)
  468.   (if (##pair? l)
  469.     (let ((first (##touch-list (##car l))))
  470.       (if (and (##eq? level 1) (##unquote-splicing? first))
  471.         (begin
  472.           (##shape src first 2)
  473.           (if (##null? (##cdr l))
  474.             (##comp cte (##cadr first) tail?)
  475.             (gen ##gen-quasi-append
  476.               (##comp cte (##cadr first) #f)
  477.               (##comp-quasi cte src #f (##cdr l) 1))))
  478.         (gen ##gen-quasi-cons
  479.           (##comp-quasi cte src #f first level)
  480.           (##comp-quasi cte src #f (##cdr l) level))))
  481.     (##comp-quasi cte src tail? l level)))
  482.  
  483. (define (##unquote-splicing? x)
  484.   (and (##pair? x)
  485.        (let ((y (##car x)))
  486.          (touch-vars (y)
  487.            (##eq? y 'UNQUOTE-SPLICING)))))
  488.  
  489. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  490.  
  491. (define (##comp-SET! cte src tail?)
  492.   (##shape src src 3)
  493.   (let ((var (##cadr src)))
  494.     (touch-vars (var)
  495.       (begin
  496.         (##variable src var)
  497.         (let ((x (##cte-lookup-var cte var)))
  498.           (if (loc-access? x)
  499.             (let ((up (loc-access-up x))
  500.                   (over (loc-access-over x)))
  501.               (gen ##gen-loc-set up over (##comp cte (##caddr src) #f)))
  502.             (gen ##gen-glo-set x (##comp cte (##caddr src) #f))))))))
  503.  
  504. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  505.  
  506. (define (##comp-LAMBDA cte src tail?)
  507.   (##shape src src -3)
  508.   (##comp-lambda-aux cte src tail? (##touch-list (##cadr src)) (##cddr src)))
  509.  
  510. (define (##comp-lambda-aux cte src tail? parms body)
  511.   (let ((frame (##parms->frame src parms)))
  512.     (let ((c (##comp-body (##cte-push-frame cte (##cons (self-var) frame)) src #t body)))
  513.       (if (##rest-param? parms)
  514.         (gen ##gen-prc-rest frame c)
  515.         (gen ##gen-prc frame c)))))
  516.  
  517. (define (##parms->frame src parms)
  518.   (cond ((##null? parms)
  519.          '())
  520.         ((##pair? parms)
  521.          (let ((x (##car parms)))
  522.            (touch-vars (x)
  523.              (let ((rest (##parms->frame src (##cdr parms))))
  524.                (##variable src x)
  525.                (if (##memq x rest)
  526.                  (ct-error-syntax "Duplicate parameter in parameter list"))
  527.                (##cons x rest)))))
  528.         (else
  529.          (##variable src parms)
  530.          (##list parms))))
  531.  
  532. (define (##rest-param? parms)
  533.   (cond ((##pair? parms)
  534.          (##rest-param? (##cdr parms)))
  535.         ((##null? parms)
  536.          #f)
  537.         (else
  538.          #t)))
  539.  
  540. (define (##comp-body cte src tail? body)
  541.  
  542.   (define (letrec-defines cte vars vals body)
  543.     (if (##pair? body)
  544.  
  545.       (let ((src (##touch-list (##car body))))
  546.         (if (##not (##pair? src))
  547.           (letrec-defines* cte vars vals body)
  548.           (let ((first (##car src)))
  549.             (touch-vars (first)
  550.               (if (##macro? cte first)
  551.                 (letrec-defines cte
  552.                                 vars
  553.                                 vals
  554.                                 (##cons (##macro-expand cte src) (##cdr body)))
  555.                 (case first
  556.                   ((BEGIN)
  557.                    (letrec-defines cte
  558.                                    vars
  559.                                    vals
  560.                                    (##append (##cdr src) (##cdr body))))
  561.                   ((DEFINE)
  562.                    (let ((x (##definition-name src)))
  563.                      (##variable src x)
  564.                      (if (##memq x vars)
  565.                        (ct-error-syntax "Duplicate definition of a variable"))
  566.                      (letrec-defines cte
  567.                                      (##cons x vars)
  568.                                      (##cons (##definition-value src) vals)
  569.                                      (##cdr body))))
  570.                   ((##DECLARE)
  571.                    (##shape src src -1)
  572.                    (letrec-defines (##cte-push-decl cte (##cdr src))
  573.                                    vars
  574.                                    vals
  575.                                    (##cdr body)))
  576.                   ((##DEFINE-MACRO)
  577.                    (let ((x (##definition-name src)))
  578.                      (letrec-defines (##cte-push-macro
  579.                                        cte
  580.                                        x
  581.                                        (##eval-global (##definition-value src)))
  582.                                      vars
  583.                                      vals
  584.                                      (##cdr body))))
  585.                   ((##INCLUDE)
  586.                    (##shape src src 2)
  587.                    (letrec-defines cte
  588.                                    vars
  589.                                    vals
  590.                                    (##append (##read-expressions cte src (##cadr src))
  591.                                              (##cdr body))))
  592.                   (else
  593.                    (letrec-defines* cte vars vals body))))))))
  594.  
  595.       (ct-error-syntax "Body must contain at least one evaluable expression")))
  596.  
  597.   (define (letrec-defines* cte vars vals body)
  598.     (if (##null? vars)
  599.       (##comp-seq cte src tail? body)
  600.       (##comp-letrec-aux cte src tail? vars vals body)))
  601.  
  602.   (letrec-defines cte '() '() body))
  603.  
  604. (define (##definition-name src)
  605.   (##shape src src -3)
  606.   (let ((pattern (##cadr src)))
  607.     (touch-vars (pattern)
  608.       (let ((name (if (##pair? pattern)
  609.                     (let ((name (##car pattern)))
  610.                       (touch-vars (name)
  611.                         name))
  612.                     (begin
  613.                       (##shape src src 3)
  614.                       pattern))))
  615.         (if (##not (##symbol? name))
  616.           (ct-error-syntax "Defined variable must be an identifier"))
  617.         name))))
  618.  
  619. (define (##definition-value src)
  620.   (let ((pattern (##cadr src)))
  621.     (touch-vars (pattern)
  622.       (if (##pair? pattern)
  623.         (##cons 'LAMBDA (##cons (##cdr pattern) (##cddr src)))
  624.         (##caddr src)))))
  625.  
  626. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  627.  
  628. (define (##comp-IF cte src tail?)
  629.   (##shape src src -3)
  630.   (if (##pair? (##cdddr src))
  631.     (begin
  632.       (##shape src src 4)
  633.       (gen ##gen-if3
  634.         (##comp cte (##cadr src) #f)
  635.         (##comp cte (##caddr src) tail?)
  636.         (##comp cte (##cadddr src) tail?)))
  637.     (begin
  638.       (##shape src src 3)
  639.       (gen ##gen-if2
  640.         (##comp cte (##cadr src) #f)
  641.         (##comp cte (##caddr src) tail?)))))
  642.  
  643. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  644.  
  645. (define (##comp-COND cte src tail?)
  646.   (##shape src src -2)
  647.   (##comp-cond-aux cte src tail? (##cdr src)))
  648.  
  649. (define (##comp-cond-aux cte src tail? clauses)
  650.   (if (##pair? clauses)
  651.     (let ((clause (##touch-list (##car clauses))))
  652.       (##shape src clause -1)
  653.       (let ((x (##car clause)))
  654.         (touch-vars (x)
  655.           (cond ((##eq? x 'ELSE)
  656.                  (##shape src clause -2)
  657.                  (if (##not (##null? (##cdr clauses)))
  658.                    (ct-error-syntax "ELSE clause must be last"))
  659.                  (##comp-seq cte src tail? (##cdr clause)))
  660.                 ((##not (##pair? (##cdr clause)))
  661.                  (gen ##gen-cond-or
  662.                     (##comp cte (##car clause) #f)
  663.                     (##comp-cond-aux cte src tail? (##cdr clauses))))
  664.                 (else
  665.                  (let ((y (##cadr clause)))
  666.                    (touch-vars (y)
  667.                      (if (##eq? y '=>)
  668.                        (begin
  669.                          (##shape src clause -3)
  670.                          (gen ##gen-cond-send
  671.                            (##comp cte (##car clause) #f)
  672.                            (##comp cte (##caddr clause) #f)
  673.                            (##comp-cond-aux cte src tail? (##cdr clauses))))
  674.                        (gen ##gen-cond-if
  675.                          (##comp cte (##car clause) #f)
  676.                          (##comp-seq cte src tail? (##cdr clause))
  677.                          (##comp-cond-aux cte src tail? (##cdr clauses)))))))))))
  678.     (gen ##gen-cst (unspecified-obj))))
  679.  
  680. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  681.  
  682. (define (##comp-AND cte src tail?)
  683.   (let ((rest (##cdr src)))
  684.     (if (##pair? rest)
  685.       (##comp-and-aux cte src tail? rest)
  686.       (gen ##gen-cst #t))))
  687.  
  688. (define (##comp-and-aux cte src tail? l)
  689.   (let ((rest (##cdr l)))
  690.     (if (##pair? rest)
  691.       (gen ##gen-and
  692.         (##comp cte (##car l) #f)
  693.         (##comp-and-aux cte src tail? rest))
  694.       (##comp cte (##car l) tail?))))
  695.  
  696. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  697.  
  698. (define (##comp-OR cte src tail?)
  699.   (let ((rest (##cdr src)))
  700.     (if (##pair? rest)
  701.       (##comp-or-aux cte src tail? rest)
  702.       (gen ##gen-cst #f))))
  703.  
  704. (define (##comp-or-aux cte src tail? l)
  705.   (let ((rest (##cdr l)))
  706.     (if (##pair? rest)
  707.       (gen ##gen-or
  708.         (##comp cte (##car l) #f)
  709.         (##comp-or-aux cte src tail? rest))
  710.       (##comp cte (##car l) tail?))))
  711.  
  712. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  713.  
  714. (define (##comp-CASE cte src tail?)
  715.   (##shape src src -3)
  716.   (gen ##gen-case
  717.     (##comp cte (##cadr src) #f)
  718.     (let ((cte (##cte-push-frame cte (##list (selector-var)))))
  719.       (##comp-case-aux cte src tail? (##cddr src)))))
  720.  
  721. (define (##comp-case-aux cte src tail? clauses)
  722.   (if (##pair? clauses)
  723.     (let ((clause (##touch-list (##car clauses))))
  724.       (##shape src clause -2)
  725.       (let ((first (##touch-list (##car clause))))
  726.         (if (##eq? first 'ELSE)
  727.           (begin
  728.             (if (##not (##null? (##cdr clauses)))
  729.               (ct-error-syntax "ELSE clause must be last"))
  730.             (gen ##gen-case-else
  731.               (##comp-seq cte src tail? (##cdr clause))))
  732.           (gen ##gen-case-clause
  733.             first
  734.             (##comp-seq cte src tail? (##cdr clause))
  735.             (##comp-case-aux cte src tail? (##cdr clauses))))))
  736.     (gen ##gen-case-else
  737.       (gen ##gen-cst (unspecified-obj)))))
  738.  
  739. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  740.  
  741. (define (##comp-LET cte src tail?)
  742.   (##shape src src -3)
  743.   (let ((x (##touch-list (##cadr src))))
  744.     (cond ((##symbol? x)
  745.            (##shape src src -4)
  746.            (let ((bindings (##touch-list (##caddr src))))
  747.              (let* ((vars (##bindings->vars src bindings #t))
  748.                     (vals (##bindings->vals bindings)))
  749.                (gen ##gen-app
  750.                  (let ((inner-cte (##cte-push-frame cte (##list x))))
  751.                    (gen ##gen-letrec
  752.                      (##list x)
  753.                      (let ((cte inner-cte)
  754.                            (tail? #f))
  755.                        (##list (gen ##gen-prc
  756.                                vars
  757.                                (##comp-body (##cte-push-frame cte (##cons (self-var) vars))
  758.                                             src
  759.                                             #t
  760.                                             (##cdddr src)))))
  761.                      (let ((cte inner-cte)
  762.                            (tail? #f))
  763.                        (gen ##gen-loc-ref 0 1)))) ; fetch loop variable
  764.                  (##comp-vals cte vals)))))
  765.           ((##null? x)
  766.            (##comp-body cte src tail? (##cddr src)))
  767.           (else
  768.            (let* ((bindings x)
  769.                   (vars (##bindings->vars src bindings #t))
  770.                   (vals (##bindings->vals bindings)))
  771.              (let ((c (##comp-body (##cte-push-frame cte vars) src tail? (##cddr src))))
  772.                (gen ##gen-let
  773.                  vars
  774.                  (##comp-vals cte vals)
  775.                  c)))))))
  776.  
  777. (define (##comp-vals cte l)
  778.   (if (##pair? l)
  779.     (##cons (##comp cte (##car l) #f) (##comp-vals cte (##cdr l)))
  780.     '()))
  781.  
  782. (define (##bindings->vars src bindings check-duplicates?)
  783.   (if (##pair? bindings)
  784.     (let ((binding (##touch-list (##car bindings))))
  785.       (##shape src binding 2)
  786.       (let ((x (##car binding)))
  787.         (touch-vars (x)
  788.           (let ((rest (##bindings->vars src (##cdr bindings) check-duplicates?)))
  789.             (##variable src x)
  790.             (if (and check-duplicates? (##memq x rest))
  791.               (ct-error-syntax "Duplicate variable in bindings"))
  792.             (##cons x rest)))))
  793.     (if (##null? bindings)
  794.       '()
  795.       (ct-error-syntax "Ill-terminated bindings"))))
  796.  
  797. (define (##bindings->vals bindings)
  798.   (if (##pair? bindings)
  799.     (let ((binding (##touch-list (##car bindings))))
  800.       (##cons (##cadr binding) (##bindings->vals (##cdr bindings))))
  801.     '()))
  802.  
  803. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  804.  
  805. (define (##comp-LET* cte src tail?)
  806.   (##shape src src -3)
  807.   (let ((bindings (##cadr src)))
  808.     (touch-vars (bindings)
  809.       (let* ((vars (##bindings->vars src bindings #f))
  810.              (vals (##bindings->vals bindings)))
  811.         (##comp-let*-aux cte src tail? vars vals (##cddr src))))))
  812.  
  813. (define (##comp-let*-aux cte src tail? vars vals body)
  814.   (if (##pair? vars)
  815.     (let ((frame (##list (##car vars))))
  816.       (let ((inner-cte (##cte-push-frame cte frame)))
  817.         (gen ##gen-let
  818.           frame
  819.           (##list (##comp cte (##car vals) #f))
  820.           (##comp-let*-aux inner-cte src tail? (##cdr vars) (##cdr vals) body))))
  821.     (##comp-body cte src tail? body)))
  822.  
  823. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  824.  
  825. (define (##comp-LETREC cte src tail?)
  826.   (##shape src src -3)
  827.   (let ((bindings (##touch-list (##cadr src))))
  828.     (if (##null? bindings)
  829.       (##comp-body cte src tail? (##cddr src))
  830.       (let* ((vars (##bindings->vars src bindings #t))
  831.              (vals (##bindings->vals bindings)))
  832.         (##comp-letrec-aux cte src tail? vars vals (##cddr src))))))
  833.  
  834. (define (##comp-letrec-aux cte src tail? vars vals body)
  835.   (if (##pair? vars)
  836.     (let ((inner-cte (##cte-push-frame cte vars)))
  837.       (gen ##gen-letrec
  838.         vars
  839.         (##comp-vals inner-cte vals)
  840.         (##comp-body inner-cte src tail? body)))
  841.     (##comp-body cte src tail? body)))
  842.  
  843. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  844.  
  845. (define (##comp-do cte src tail?)
  846.   (##shape src src -3)
  847.   (let ((bindings (##touch-list (##cadr src)))
  848.         (exit (##touch-list (##caddr src))))
  849.     (##shape src exit -1)
  850.     (let* ((vars (##bindings->vars* src bindings))
  851.            (do-loop-vars (##list (do-loop-var)))
  852.            (inner-cte (##cte-push-frame cte do-loop-vars)))
  853.       (gen ##gen-letrec
  854.         do-loop-vars
  855.         (##list
  856.           (let ((cte inner-cte)
  857.                 (tail? #f))
  858.             (gen ##gen-prc
  859.               vars
  860.               (let ((cte (##cte-push-frame cte (##cons (self-var) vars)))
  861.                     (tail? #t))
  862.                 (gen ##gen-if3
  863.                   (##comp cte (##car exit) #f)
  864.                   (##comp-seq cte src tail? (##cdr exit))
  865.                   (let ((call
  866.                           (gen ##gen-app
  867.                             (let ((tail? #f))
  868.                               (gen ##gen-loc-ref 1 1)) ; fetch do-loop-var
  869.                             (##comp-vals cte (##bindings->steps bindings)))))
  870.                     (if (##null? (##cdddr src))
  871.                       call
  872.                       (gen ##gen-seq
  873.                         (##comp-seq cte src #f (##cdddr src))
  874.                         call))))))))
  875.         (let ((cte inner-cte))
  876.           (gen ##gen-app
  877.             (let ((tail? #f))
  878.               (gen ##gen-loc-ref 0 1)) ; fetch do-loop-var
  879.             (##comp-vals cte (##bindings->vals bindings))))))))
  880.  
  881. (define (##bindings->vars* src bindings)
  882.   (if (##pair? bindings)
  883.     (let ((binding (##touch-list (##car bindings))))
  884.       (##shape src binding -2)
  885.       (if (##pair? (##cddr binding)) (##shape src binding 3))
  886.       (let ((x (##car binding)))
  887.         (touch-vars (x)
  888.           (let ((rest (##bindings->vars* src (##cdr bindings))))
  889.             (##variable src x)
  890.             (if (##memq x rest)
  891.               (ct-error-syntax "Duplicate variable in bindings"))
  892.             (##cons x rest)))))
  893.     (if (##null? bindings)
  894.       '()
  895.       (ct-error-syntax "Ill-terminated bindings"))))
  896.  
  897. (define (##bindings->steps bindings)
  898.   (if (##pair? bindings)
  899.     (let ((binding (##touch-list (##car bindings))))
  900.       (##cons (if (##pair? (##cddr binding)) (##caddr binding) (##car binding))
  901.               (##bindings->steps (##cdr bindings))))
  902.     '()))
  903.  
  904. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  905.  
  906. (define (##comp-app cte src tail?)
  907.   (let ((n (##proper-length src)))
  908.     (if n
  909.       (gen ##gen-app
  910.         (##comp cte (##car src) #f)
  911.         (##comp-vals cte (##cdr src)))
  912.       (ct-error-syntax "Ill-formed procedure application"))))
  913.  
  914. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  915.  
  916. (define (##comp-DELAY cte src tail?)
  917.   (##shape src src 2)
  918.   (gen ##gen-delay (##comp cte (##cadr src) #t)))
  919.  
  920. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  921.  
  922. (define (##comp-FUTURE cte src tail?)
  923.   (##shape src src 2)
  924.   (gen ##gen-future (##comp cte (##cadr src) #t)))
  925.  
  926. ;==============================================================================
  927.  
  928. ; Code generation procedures
  929.  
  930. ;------------------------------------------------------------------------------
  931.  
  932. ; Macros to manipulate the runtime environment
  933.  
  934. (##define-macro (mk-rte rte . lst)
  935.   (let ((n (length lst)))
  936.     `(let (($rte (##make-vector ,(+ n 1) (unspecified-obj))))
  937.        (##vector-set! $rte 0 ,rte)
  938.        ,@(let loop2 ((l lst) (i 1) (r '()))
  939.            (if (pair? l)
  940.              (loop2 (cdr l) (+ i 1) (cons `(##vector-set! $rte ,i ,(car l)) r))
  941.              (reverse r)))
  942.        $rte)))
  943.  
  944. (##define-macro (mk-rte* rte n)
  945.   `(let (($rte (##make-vector (##fixnum.+ ,n 1) (unspecified-obj))))
  946.      (##vector-set! $rte 0 ,rte)
  947.      $rte))
  948.  
  949. (##define-macro (rte-up rte)         `(##vector-ref ,rte 0))
  950. (##define-macro (rte-ref rte i)      `(##vector-ref ,rte ,i))
  951. (##define-macro (rte-set! rte i val) `(##vector-set! ,rte ,i ,val))
  952.  
  953. ;------------------------------------------------------------------------------
  954.  
  955. (define ##cprc-top
  956.   (mk-cprc
  957.     (##subproblem-apply0 $code rte
  958.       (lambda ()
  959.         (let ((rte (mk-rte rte #f)))
  960.           (code-run (^ 0)))))))
  961.  
  962. (define ##gen-top
  963.   (mk-gen (frames val)
  964.     (mk-code ##cprc-top (val) frames)))
  965.  
  966. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  967.  
  968. (define ##cprc-cst-null  (mk-cprc '()))
  969. (define ##cprc-cst-true  (mk-cprc #t))
  970. (define ##cprc-cst-false (mk-cprc #f))
  971. (define ##cprc-cst--2    (mk-cprc -2))
  972. (define ##cprc-cst--1    (mk-cprc -1))
  973. (define ##cprc-cst-0     (mk-cprc 0))
  974. (define ##cprc-cst-1     (mk-cprc 1))
  975. (define ##cprc-cst-2     (mk-cprc 2))
  976. (define ##cprc-cst       (mk-cprc (^ 0)))
  977.  
  978. (define ##gen-cst
  979.   (mk-gen (val)
  980.     (case val
  981.       ((()) (mk-code ##cprc-cst-null  ()))
  982.       ((#t) (mk-code ##cprc-cst-true  ()))
  983.       ((#f) (mk-code ##cprc-cst-false ()))
  984.       ((-2) (mk-code ##cprc-cst--2    ()))
  985.       ((-1) (mk-code ##cprc-cst--1    ()))
  986.       ((0)  (mk-code ##cprc-cst-0     ()))
  987.       ((1)  (mk-code ##cprc-cst-1     ()))
  988.       ((2)  (mk-code ##cprc-cst-2     ()))
  989.       (else (mk-code ##cprc-cst       () val)))))
  990.  
  991. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  992.  
  993. (define ##cprc-loc-ref-0-1 (mk-cprc (rte-ref rte 1)))
  994. (define ##cprc-loc-ref-0-2 (mk-cprc (rte-ref rte 2)))
  995. (define ##cprc-loc-ref-0-3 (mk-cprc (rte-ref rte 3)))
  996.  
  997. (define ##cprc-loc-ref-1-1 (mk-cprc (rte-ref (rte-up rte) 1)))
  998. (define ##cprc-loc-ref-1-2 (mk-cprc (rte-ref (rte-up rte) 2)))
  999. (define ##cprc-loc-ref-1-3 (mk-cprc (rte-ref (rte-up rte) 3)))
  1000.  
  1001. (define ##cprc-loc-ref-2-1 (mk-cprc (rte-ref (rte-up (rte-up rte)) 1)))
  1002. (define ##cprc-loc-ref-2-2 (mk-cprc (rte-ref (rte-up (rte-up rte)) 2)))
  1003. (define ##cprc-loc-ref-2-3 (mk-cprc (rte-ref (rte-up (rte-up rte)) 3)))
  1004.  
  1005. (define ##cprc-loc-ref
  1006.   (mk-cprc
  1007.     (let loop ((e rte) (i (^ 0)))
  1008.       (if (##fixnum.< 0 i)
  1009.         (loop (rte-up e) (##fixnum.- i 1))
  1010.         (rte-ref e (^ 1))))))
  1011.  
  1012. (define ##gen-loc-ref
  1013.   (mk-gen (up over)
  1014.     (case up
  1015.       ((0)
  1016.        (case over
  1017.          ((1)  (mk-code ##cprc-loc-ref-0-1 ()))
  1018.          ((2)  (mk-code ##cprc-loc-ref-0-2 ()))
  1019.          ((3)  (mk-code ##cprc-loc-ref-0-3 ()))
  1020.          (else (mk-code ##cprc-loc-ref     () up over))))
  1021.       ((1)
  1022.        (case over
  1023.          ((1)  (mk-code ##cprc-loc-ref-1-1 ()))
  1024.          ((2)  (mk-code ##cprc-loc-ref-1-2 ()))
  1025.          ((3)  (mk-code ##cprc-loc-ref-1-3 ()))
  1026.          (else (mk-code ##cprc-loc-ref     () up over))))
  1027.       ((2)
  1028.        (case over
  1029.          ((1)  (mk-code ##cprc-loc-ref-2-1 ()))
  1030.          ((2)  (mk-code ##cprc-loc-ref-2-2 ()))
  1031.          ((3)  (mk-code ##cprc-loc-ref-2-3 ()))
  1032.          (else (mk-code ##cprc-loc-ref     () up over))))
  1033.      (else
  1034.        (mk-code ##cprc-loc-ref () up over)))))
  1035.  
  1036. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1037.  
  1038. (define ##cprc-glo-ref
  1039.   (mk-cprc
  1040.     (let loop ((val (global-env-ref (^ 0))))
  1041.       (if (unbound? val)
  1042.         (loop (rt-error-unbound-global-var $code rte))
  1043.         val))))
  1044.  
  1045. (define ##gen-glo-ref
  1046.   (mk-gen (ind)
  1047.     (mk-code ##cprc-glo-ref () ind)))
  1048.  
  1049. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1050.  
  1051. (define ##cprc-loc-set
  1052.   (mk-cprc
  1053.     (let ((val (code-run (^ 0))))
  1054.       (let loop ((e rte) (i (^ 1)))
  1055.         (if (##fixnum.< 0 i)
  1056.           (loop (rte-up e) (##fixnum.- i 1))
  1057.           (begin
  1058.             (rte-set! e (^ 2) val)
  1059.             (set!-ret-obj)))))))
  1060.  
  1061. (define ##gen-loc-set
  1062.   (mk-gen (up over val)
  1063.     (mk-code ##cprc-loc-set (val) up over)))
  1064.  
  1065. (define ##cprc-glo-set
  1066.   (mk-cprc
  1067.     (let ((val (code-run (^ 0))))
  1068.       (global-env-set! (^ 1) val)
  1069.       (set!-ret-obj))))
  1070.  
  1071. (define ##gen-glo-set
  1072.   (mk-gen (ind val)
  1073.     (mk-code ##cprc-glo-set (val) ind)))
  1074.  
  1075. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1076.  
  1077. (define ##cprc-glo-def
  1078.   (mk-cprc
  1079.     (let ((rte #f))
  1080.       (global-env-set! (^ 1) (code-run (^ 0)))
  1081.       (^ 2))))
  1082.  
  1083. (define ##gen-glo-def
  1084.   (mk-gen (name ind val)
  1085.     (mk-code ##cprc-glo-def (val) ind name)))
  1086.  
  1087. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1088.  
  1089. (define ##cprc-if2
  1090.   (mk-cprc
  1091.     (let ((pred (code-run (^ 0))))
  1092.       (touch-vars (pred)
  1093.         (if (true? pred)
  1094.           (code-run (^ 1))
  1095.           (unspecified-obj))))))
  1096.  
  1097. (define ##gen-if2
  1098.   (mk-gen (pre con)
  1099.     (mk-code ##cprc-if2 (pre con))))
  1100.  
  1101. (define ##cprc-if3
  1102.   (mk-cprc
  1103.     (let ((pred (code-run (^ 0))))
  1104.       (touch-vars (pred)
  1105.         (if (true? pred)
  1106.           (code-run (^ 1))
  1107.           (code-run (^ 2)))))))
  1108.  
  1109. (define ##gen-if3
  1110.   (mk-gen (pre con alt)
  1111.     (mk-code ##cprc-if3 (pre con alt))))
  1112.  
  1113. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1114.  
  1115. (define ##cprc-seq
  1116.   (mk-cprc
  1117.     (code-run (^ 0))
  1118.     (code-run (^ 1))))
  1119.  
  1120. (define ##gen-seq
  1121.   (mk-gen (val1 val2)
  1122.     (mk-code ##cprc-seq (val1 val2))))
  1123.  
  1124. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1125.  
  1126. (define ##cprc-quasi-list->vector
  1127.   (mk-cprc
  1128.     (quasi-list->vector (code-run (^ 0)))))
  1129.  
  1130. (define ##gen-quasi-list->vector
  1131.   (mk-gen (val)
  1132.     (mk-code ##cprc-quasi-list->vector (val))))
  1133.  
  1134. (define ##cprc-quasi-append
  1135.   (mk-cprc
  1136.     (quasi-append (code-run (^ 0)) (code-run (^ 1)))))
  1137.  
  1138. (define ##gen-quasi-append
  1139.   (mk-gen (val1 val2)
  1140.     (mk-code ##cprc-quasi-append (val1 val2))))
  1141.  
  1142. (define ##cprc-quasi-cons
  1143.   (mk-cprc
  1144.     (quasi-cons (code-run (^ 0)) (code-run (^ 1)))))
  1145.  
  1146. (define ##gen-quasi-cons
  1147.   (mk-gen (val1 val2)
  1148.     (mk-code ##cprc-quasi-cons (val1 val2))))
  1149.  
  1150. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1151.  
  1152. (define ##cprc-cond-if
  1153.   (mk-cprc
  1154.     (let ((pred (code-run (^ 0))))
  1155.       (touch-vars (pred)
  1156.         (if (true? pred)
  1157.           (code-run (^ 1))
  1158.           (code-run (^ 2)))))))
  1159.  
  1160. (define ##gen-cond-if
  1161.   (mk-gen (val1 val2 val3)
  1162.     (mk-code ##cprc-cond-if (val1 val2 val3))))
  1163.  
  1164. (define ##cprc-cond-or
  1165.   (mk-cprc
  1166.     (let ((pred (code-run (^ 0))))
  1167.       (touch-vars (pred)
  1168.         (if (true? pred)
  1169.           pred
  1170.           (code-run (^ 1)))))))
  1171.  
  1172. (define ##gen-cond-or
  1173.   (mk-gen (val1 val2)
  1174.     (mk-code ##cprc-cond-or (val1 val2))))
  1175.  
  1176. (define ##cprc-cond-send-red
  1177.   (mk-cprc
  1178.     (let ((pred (code-run (^ 0))))
  1179.       (touch-vars (pred)
  1180.         (if (true? pred)
  1181.           (let loop ((proc (code-run (^ 1))))
  1182.             (touch-vars (proc)
  1183.               (if (##not (##procedure? proc))
  1184.                 (loop (rt-error-non-procedure-send $code rte))
  1185.                 (##reduction-apply1 $code rte proc pred))))
  1186.           (code-run (^ 2)))))))
  1187.  
  1188. (define ##cprc-cond-send-sub
  1189.   (mk-cprc
  1190.     (let ((pred (code-run (^ 0))))
  1191.       (touch-vars (pred)
  1192.         (if (true? pred)
  1193.           (let loop ((proc (code-run (^ 1))))
  1194.             (touch-vars (proc)
  1195.               (if (##not (##procedure? proc))
  1196.                 (loop (rt-error-non-procedure-send $code rte))
  1197.                 (##subproblem-apply1 $code rte proc pred))))
  1198.           (code-run (^ 2)))))))
  1199.  
  1200. (define ##gen-cond-send
  1201.   (mk-gen (val1 val2 val3)
  1202.     (mk-code (if tail? ##cprc-cond-send-red ##cprc-cond-send-sub)
  1203.              (val1 val2 val3))))
  1204.  
  1205. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1206.  
  1207. (define ##cprc-or
  1208.   (mk-cprc
  1209.     (let ((pred (code-run (^ 0))))
  1210.       (touch-vars (pred)
  1211.         (if (true? pred)
  1212.           pred
  1213.           (code-run (^ 1)))))))
  1214.  
  1215. (define ##gen-or
  1216.   (mk-gen (val1 val2)
  1217.     (mk-code ##cprc-or (val1 val2))))
  1218.  
  1219. (define ##cprc-and
  1220.   (mk-cprc
  1221.     (let ((pred (code-run (^ 0))))
  1222.       (touch-vars (pred)
  1223.         (if (##not (true? pred))
  1224.           pred
  1225.           (code-run (^ 1)))))))
  1226.  
  1227. (define ##gen-and
  1228.   (mk-gen (val1 val2)
  1229.     (mk-code ##cprc-and (val1 val2))))
  1230.  
  1231. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1232.  
  1233. (define ##cprc-case
  1234.   (mk-cprc
  1235.     (let ((selector (code-run (^ 0))))
  1236.       (touch-vars (selector)
  1237.         (let ((rte (mk-rte rte selector)))
  1238.           (code-run (^ 1)))))))
  1239.  
  1240. (define ##gen-case
  1241.   (mk-gen (val1 val2)
  1242.     (mk-code ##cprc-case (val1 val2))))
  1243.  
  1244. (define ##cprc-case-clause
  1245.   (mk-cprc
  1246.     (if (##case-memv (rte-ref rte 1) (^ 2))
  1247.       (code-run (^ 0))
  1248.       (code-run (^ 1)))))
  1249.  
  1250. (define ##gen-case-clause
  1251.   (mk-gen (cases val1 val2)
  1252.     (mk-code ##cprc-case-clause (val1 val2) cases)))
  1253.  
  1254. (define ##cprc-case-else
  1255.   (mk-cprc
  1256.     (code-run (^ 0))))
  1257.  
  1258. (define ##gen-case-else
  1259.   (mk-gen (val)
  1260.     (mk-code ##cprc-case-else (val))))
  1261.  
  1262. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1263.  
  1264. (define ##cprc-let
  1265.   (mk-cprc
  1266.     (let ((n (##fixnum.- (code-length $code) 2)))
  1267.       (let ((inner-rte (mk-rte* rte n)))
  1268.         (let loop ((i n))
  1269.           (if (##fixnum.< 0 i)
  1270.             (begin
  1271.               (rte-set! inner-rte i (code-run (code-ref $code i)))
  1272.               (loop (##fixnum.- i 1)))
  1273.             (let ((rte inner-rte))
  1274.               (code-run (^ 0)))))))))
  1275.  
  1276. (define ##gen-let
  1277.   (mk-gen (vars vals body)
  1278.     (let ((c (##mk-code* ##cprc-let (##cons body vals) 1)))
  1279.       (code-set! c (##fixnum.+ (##length vals) 1) vars)
  1280.       c)))
  1281.  
  1282. (define ##cprc-letrec
  1283.   (mk-cprc
  1284.     (let ((n (##fixnum.- (code-length $code) 2)))
  1285.       (let ((rte (mk-rte* rte n)))
  1286.         (let loop ((i n))
  1287.           (if (##fixnum.< 0 i)
  1288.             (begin
  1289.               (rte-set! rte i (code-run (code-ref $code i)))
  1290.               (loop (##fixnum.- i 1)))
  1291.             (code-run (^ 0))))))))
  1292.  
  1293. (define ##gen-letrec
  1294.   (mk-gen (vars vals body)
  1295.     (let ((c (##mk-code* ##cprc-letrec (##cons body vals) 1)))
  1296.       (code-set! c (##fixnum.+ (##length vals) 1) vars)
  1297.       c)))
  1298.  
  1299. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1300.  
  1301. (define ##cprc-prc0
  1302.   (mk-cprc
  1303.     (letrec ((proc
  1304.                (lambda ()
  1305.                  (let ((rte (mk-rte rte proc)))
  1306.                    (code-run (^ 0))))))
  1307.       proc)))
  1308.  
  1309. (define ##cprc-prc1
  1310.   (mk-cprc
  1311.     (letrec ((proc
  1312.                (lambda (arg1)
  1313.                  (let ((rte (mk-rte rte proc arg1)))
  1314.                    (code-run (^ 0))))))
  1315.       proc)))
  1316.  
  1317. (define ##cprc-prc2
  1318.   (mk-cprc
  1319.     (letrec ((proc
  1320.                (lambda (arg1 arg2)
  1321.                  (let ((rte (mk-rte rte proc arg1 arg2)))
  1322.                    (code-run (^ 0))))))
  1323.       proc)))
  1324.  
  1325. (define ##cprc-prc3
  1326.   (mk-cprc
  1327.     (letrec ((proc
  1328.                (lambda (arg1 arg2 arg3)
  1329.                  (let ((rte (mk-rte rte proc arg1 arg2 arg3)))
  1330.                    (code-run (^ 0))))))
  1331.       proc)))
  1332.  
  1333. (define ##cprc-prc
  1334.   (mk-cprc
  1335.     (letrec ((proc
  1336.                (lambda args
  1337.                  (let ((n (^ 1)))
  1338.                    (let ((inner-rte (mk-rte* rte n)))
  1339.                      (rte-set! inner-rte 1 proc)
  1340.                      (let loop ((i 2) (l args))
  1341.                        (if (##fixnum.< n i)
  1342.                          (if (##pair? l)
  1343.                            (rt-error-too-many-args proc args)
  1344.                            (let ((rte inner-rte))
  1345.                              (code-run (^ 0))))
  1346.                          (if (##pair? l)
  1347.                            (begin
  1348.                              (rte-set! inner-rte i (##car l))
  1349.                              (loop (##fixnum.+ i 1) (##cdr l)))
  1350.                            (rt-error-too-few-args proc args)))))))))
  1351.       proc)))
  1352.  
  1353. (define ##gen-prc
  1354.   (mk-gen (frame body)
  1355.     (case (##length frame)
  1356.       ((0)  (mk-code ##cprc-prc0 (body) frame))
  1357.       ((1)  (mk-code ##cprc-prc1 (body) frame))
  1358.       ((2)  (mk-code ##cprc-prc2 (body) frame))
  1359.       ((3)  (mk-code ##cprc-prc3 (body) frame))
  1360.       (else (mk-code ##cprc-prc  (body) (##fixnum.+ (##length frame) 1) frame)))))
  1361.  
  1362. (define ##cprc-prc-rest
  1363.   (mk-cprc
  1364.     (letrec ((proc
  1365.                (lambda args
  1366.                  (let ((n (^ 1)))
  1367.                    (let ((inner-rte (mk-rte* rte n)))
  1368.                      (rte-set! inner-rte 1 proc)
  1369.                      (let loop ((i 2) (l args))
  1370.                        (if (##fixnum.< i n)
  1371.                          (if (##pair? l)
  1372.                            (begin
  1373.                              (rte-set! inner-rte i (##car l))
  1374.                              (loop (##fixnum.+ i 1) (##cdr l)))
  1375.                            (rt-error-too-few-args proc args))
  1376.                          (begin
  1377.                            (rte-set! inner-rte i l)
  1378.                            (let ((rte inner-rte))
  1379.                              (code-run (^ 0)))))))))))
  1380.       proc)))
  1381.  
  1382. (define ##gen-prc-rest
  1383.   (mk-gen (frame body)
  1384.     (mk-code ##cprc-prc-rest (body) (##fixnum.+ (##length frame) 1) frame)))
  1385.  
  1386. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1387.  
  1388. (define ##cprc-app0-red
  1389.   (mk-cprc
  1390.     (let ((proc (code-run (^ 0))))
  1391.       (touch-vars (proc)
  1392.         (if (##not (##procedure? proc))
  1393.           (rt-error-non-procedure-oper $code rte)
  1394.           (##reduction-apply0 $code rte proc))))))
  1395.  
  1396. (define ##cprc-app1-red
  1397.   (mk-cprc
  1398.     (let ((proc (code-run (^ 0))))
  1399.       (touch-vars (proc)
  1400.         (if (##not (##procedure? proc))
  1401.           (rt-error-non-procedure-oper $code rte)
  1402.           (let ((arg1 (code-run (^ 1))))
  1403.             (##reduction-apply1 $code rte proc arg1)))))))
  1404.  
  1405. (define ##cprc-app2-red
  1406.   (mk-cprc
  1407.     (let ((proc (code-run (^ 0))))
  1408.       (touch-vars (proc)
  1409.         (if (##not (##procedure? proc))
  1410.           (rt-error-non-procedure-oper $code rte)
  1411.           (let ((arg1 (code-run (^ 1)))
  1412.                 (arg2 (code-run (^ 2))))
  1413.             (##reduction-apply2 $code rte proc arg1 arg2)))))))
  1414.  
  1415. (define ##cprc-app3-red
  1416.   (mk-cprc
  1417.     (let ((proc (code-run (^ 0))))
  1418.       (touch-vars (proc)
  1419.         (if (##not (##procedure? proc))
  1420.           (rt-error-non-procedure-oper $code rte)
  1421.           (let ((arg1 (code-run (^ 1)))
  1422.                 (arg2 (code-run (^ 2)))
  1423.                 (arg3 (code-run (^ 3))))
  1424.             (##reduction-apply3 $code rte proc arg1 arg2 arg3)))))))
  1425.  
  1426. (define ##cprc-app-red
  1427.   (mk-cprc
  1428.     (let ((proc (code-run (^ 0))))
  1429.       (touch-vars (proc)
  1430.         (if (##not (##procedure? proc))
  1431.           (rt-error-non-procedure-oper $code rte)
  1432.           (let loop ((i (##fixnum.- (code-length $code) 1)) (args '()))
  1433.             (if (##fixnum.< 0 i)
  1434.               (loop (##fixnum.- i 1) (##cons (code-run (code-ref $code i)) args))
  1435.               (##reduction-apply $code rte proc args))))))))
  1436.  
  1437. (define ##cprc-app0-sub
  1438.   (mk-cprc
  1439.     (let ((proc (code-run (^ 0))))
  1440.       (touch-vars (proc)
  1441.         (if (##not (##procedure? proc))
  1442.           (rt-error-non-procedure-oper $code rte)
  1443.           (##subproblem-apply0 $code rte proc))))))
  1444.  
  1445. (define ##cprc-app1-sub
  1446.   (mk-cprc
  1447.     (let ((proc (code-run (^ 0))))
  1448.       (touch-vars (proc)
  1449.         (if (##not (##procedure? proc))
  1450.           (rt-error-non-procedure-oper $code rte)
  1451.           (let ((arg1 (code-run (^ 1))))
  1452.             (##subproblem-apply1 $code rte proc arg1)))))))
  1453.  
  1454. (define ##cprc-app2-sub
  1455.   (mk-cprc
  1456.     (let ((proc (code-run (^ 0))))
  1457.       (touch-vars (proc)
  1458.         (if (##not (##procedure? proc))
  1459.           (rt-error-non-procedure-oper $code rte)
  1460.           (let ((arg1 (code-run (^ 1)))
  1461.                 (arg2 (code-run (^ 2))))
  1462.             (##subproblem-apply2 $code rte proc arg1 arg2)))))))
  1463.  
  1464. (define ##cprc-app3-sub
  1465.   (mk-cprc
  1466.     (let ((proc (code-run (^ 0))))
  1467.       (touch-vars (proc)
  1468.         (if (##not (##procedure? proc))
  1469.           (rt-error-non-procedure-oper $code rte)
  1470.           (let ((arg1 (code-run (^ 1)))
  1471.                 (arg2 (code-run (^ 2)))
  1472.                 (arg3 (code-run (^ 3))))
  1473.             (##subproblem-apply3 $code rte proc arg1 arg2 arg3)))))))
  1474.  
  1475. (define ##cprc-app-sub
  1476.   (mk-cprc
  1477.     (let ((proc (code-run (^ 0))))
  1478.       (touch-vars (proc)
  1479.         (if (##not (##procedure? proc))
  1480.           (rt-error-non-procedure-oper $code rte)
  1481.           (let loop ((i (##fixnum.- (code-length $code) 1)) (args '()))
  1482.             (if (##fixnum.< 0 i)
  1483.               (loop (##fixnum.- i 1) (##cons (code-run (code-ref $code i)) args))
  1484.               (##subproblem-apply $code rte proc args))))))))
  1485.  
  1486. (define ##gen-app
  1487.   (mk-gen (oper args)
  1488.     (case (##length args)
  1489.       ((0)  (mk-code    (if tail? ##cprc-app0-red ##cprc-app0-sub) (oper)))
  1490.       ((1)  (mk-code    (if tail? ##cprc-app1-red ##cprc-app1-sub) (oper (##car args))))
  1491.       ((2)  (mk-code    (if tail? ##cprc-app2-red ##cprc-app2-sub) (oper (##car args) (##cadr args))))
  1492.       ((3)  (mk-code    (if tail? ##cprc-app3-red ##cprc-app3-sub) (oper (##car args) (##cadr args) (##caddr args))))
  1493.       (else (##mk-code* (if tail? ##cprc-app-red  ##cprc-app-sub)  (##cons oper args) 0)))))
  1494.  
  1495. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1496.  
  1497. (define (##reduction-apply0 $code rte proc)
  1498.   (##declare (intr-checks))
  1499.   (proc))
  1500.  
  1501. (define (##reduction-apply1 $code rte proc arg1)
  1502.   (##declare (intr-checks))
  1503.   (proc arg1))
  1504.  
  1505. (define (##reduction-apply2 $code rte proc arg1 arg2)
  1506.   (##declare (intr-checks))
  1507.   (proc arg1 arg2))
  1508.  
  1509. (define (##reduction-apply3 $code rte proc arg1 arg2 arg3)
  1510.   (##declare (intr-checks))
  1511.   (proc arg1 arg2 arg3))
  1512.  
  1513. (define (##reduction-apply $code rte proc args)
  1514.   (##declare (intr-checks))
  1515.   (##apply proc args))
  1516.  
  1517. (define (##subproblem-apply0 $code rte proc)
  1518.   (##declare (intr-checks))
  1519.   (let ((result (proc)))
  1520.     (let ((a $code) (b rte))
  1521.       result)))
  1522.  
  1523. (define (##subproblem-apply1 $code rte proc arg1)
  1524.   (##declare (intr-checks))
  1525.   (let ((result (proc arg1)))
  1526.     (let ((a $code) (b rte))
  1527.       result)))
  1528.  
  1529. (define (##subproblem-apply2 $code rte proc arg1 arg2)
  1530.   (##declare (intr-checks))
  1531.   (let ((result (proc arg1 arg2)))
  1532.     (let ((a $code) (b rte))
  1533.       result)))
  1534.  
  1535. (define (##subproblem-apply3 $code rte proc arg1 arg2 arg3)
  1536.   (##declare (intr-checks))
  1537.   (let ((result (proc arg1 arg2 arg3)))
  1538.     (let ((a $code) (b rte))
  1539.       result)))
  1540.  
  1541. (define (##subproblem-apply $code rte proc args)
  1542.   (##declare (intr-checks))
  1543.   (let ((result (##apply proc args)))
  1544.     (let ((a $code) (b rte))
  1545.       result)))
  1546.  
  1547. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1548.  
  1549. (define ##cprc-delay
  1550.   (mk-cprc
  1551.     (delay (code-run (^ 0)))))
  1552.  
  1553. (define ##gen-delay
  1554.   (mk-gen (val)
  1555.     (mk-code ##cprc-delay (val))))
  1556.  
  1557. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1558.  
  1559. (define ##cprc-future
  1560.   (mk-cprc
  1561.     (future (code-run (^ 0)))))
  1562.  
  1563. (define ##gen-future
  1564.   (mk-gen (val)
  1565.     (mk-code ##cprc-future (val))))
  1566.  
  1567. ;------------------------------------------------------------------------------
  1568.  
  1569. ; Access to compiler created structures for interpreter procedures and frames
  1570.  
  1571. (define ##int-proc-body-format-1
  1572.   (##list (##proc-closure-body (##cprc-prc0 #f #f))
  1573.           (##proc-closure-body (##cprc-prc1 #f #f))
  1574.           (##proc-closure-body (##cprc-prc2 #f #f))
  1575.           (##proc-closure-body (##cprc-prc3 #f #f))))
  1576.  
  1577. (define ##int-proc-body-format-2
  1578.   (##list (##proc-closure-body (##cprc-prc       #f #f))
  1579.           (##proc-closure-body (##cprc-prc-rest  #f #f))))
  1580.  
  1581. (define (##int-proc? x)
  1582.   (and (##procedure? x)
  1583.        (##proc-closure? x)
  1584.        (or (##memq (##proc-closure-body x) ##int-proc-body-format-1)
  1585.            (##memq (##proc-closure-body x) ##int-proc-body-format-2))))
  1586.  
  1587. (define (##int-proc-code x)
  1588.   (if (##memq (##proc-closure-body x) ##int-proc-body-format-1)
  1589.     (##proc-closure-ref x 0)
  1590.     (##proc-closure-ref x 2)))
  1591.  
  1592. (define (##int-proc-rte x)
  1593.   (if (##memq (##proc-closure-body x) ##int-proc-body-format-1)
  1594.     (##proc-closure-ref x 2)
  1595.     (##proc-closure-ref x 1)))
  1596.  
  1597. ;==============================================================================
  1598.  
  1599. ; Eval
  1600.  
  1601. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1602.  
  1603. ; Evaluation in the global environment (with current dynamic env)
  1604.  
  1605. (define ##eval-global #f)
  1606. (set! ##eval-global
  1607.   (lambda (expr)
  1608.     (##eval expr #f #f (##dynamic-env-ref))))
  1609.  
  1610. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1611.  
  1612. ; Evaluation in a particular environment ('frames' describes the runtime
  1613. ; environment 'rte').
  1614.  
  1615. (define ##eval #f)
  1616. (set! ##eval
  1617.   (lambda (expr frames rte dyn-env)
  1618.     (let ((c (##compile expr frames)))
  1619.       (##dynamic-env-bind
  1620.         dyn-env
  1621.         (lambda () (let ((rte rte)) (code-run c)))))))
  1622.  
  1623. ;==============================================================================
  1624.  
  1625. ; Decompilation of a piece of code
  1626.  
  1627. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1628.  
  1629. (##define-macro (mk-degen params . def)
  1630.   `(lambda ($code ,@params) ,@def))
  1631.  
  1632. (##define-macro (degen proc . args)
  1633.   `(,proc $code ,@args))
  1634.  
  1635. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1636.  
  1637. (define (##extract-frame subcode up)
  1638.   (let (($code (code-link subcode)))
  1639.     (if $code
  1640.       (let ((cprc (code-cprc $code)))
  1641.         (cond ((##eq? cprc ##cprc-top)
  1642.                (##extract-frame-top $code subcode up))
  1643.               ((##eq? cprc ##cprc-glo-def)
  1644.                (##extract-frame-glo-def $code subcode up))
  1645.               ((##eq? cprc ##cprc-case)
  1646.                (##extract-frame-case $code subcode up))
  1647.               ((##eq? cprc ##cprc-let)
  1648.                (##extract-frame-let $code subcode up))
  1649.               ((##eq? cprc ##cprc-letrec)
  1650.                (##extract-frame-letrec $code subcode up))
  1651.               ((or (##eq? cprc ##cprc-prc0)
  1652.                    (##eq? cprc ##cprc-prc1)
  1653.                    (##eq? cprc ##cprc-prc2)
  1654.                    (##eq? cprc ##cprc-prc3)
  1655.                    (##eq? cprc ##cprc-prc)
  1656.                    (##eq? cprc ##cprc-prc-rest))
  1657.                (##extract-frame-prc $code subcode up))
  1658.               (else
  1659.                (##extract-frame-default $code subcode up))))
  1660.       #f)))
  1661.  
  1662. (define ##extract-frame-default
  1663.   (lambda ($code subcode up)
  1664.     (##extract-frame $code up)))
  1665.  
  1666. (define ##extract-frame-top
  1667.   (lambda ($code subcode up)
  1668.     (if (##fixnum.= up 0)
  1669.       (##list (self-var))
  1670.       (let loop ((frames (^ 1)) (up (##fixnum.- up 1)))
  1671.         (if frames
  1672.           (if (##fixnum.= up 0)
  1673.             (##car frames)
  1674.             (loop (##cdr frames) (##fixnum.- up 1)))
  1675.           #f)))))
  1676.  
  1677. (define ##extract-frame-glo-def
  1678.   (lambda ($code subcode up)
  1679.     #f))
  1680.  
  1681. (define ##extract-frame-case
  1682.   (lambda ($code subcode up)
  1683.     (if (##eq? subcode (^ 1))
  1684.       (if (##fixnum.= up 0)
  1685.         (##list (selector-var))
  1686.         (##extract-frame $code (##fixnum.- up 1)))
  1687.       (##extract-frame $code up))))
  1688.  
  1689. (define ##extract-frame-let
  1690.   (lambda ($code subcode up)
  1691.     (if (##eq? subcode (^ 0))
  1692.       (if (##fixnum.= up 0)
  1693.         (code-ref $code (##fixnum.- (code-length $code) 1))
  1694.         (##extract-frame $code (##fixnum.- up 1)))
  1695.       (##extract-frame $code up))))
  1696.  
  1697. (define ##extract-frame-letrec
  1698.   (lambda ($code subcode up)
  1699.     (if (##fixnum.= up 0)
  1700.       (code-ref $code (##fixnum.- (code-length $code) 1))
  1701.       (##extract-frame $code (##fixnum.- up 1)))))
  1702.  
  1703. (define ##extract-frame-prc
  1704.   (lambda ($code subcode up)
  1705.     (if (##fixnum.= up 0)
  1706.       (##cons (self-var) (code-ref $code (##fixnum.- (code-length $code) 1)))
  1707.       (##extract-frame $code (##fixnum.- up 1)))))
  1708.  
  1709. (define (##extract-frames $code)
  1710.  
  1711.   (define (rev l tail)
  1712.     (if (##pair? l) (rev (##cdr l) (##cons (##car l) tail)) tail))
  1713.  
  1714.   (let loop ((i 0) (frames '()))
  1715.     (let ((frame (##extract-frame $code i)))
  1716.       (if frame
  1717.         (loop (##fixnum.+ i 1) (##cons frame frames))
  1718.         (rev frames #f)))))
  1719.  
  1720. (define (##extract-proc $code rte)
  1721.   (let loop ((i 0) (rte rte))
  1722.     (let ((frame (##extract-frame $code i)))
  1723.       (if frame
  1724.         (if (and (##pair? frame) (##eq? (##car frame) (self-var)))
  1725.           (rte-ref rte 1)
  1726.           (loop (##fixnum.+ i 1) (rte-up rte)))
  1727.         #f))))
  1728.  
  1729. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1730.  
  1731. (define (##BEGIN? x) (and (##pair? x) (##eq? (##car x) 'BEGIN)))
  1732. (define (##COND? x)  (and (##pair? x) (##eq? (##car x) 'COND)))
  1733. (define (##AND? x)   (and (##pair? x) (##eq? (##car x) 'AND)))
  1734. (define (##OR? x)    (and (##pair? x) (##eq? (##car x) 'OR)))
  1735. (define (##unspecified-obj? x)
  1736.   (and (##pair? x) (##eq? (##car x) 'QUOTE) (##eq? (##cadr x) (unspecified-obj))))
  1737.  
  1738. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1739.  
  1740. (define ##degen-top
  1741.   (mk-degen ()
  1742.     (##decomp (^ 0))))
  1743.  
  1744. (define ##degen-cst-x
  1745.   (mk-degen (val)
  1746.     (if (##self-eval? val) val (##list 'QUOTE val))))
  1747.  
  1748. (define ##degen-cst
  1749.   (mk-degen ()
  1750.     (degen ##degen-cst-x (^ 0))))
  1751.  
  1752. (define ##degen-loc-ref-x-y
  1753.   (mk-degen (up over)
  1754.     (degen ##degen-up-over up over)))
  1755.  
  1756. (define ##degen-up-over
  1757.   (mk-degen (up over)
  1758.     (let loop ((l (##extract-frame $code up)) (i over))
  1759.       (if (##fixnum.< i 2)
  1760.         (##car l)
  1761.         (loop (##cdr l) (##fixnum.- i 1))))))
  1762.  
  1763. (define ##degen-loc-ref
  1764.   (mk-degen ()
  1765.     (degen ##degen-loc-ref-x-y (^ 0) (^ 1))))
  1766.  
  1767. (define ##degen-glo-ref
  1768.   (mk-degen ()
  1769.     (global-env-loc->var (^ 0))))
  1770.  
  1771. (define ##degen-loc-set
  1772.   (mk-degen ()
  1773.     (##list 'SET! (degen ##degen-up-over (^ 1) (^ 2))
  1774.                   (##decomp (^ 0)))))
  1775.  
  1776. (define ##degen-glo-set
  1777.   (mk-degen ()
  1778.     (##list 'SET! (global-env-loc->var (^ 1))
  1779.                   (##decomp (^ 0)))))
  1780.  
  1781. (define ##degen-glo-def
  1782.   (mk-degen ()
  1783.     (##list 'DEFINE (global-env-loc->var (^ 1))
  1784.                     (##decomp (^ 0)))))
  1785.  
  1786. (define ##degen-if2
  1787.   (mk-degen ()
  1788.     (##list 'IF (##decomp (^ 0))
  1789.                 (##decomp (^ 1)))))
  1790.  
  1791. (define ##degen-if3
  1792.   (mk-degen ()
  1793.     (##list 'IF (##decomp (^ 0))
  1794.                 (##decomp (^ 1))
  1795.                 (##decomp (^ 2)))))
  1796.  
  1797. (define ##degen-seq
  1798.   (mk-degen ()
  1799.     (let ((val1 (##decomp (^ 0)))
  1800.           (val2 (##decomp (^ 1))))
  1801.       (if (##BEGIN? val2)
  1802.         (##cons 'BEGIN (##cons val1 (##cdr val2)))
  1803.         (##list 'BEGIN val1 val2)))))
  1804.  
  1805. (define ##degen-quasi-list->vector
  1806.   (mk-degen ()
  1807.     (##list 'QUASIQUOTE (##make-vector 1 (##list 'UNQUOTE-SPLICING (##decomp (^ 0)))))))
  1808.  
  1809. (define ##degen-quasi-append
  1810.   (mk-degen ()
  1811.     (##list 'QUASIQUOTE (##list (##list 'UNQUOTE-SPLICING (##decomp (^ 0)))
  1812.                                 (##list 'UNQUOTE-SPLICING (##decomp (^ 1)))))))
  1813.  
  1814. (define ##degen-quasi-cons
  1815.   (mk-degen ()
  1816.     (##list 'QUASIQUOTE (##list (##list 'UNQUOTE (##decomp (^ 0)))
  1817.                                 (##list 'UNQUOTE-SPLICING (##decomp (^ 1)))))))
  1818.  
  1819. (define ##degen-cond-if
  1820.   (mk-degen ()
  1821.     (let ((val1 (##decomp (^ 0)))
  1822.           (val2 (##decomp (^ 1)))
  1823.           (val3 (##decomp (^ 2))))
  1824.       (##build-cond
  1825.         (if (##BEGIN? val2) (##cons val1 (##cdr val2)) (##list val1 val2))
  1826.         val3))))
  1827.  
  1828. (define ##degen-cond-or
  1829.   (mk-degen ()
  1830.     (let ((val1 (##decomp (^ 0)))
  1831.           (val2 (##decomp (^ 1))))
  1832.       (##build-cond (##list val1) val2))))
  1833.  
  1834. (define ##degen-cond-send
  1835.   (mk-degen ()
  1836.     (let ((val1 (##decomp (^ 0)))
  1837.           (val2 (##decomp (^ 1)))
  1838.           (val3 (##decomp (^ 2))))
  1839.       (##build-cond (##list val1 '=> val2) val3))))
  1840.  
  1841. (define (##build-cond clause rest)
  1842.   (cond ((##COND? rest)
  1843.          (##cons 'COND (##cons clause (##cdr rest))))
  1844.         ((##BEGIN? rest)
  1845.          (##cons 'COND (##list clause (##cons 'ELSE (##cdr rest)))))
  1846.         ((##unspecified-obj? rest)
  1847.          (##list 'COND clause))
  1848.         (else
  1849.          (##list 'COND clause (##list 'ELSE rest)))))
  1850.  
  1851. (define ##degen-or
  1852.   (mk-degen ()
  1853.     (let ((val1 (##decomp (^ 0)))
  1854.           (val2 (##decomp (^ 1))))
  1855.       (if (##OR? val2)
  1856.         (##cons 'OR (##cons val1 (##cdr val2)))
  1857.         (##list 'OR val1 val2)))))
  1858.  
  1859. (define ##degen-and
  1860.   (mk-degen ()
  1861.     (let ((val1 (##decomp (^ 0)))
  1862.           (val2 (##decomp (^ 1))))
  1863.       (if (##AND? val2)
  1864.         (##cons 'AND (##cons val1 (##cdr val2)))
  1865.         (##list 'AND val1 val2)))))
  1866.  
  1867. (define ##degen-case
  1868.   (mk-degen ()
  1869.     (let ((val1 (##decomp (^ 0)))
  1870.           (val2 (##decomp (^ 1))))
  1871.       (##cons 'CASE (##cons val1 val2)))))
  1872.  
  1873. (define ##degen-case-clause
  1874.   (mk-degen ()
  1875.     (let ((val1 (##decomp (^ 0)))
  1876.           (val2 (##decomp (^ 1))))
  1877.       (##cons (if (##BEGIN? val1)
  1878.                 (##cons (^ 2) (##cdr val1))
  1879.                 (##list (^ 2) val1))
  1880.               val2))))
  1881.  
  1882. (define ##degen-case-else
  1883.   (mk-degen ()
  1884.     (let ((val (##decomp (^ 0))))
  1885.       (if (##unspecified-obj? val)
  1886.         '()
  1887.         (##list (if (##BEGIN? val)
  1888.                   (##cons 'ELSE (##cdr val))
  1889.                   (##list 'ELSE val)))))))
  1890.  
  1891. (define ##degen-let
  1892.   (mk-degen ()
  1893.     (let ((n (code-length $code)))
  1894.       (let loop ((i (##fixnum.- n 2)) (vals '()))
  1895.         (if (##fixnum.< 0 i)
  1896.           (loop (##fixnum.- i 1)
  1897.                 (##cons (##decomp (code-ref $code i)) vals))
  1898.           (let ((body (##decomp (^ 0)))
  1899.                 (bindings (##make-bindings (code-ref $code (##fixnum.- n 1)) vals)))
  1900.             (if (##BEGIN? body)
  1901.               (##cons 'LET (##cons bindings (##cdr body)))
  1902.               (##list 'LET bindings body))))))))
  1903.  
  1904. (define (##make-bindings l1 l2)
  1905.   (if (##pair? l1)
  1906.     (##cons (##list (##car l1) (##car l2))
  1907.             (##make-bindings (##cdr l1) (##cdr l2)))
  1908.     '()))
  1909.  
  1910. (define ##degen-letrec
  1911.   (mk-degen ()
  1912.     (let ((n (code-length $code)))
  1913.       (let loop ((i (##fixnum.- n 2)) (vals '()))
  1914.         (if (##fixnum.< 0 i)
  1915.           (loop (##fixnum.- i 1)
  1916.                 (##cons (##decomp (code-ref $code i)) vals))
  1917.           (let ((body (##decomp (^ 0)))
  1918.                 (bindings (##make-bindings (code-ref $code (##fixnum.- n 1)) vals)))
  1919.             (if (##BEGIN? body)
  1920.               (##cons 'LETREC (##cons bindings (##cdr body)))
  1921.               (##list 'LETREC bindings body))))))))
  1922.  
  1923. (define ##degen-prc
  1924.   (mk-degen ()
  1925.     (let ((body (##decomp (^ 0)))
  1926.           (params (code-ref $code (##fixnum.- (code-length $code) 1))))
  1927.       (if (##BEGIN? body)
  1928.         (##cons 'LAMBDA (##cons params (##cdr body)))
  1929.         (##list 'LAMBDA params body)))))
  1930.  
  1931. (define ##degen-prc-rest
  1932.   (mk-degen ()
  1933.     (let ((body (##decomp (^ 0)))
  1934.           (params (##make-rest-params (^ 2))))
  1935.       (if (##BEGIN? body)
  1936.         (##cons 'LAMBDA (##cons params (##cdr body)))
  1937.         (##list 'LAMBDA params body)))))
  1938.  
  1939. (define (##make-rest-params l)
  1940.   (if (##null? (##cdr l))
  1941.     (##car l)
  1942.     (##cons (##car l) (##make-rest-params (##cdr l)))))
  1943.  
  1944. (define ##degen-app0
  1945.   (mk-degen ()
  1946.     (##list (##decomp (^ 0)))))
  1947.  
  1948. (define ##degen-app1
  1949.   (mk-degen ()
  1950.     (##list (##decomp (^ 0))
  1951.             (##decomp (^ 1)))))
  1952.  
  1953. (define ##degen-app2
  1954.   (mk-degen ()
  1955.     (##list (##decomp (^ 0))
  1956.             (##decomp (^ 1))
  1957.             (##decomp (^ 2)))))
  1958.  
  1959. (define ##degen-app3
  1960.   (mk-degen ()
  1961.     (##list (##decomp (^ 0))
  1962.             (##decomp (^ 1))
  1963.             (##decomp (^ 2))
  1964.             (##decomp (^ 3)))))
  1965.  
  1966. (define ##degen-app
  1967.   (mk-degen ()
  1968.     (let ((n (code-length $code)))
  1969.       (let loop ((i (##fixnum.- n 1)) (vals '()))
  1970.         (if (##not (##fixnum.< i 0))
  1971.           (loop (##fixnum.- i 1)
  1972.                 (##cons (##decomp (code-ref $code i)) vals))
  1973.           vals)))))
  1974.  
  1975. (define ##degen-delay
  1976.   (mk-degen ()
  1977.     (##list 'DELAY (##decomp (^ 0)))))
  1978.  
  1979. (define ##degen-future
  1980.   (mk-degen ()
  1981.     (##list 'FUTURE (##decomp (^ 0)))))
  1982.  
  1983. ;------------------------------------------------------------------------------
  1984.  
  1985. (define ##decomp-dispatch-table
  1986.   (##list
  1987.     (##cons ##cprc-top           ##degen-top)
  1988.  
  1989.     (##cons ##cprc-cst-null      (mk-degen () (degen ##degen-cst-x '())))
  1990.     (##cons ##cprc-cst-true      (mk-degen () (degen ##degen-cst-x #t)))
  1991.     (##cons ##cprc-cst-false     (mk-degen () (degen ##degen-cst-x #f)))
  1992.     (##cons ##cprc-cst--2        (mk-degen () (degen ##degen-cst-x -2)))
  1993.     (##cons ##cprc-cst--1        (mk-degen () (degen ##degen-cst-x -1)))
  1994.     (##cons ##cprc-cst-0         (mk-degen () (degen ##degen-cst-x 0)))
  1995.     (##cons ##cprc-cst-1         (mk-degen () (degen ##degen-cst-x 1)))
  1996.     (##cons ##cprc-cst-2         (mk-degen () (degen ##degen-cst-x 2)))
  1997.     (##cons ##cprc-cst           ##degen-cst)
  1998.  
  1999.     (##cons ##cprc-loc-ref-0-1   (mk-degen () (degen ##degen-loc-ref-x-y 0 1)))
  2000.     (##cons ##cprc-loc-ref-0-2   (mk-degen () (degen ##degen-loc-ref-x-y 0 2)))
  2001.     (##cons ##cprc-loc-ref-0-3   (mk-degen () (degen ##degen-loc-ref-x-y 0 3)))
  2002.     (##cons ##cprc-loc-ref-1-1   (mk-degen () (degen ##degen-loc-ref-x-y 1 1)))
  2003.     (##cons ##cprc-loc-ref-1-2   (mk-degen () (degen ##degen-loc-ref-x-y 1 2)))
  2004.     (##cons ##cprc-loc-ref-1-3   (mk-degen () (degen ##degen-loc-ref-x-y 1 3)))
  2005.     (##cons ##cprc-loc-ref-2-1   (mk-degen () (degen ##degen-loc-ref-x-y 2 1)))
  2006.     (##cons ##cprc-loc-ref-2-2   (mk-degen () (degen ##degen-loc-ref-x-y 2 2)))
  2007.     (##cons ##cprc-loc-ref-2-3   (mk-degen () (degen ##degen-loc-ref-x-y 2 3)))
  2008.     (##cons ##cprc-loc-ref       ##degen-loc-ref)
  2009.     (##cons ##cprc-glo-ref       ##degen-glo-ref)
  2010.  
  2011.     (##cons ##cprc-loc-set       ##degen-loc-set)
  2012.     (##cons ##cprc-glo-set       ##degen-glo-set)
  2013.     (##cons ##cprc-glo-def       ##degen-glo-def)
  2014.  
  2015.     (##cons ##cprc-if2           ##degen-if2)
  2016.     (##cons ##cprc-if3           ##degen-if3)
  2017.     (##cons ##cprc-seq           ##degen-seq)
  2018.     (##cons ##cprc-quasi-list->vector ##degen-quasi-list->vector)
  2019.     (##cons ##cprc-quasi-append  ##degen-quasi-append)
  2020.     (##cons ##cprc-quasi-cons    ##degen-quasi-cons)
  2021.     (##cons ##cprc-cond-if       ##degen-cond-if)
  2022.     (##cons ##cprc-cond-or       ##degen-cond-or)
  2023.     (##cons ##cprc-cond-send-red ##degen-cond-send)
  2024.     (##cons ##cprc-cond-send-sub ##degen-cond-send)
  2025.  
  2026.     (##cons ##cprc-or            ##degen-or)
  2027.     (##cons ##cprc-and           ##degen-and)
  2028.  
  2029.     (##cons ##cprc-case          ##degen-case)
  2030.     (##cons ##cprc-case-clause   ##degen-case-clause)
  2031.     (##cons ##cprc-case-else     ##degen-case-else)
  2032.  
  2033.     (##cons ##cprc-let           ##degen-let)
  2034.     (##cons ##cprc-letrec        ##degen-letrec)
  2035.  
  2036.     (##cons ##cprc-prc0          ##degen-prc)
  2037.     (##cons ##cprc-prc1          ##degen-prc)
  2038.     (##cons ##cprc-prc2          ##degen-prc)
  2039.     (##cons ##cprc-prc3          ##degen-prc)
  2040.     (##cons ##cprc-prc           ##degen-prc)
  2041.     (##cons ##cprc-prc-rest      ##degen-prc-rest)
  2042.  
  2043.     (##cons ##cprc-app0-red      ##degen-app0)
  2044.     (##cons ##cprc-app1-red      ##degen-app1)
  2045.     (##cons ##cprc-app2-red      ##degen-app2)
  2046.     (##cons ##cprc-app3-red      ##degen-app3)
  2047.     (##cons ##cprc-app-red       ##degen-app)
  2048.     (##cons ##cprc-app0-sub      ##degen-app0)
  2049.     (##cons ##cprc-app1-sub      ##degen-app1)
  2050.     (##cons ##cprc-app2-sub      ##degen-app2)
  2051.     (##cons ##cprc-app3-sub      ##degen-app3)
  2052.     (##cons ##cprc-app-sub       ##degen-app)
  2053.  
  2054.     (##cons ##cprc-delay         ##degen-delay)
  2055.     (##cons ##cprc-future        ##degen-future)
  2056. ))
  2057.  
  2058. ;------------------------------------------------------------------------------
  2059.  
  2060. (define (##decomp $code)
  2061.   (let ((cprc (code-cprc $code)))
  2062.     (let ((x (##assq cprc ##decomp-dispatch-table)))
  2063.       (if x
  2064.         (degen (##cdr x))
  2065.         '?))))
  2066.  
  2067. (define (##decompile proc)
  2068.  
  2069.   (define (decomp1 p)
  2070.     (if (##proc-subproc? p)
  2071.       (decomp2 (##proc-subproc-parent p) (##proc-subproc-tag p))
  2072.       (decomp2 p 0)))
  2073.  
  2074.   (define (decomp2 parent tag)
  2075.     (let ((info (##proc-debug-info parent)))
  2076.       (if info
  2077.         (let ((v (##vector-ref info 0)))
  2078.           (let loop ((i (##fixnum.- (##vector-length v) 1)))
  2079.             (if (##fixnum.< i 0)
  2080.               proc
  2081.               (let ((x (##vector-ref v i)))
  2082.                 (if (##fixnum.= tag (##vector-ref x 0))
  2083.                   (source->expression (##vector-ref x 1))
  2084.                   (loop (##fixnum.- i 1)))))))
  2085.         proc)))
  2086.  
  2087.   (define (source-code x)
  2088.     (##vector-ref x 0))
  2089.  
  2090.   (define (source->expression source)
  2091.  
  2092.     (define (list->expression l)
  2093.       (cond ((##pair? l)
  2094.              (##cons (source->expression (##car l))
  2095.                      (list->expression (##cdr l))))
  2096.             ((##null? l)
  2097.              '())
  2098.             (else
  2099.              (source->expression l))))
  2100.  
  2101.     (define (vector->expression v)
  2102.       (let* ((len (##vector-length v))
  2103.              (x (##make-vector len #f)))
  2104.         (let loop ((i (##fixnum.- len 1)))
  2105.           (if (##not (##fixnum.< i 0))
  2106.             (begin
  2107.               (##vector-set! x i (source->expression (##vector-ref v i)))
  2108.               (loop (##fixnum.- i 1)))))
  2109.         x))
  2110.  
  2111.     (let ((code (source-code source)))
  2112.       (cond ((##pair? code)   (list->expression code))
  2113.             ((##vector? code) (vector->expression code))
  2114.             (else             code))))
  2115.  
  2116.   (cond ((##int-proc? proc)
  2117.          (##decomp (##int-proc-code proc)))
  2118.         ((##proc-closure? proc)
  2119.          (decomp1 (##proc-closure-body proc)))
  2120.         (else
  2121.          (decomp1 proc))))
  2122.  
  2123. ;==============================================================================
  2124.  
  2125. ; Debugger
  2126.  
  2127. ;------------------------------------------------------------------------------
  2128.  
  2129. ; Access to interpreter continuation frames
  2130.  
  2131. (define (##int-frame-non-subproblem? f)
  2132.   (let ((parent (##proc-subproc-parent (##frame-ret f))))
  2133.     (##assq parent ##decomp-dispatch-table)))
  2134.  
  2135. (define (##int-frame-subproblem? f)
  2136.   (let ((parent (##proc-subproc-parent (##frame-ret f))))
  2137.     (or (##eq? parent ##subproblem-apply0)
  2138.         (##eq? parent ##subproblem-apply1)
  2139.         (##eq? parent ##subproblem-apply2)
  2140.         (##eq? parent ##subproblem-apply3)
  2141.         (##eq? parent ##subproblem-apply))))
  2142.  
  2143. (define (##int-frame-subproblem-code f)
  2144.   (let ((parent (##proc-subproc-parent (##frame-ret f))))
  2145.     (if (##eq? parent ##subproblem-apply0)
  2146.       (##frame-stk-ref f 2)
  2147.       (##frame-stk-ref f 1))))
  2148.  
  2149. (define (##int-frame-subproblem-rte f)
  2150.   (let ((parent (##proc-subproc-parent (##frame-ret f))))
  2151.     (if (or (##eq? parent ##subproblem-apply2)
  2152.             (##eq? parent ##subproblem-apply3))
  2153.       (##frame-stk-ref f 2)
  2154.       (##frame-stk-ref f 3))))
  2155.  
  2156. ;------------------------------------------------------------------------------
  2157.  
  2158. ; Utilities
  2159.  
  2160. (define (##continuation->subproblems cont)
  2161.   (let loop ((f (##continuation->frame cont)) (l '()))
  2162.     (if f
  2163.       (if (##int-frame-non-subproblem? f)
  2164.         (loop (##frame-next f) l)
  2165.         (loop (##frame-next f) (##cons f l)))
  2166.       (##reverse l))))
  2167.  
  2168. (define (##eval-within expr f dyn-bindings)
  2169.   (let ((dyn-env (##cons dyn-bindings (##frame-dyn-env f))))
  2170.     (if (##int-frame-subproblem? f)
  2171.       (##eval expr
  2172.               (##extract-frames (##int-frame-subproblem-code f))
  2173.               (##int-frame-subproblem-rte f)
  2174.               dyn-env)
  2175.       (##eval expr #f #f dyn-env))))
  2176.  
  2177. (define (##procedure-name p)
  2178.   (or (##object->global-var-name p) p))
  2179.  
  2180. ;------------------------------------------------------------------------------
  2181.  
  2182. ; Read eval print loop
  2183.  
  2184. (define (##repl (in ##stdin) (out ##stdout) (prompt2 ": ") (prompt1 ""))
  2185.   (##call-with-current-continuation
  2186.     (lambda (cont) (##read-eval-print in out prompt2 prompt1 cont))))
  2187.  
  2188. (define ##repl-write #f)
  2189. (set! ##repl-write #f)
  2190.  
  2191. (define ##repl-read #f)
  2192. (set! ##repl-read #f)
  2193.  
  2194. (define (##read-eval-print in out prompt2 prompt1 cont)
  2195.  
  2196.   (define (repl-start subprobs repl-info dyn-bindings)
  2197.  
  2198.     (define (repl-read)
  2199.       (let ((proc ##repl-read))
  2200.         (if (##procedure? proc)
  2201.           (proc in)
  2202.           (##read in))))
  2203.  
  2204.     (define (repl-write val)
  2205.       (let ((proc ##repl-write))
  2206.         (if (##procedure? proc)
  2207.           (proc val out)
  2208.           (begin
  2209.             (##write val out (if-touches #t #f))
  2210.             (##newline out)))))
  2211.  
  2212.     (define (repl-n n)
  2213.       (let loop ((i 0) (s subprobs))
  2214.         (if (and (##fixnum.< n i) (##pair? (##cdr s)))
  2215.           (loop (##fixnum.- i 1) (##cdr s))
  2216.           (let ((f (##car s)))
  2217.             (##display-subproblem i f out)
  2218.             (repl i s f)))))
  2219.  
  2220.     (define (cmd-d)
  2221.       (let ((l (##cdr (##vector-ref repl-info 3))))
  2222.         (if (##pair? l)
  2223.           ((##car l) #f)
  2224.           (begin
  2225.             (##newline out)
  2226.             (##write-string "*** ^D again to exit" out)
  2227.             (##newline out)
  2228.             (if (##eof-object? (##peek-char in))
  2229.               (##quit))))))
  2230.  
  2231.     (define (cmd-t)
  2232.       (let loop ((l (##vector-ref repl-info 3)))
  2233.         (if (##pair? (##cdr l))
  2234.           (loop (##cdr l))
  2235.           ((##car l) #f))))
  2236.  
  2237.     (define (repl pos subprobs* f)
  2238.  
  2239.       (##call-with-current-continuation
  2240.         (lambda (abort)
  2241.           (##set-car! (##vector-ref repl-info 3) abort)))
  2242.  
  2243.       (let loop ()
  2244.  
  2245.         (##newline out)
  2246.         (##display prompt1 out #f)
  2247.         (if (##fixnum.< pos 0) (##display pos out #f))
  2248.         (##display prompt2 out #f)
  2249.  
  2250.         (let ((expr (repl-read)))
  2251.           (if (##eof-object? expr)
  2252.             (begin (cmd-d) (loop))
  2253.             (if (and (##pair? expr)
  2254.                      (##pair? (##cdr expr))
  2255.                      (##null? (##cddr expr))
  2256.                      (##eq? (##car expr) 'UNQUOTE))
  2257.               (let ((cmd (##cadr expr)))
  2258.                 (if (##eof-object? cmd)
  2259.                   (begin (cmd-d) (loop))
  2260.                   (case cmd
  2261.                     ((?) (##cmd-? out) (loop))
  2262.                     ((-) (repl-n (##fixnum.- pos 1)))
  2263.                     ((+) (repl-n (##fixnum.+ pos 1)))
  2264.                     ((b) (##cmd-b pos subprobs* out) (loop))
  2265.                     ((i) (##cmd-i f out) (loop))
  2266.                     ((y) (##cmd-y f out) (loop))
  2267.                     ((l) (##cmd-l f out) (loop))
  2268.                     ((t) (cmd-t))
  2269.                     ((d) (cmd-d) (loop))
  2270.                     ((r) (##display "Return value: " out #f)
  2271.                          (let ((expr (repl-read)))
  2272.                            (if (##eof-object? expr)
  2273.                              ##undef-object
  2274.                              (##eval-within expr f dyn-bindings))))
  2275.                     ((q) (##quit))
  2276.                     (else
  2277.                      (if (and (##fixnum? cmd) (##fixnum.< cmd 1))
  2278.                        (repl-n cmd)
  2279.                        (begin
  2280.                          (##write-string "Unknown command ," out)
  2281.                          (##write cmd out #f)
  2282.                          (##newline out)
  2283.                          (loop)))))))
  2284.             (let ((val (##eval-within expr f dyn-bindings)))
  2285.               (repl-write val)
  2286.               (loop)))))))
  2287.  
  2288.     (repl 0 subprobs (##car subprobs)))
  2289.  
  2290.   (let ((repl-info (##make-vector 4 #f)))
  2291.     (let ((prev-info (##dynamic-ref '##REPL-INFO #f))
  2292.           (dyn-bindings (##list (##cons '##REPL-INFO repl-info))))
  2293.       (##vector-set! repl-info 0 in)
  2294.       (##vector-set! repl-info 1 out)
  2295.       (##vector-set! repl-info 2
  2296.         (if prev-info
  2297.           (##fixnum.+ (##vector-ref prev-info 2) 1)
  2298.           0))
  2299.       (##vector-set! repl-info 3
  2300.         (##cons (lambda (x) (##quit))
  2301.                 (if prev-info
  2302.                   (##vector-ref prev-info 3)
  2303.                   '())))
  2304.       (##dynamic-bind
  2305.         dyn-bindings
  2306.         (lambda ()
  2307.           (repl-start (##continuation->subproblems cont)
  2308.                       repl-info
  2309.                       dyn-bindings))))))
  2310.  
  2311. (define (##repl-out)
  2312.   (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
  2313.     (if repl-info
  2314.       (##vector-ref repl-info 1)
  2315.       ##stdout)))
  2316.  
  2317. (define (##debug-repl cont)
  2318.   (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
  2319.     (if repl-info
  2320.       (##read-eval-print (##vector-ref repl-info 0)
  2321.                          (##vector-ref repl-info 1)
  2322.                          ": "
  2323.                          (##fixnum.+ (##vector-ref repl-info 2) 1)
  2324.                          cont)
  2325.       (##read-eval-print ##stdin ##stdout ": " 0 cont))))
  2326.  
  2327. (define (##pop-repl)
  2328.   (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
  2329.     (if repl-info
  2330.       ((##car (##vector-ref repl-info 3)) #f)
  2331.       (##quit))))
  2332.  
  2333. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2334.  
  2335. (define (##cmd-? out)
  2336.   (##write-string ",?        : Summary of commands" out) (##newline out)
  2337.   (##write-string ",+ and ,- : Move to next or previous frame of continuation" out) (##newline out)
  2338.   (##write-string ",<n>      : Move to particular frame (<n> <= 0)" out) (##newline out)
  2339.   (##write-string ",b        : Display frames of continuation (i.e. backtrace)" out) (##newline out)
  2340.   (##write-string ",i        : Display procedure attached to current frame" out) (##newline out)
  2341.   (##write-string ",y        : Display subproblem of current frame" out) (##newline out)
  2342.   (##write-string ",l        : Display list of local variables accessible in current frame" out) (##newline out)
  2343.   (##write-string ",t        : Transfer to top-level REP loop" out) (##newline out)
  2344.   (##write-string ",d        : Transfer to previous REP loop" out) (##newline out)
  2345.   (##write-string ",r        : Return from REP loop" out) (##newline out)
  2346.   (##write-string ",q        : Quit" out) (##newline out))
  2347.  
  2348. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2349.  
  2350. (define (##cmd-b pos subprobs* out)
  2351.   (define max-head 10)
  2352.   (define max-tail 6)
  2353.   (let loop ((i 0) (j (##fixnum.- (##length subprobs*) 1)) (l subprobs*))
  2354.     (if (##pair? l)
  2355.       (begin
  2356.         (cond ((or (##fixnum.< i max-head) (##fixnum.< j max-tail)
  2357.                    (and (##fixnum.= i max-head) (##fixnum.= j max-tail)))
  2358.                (##display-subproblem (##fixnum.- pos i) (##car l) out))
  2359.               ((##fixnum.= i max-head)
  2360.                (##write-string "..." out) (##newline out)))
  2361.         (loop (##fixnum.+ i 1) (##fixnum.- j 1) (##cdr l))))))
  2362.  
  2363. (define (##display-subproblem pos f out)
  2364.   (let ((x (##write pos out #f)))
  2365.     (##display-spaces (##fixnum.- 4 x) out)
  2366.     (##write-string " " out)
  2367.  
  2368.     (if (##int-frame-subproblem? f)
  2369.  
  2370.       (let ((code (##int-frame-subproblem-code f))
  2371.             (rte (##int-frame-subproblem-rte f)))
  2372.         (let ((proc (##extract-proc code rte)))
  2373.           (let ((x (if proc
  2374.                      (##write (##procedure-name proc) out #f)
  2375.                      (##display "(top level)" out #f))))
  2376.             (##display-spaces (##fixnum.- 25 x) out)
  2377.             (##write-string " " out)
  2378.             (##write-string (##object->string (##decomp code) 48 #f) out)
  2379.             (##newline out))))
  2380.  
  2381.       (let ((parent (##proc-subproc-parent (##frame-ret f))))
  2382.         (let ((x (##write (##procedure-name parent) out #f)))
  2383.           (let ((y (##decompile (##frame-ret f))))
  2384.             (if (##not (##eq? y (##frame-ret f)))
  2385.               (begin
  2386.                 (##display-spaces (##fixnum.- 25 x) out)
  2387.                 (##write-string " " out)
  2388.                 (##write-string (##object->string y 48 #f) out)))
  2389.             (##newline out)))))))
  2390.  
  2391. (define (##display-spaces n out)
  2392.   (if (##fixnum.< 0 n)
  2393.     (let ((m (if (##fixnum.< 40 n) 40 n)))
  2394.       (##write-substring "                                        " 0 m out)
  2395.       (##display-spaces (##fixnum.- n m) out))))
  2396.  
  2397. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2398.  
  2399. (define (##cmd-l f out)
  2400.  
  2401.   (define (display-locals frames rte)
  2402.     (let loop1 ((l frames) (r rte))
  2403.       (if (##pair? l)
  2404.         (let loop2 ((frame (##car l)) (values (##cdr (##vector->list r))))
  2405.           (if (##pair? frame)
  2406.             (let ((var (##car frame)))
  2407.               (if (##not (or (##eq? var (self-var))
  2408.                              (##eq? var (selector-var))
  2409.                              (##eq? var (do-loop-var))))
  2410.                 (let ((x (##write var out #f)))
  2411.                   (##write-string " = " out)
  2412.                   (##write-string (##object->string
  2413.                                     (##car values)
  2414.                                     (##fixnum.- (##fixnum.- (##port-width out) 3) x)
  2415.                                     (if-touches #t #f))
  2416.                                   out)
  2417.                   (##newline out)))
  2418.               (loop2 (##cdr frame) (##cdr values)))
  2419.             (loop1 (##cdr l) (rte-up r)))))))
  2420.  
  2421.   (if (##int-frame-subproblem? f)
  2422.     (display-locals (##extract-frames (##int-frame-subproblem-code f))
  2423.                     (##int-frame-subproblem-rte f))
  2424.     (begin
  2425.       (##write-string "Sorry, can't display compiled code environment" out)
  2426.       (##newline out))))
  2427.  
  2428. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2429.  
  2430. (define (##cmd-y f out)
  2431.   (if (##int-frame-subproblem? f)
  2432.     (##pretty-print (##decomp (##int-frame-subproblem-code f)) out (##port-width out))
  2433.     (let ((x (##decompile (##frame-ret f))))
  2434.       (if (##eq? x (##frame-ret f))
  2435.         (begin
  2436.           (##write-string "Sorry, this code was compiled without the DEBUG option" out)
  2437.           (##newline out))
  2438.         (##pretty-print x out (##port-width out))))))
  2439.  
  2440. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2441.  
  2442. (define (##cmd-i f out)
  2443.   (if (##int-frame-subproblem? f)
  2444.  
  2445.     (let ((code (##int-frame-subproblem-code f))
  2446.           (rte (##int-frame-subproblem-rte f)))
  2447.       (let ((proc (##extract-proc code rte)))
  2448.         (if proc
  2449.           (begin
  2450.             (##write proc out #f)
  2451.             (##write-string " =" out)
  2452.             (##newline out)
  2453.             (##pretty-print (##decompile proc) out (##port-width out)))
  2454.           (begin
  2455.             (##write-string "(top level)" out)
  2456.             (##newline out)))))
  2457.  
  2458.     (let ((proc (##proc-subproc-parent (##frame-ret f))))
  2459.       (##write proc out #f)
  2460.       (let ((x (##decompile proc)))
  2461.         (if (##eq? x proc)
  2462.           (##newline out)
  2463.           (begin
  2464.             (##write-string " =" out)
  2465.             (##newline out)
  2466.             (##pretty-print x out (##port-width out))))))))
  2467.  
  2468. ;==============================================================================
  2469.