home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / ABE&SUS5.ZIP / A&S_5.LSP
Encoding:
Text File  |  1987-04-06  |  38.6 KB  |  1,404 lines
  1.  
  2. ;;; Section 5.1 -- Programs we implement as register machines
  3.  
  4. ;;; GCD from section 1.2.5
  5.  
  6. (define (gcd a b)
  7.   (if (= b 0) 
  8.       a
  9.       (gcd b (remainder a b))))
  10.  
  11. ;;; Exercise 5.1 -- FACTORIAL from section 1.2.1 (block-structured)
  12.  
  13. (define (factorial n)
  14.   (define (iter product counter)
  15.     (if (> counter n)
  16.         product
  17.         (iter (* counter product)
  18.               (+ counter 1))))
  19.   (iter 1 1))
  20.  
  21. ;;; Section 5.1.1
  22.  
  23. ;;; GCD machine definition
  24.  
  25. (define-machine gcd
  26.   (registers a b t)
  27.   (controller
  28.    test-b
  29.      (branch (zero? (fetch b)) gcd-done)
  30.      (assign t (remainder (fetch a) (fetch b)))
  31.      (assign a (fetch b))
  32.      (assign b (fetch t))
  33.      (goto test-b)
  34.    gcd-done))
  35.  
  36. ;;; GCD machine with I/O (Figure 5.4)
  37.  
  38. (define-machine gcd
  39.   (registers a b t)
  40.   (controller
  41.    gcd-loop
  42.      (assign a (read))
  43.      (assign b (read))
  44.    test-b
  45.      (branch (zero? (fetch b)) gcd-done)
  46.      (assign t (remainder (fetch a) (fetch b)))
  47.      (assign a (fetch b))
  48.      (assign b (fetch t))
  49.      (goto test-b)
  50.    gcd-done
  51.      (perform (print (fetch a)))
  52.      (goto gcd-loop)))
  53.  
  54. ;;; Section 5.1.2
  55.  
  56. (define (remainder n d)
  57.   (if (< n d)
  58.       n
  59.       (remainder (- n d) d)))
  60.  
  61. ;;; GCD machine with nonprimitive REMAINDER computation
  62.  
  63. (define-machine gcd
  64.   (registers a b t)
  65.   (controller
  66.    test-b
  67.      (branch (zero? (fetch b)) gcd-done)
  68.      (assign t (fetch a))
  69.    rem-loop
  70.      (branch (< (fetch t) (fetch b)) rem-done)
  71.      (assign t (- (fetch t) (fetch b)))
  72.      (goto rem-loop)
  73.    rem-done
  74.      (assign a (fetch b))
  75.      (assign b (fetch t))
  76.      (goto test-b)
  77.    gcd-done))
  78.  
  79. ;;; Section 5.1.4 -- Recursion
  80.  
  81. ;;; FACTORIAL same as in section 1.2.1 but with args reversed
  82.  
  83. (define (factorial n)
  84.   (if (= n 1)
  85.       1
  86.       (* (factorial (- n 1)) n)))
  87.  
  88. ;;; FACTORIAL machine (Figure 5.10)
  89.  
  90. (define-machine factorial
  91.   (registers n val continue)
  92.   (controller
  93.      (assign continue fact-done)     ;set up final return address
  94.    fact-loop
  95.      (branch (=1? (fetch n)) base-case)
  96.      (save continue)
  97.      (save n)
  98.      (assign n (-1+ (fetch n)))
  99.      (assign continue after-fact)
  100.      (goto fact-loop)
  101.    after-fact
  102.      (restore n)
  103.      (restore continue)
  104.      (assign val
  105.              (* (fetch n) (fetch val)))
  106.      (goto (fetch continue))
  107.    base-case
  108.      (assign val (fetch n))
  109.      (goto (fetch continue))
  110.    fact-done))
  111.  
  112. ;;; FIB as in 1.2.2 but with base case written differently
  113.  
  114. (define (fib n)
  115.   (if (< n 2)
  116.       n
  117.       (+ (fib (- n 1)) (fib (- n 2)))))
  118.  
  119. ;;; FIB machine (Figure 5.11)
  120.  
  121. (define-machine fib
  122.   (registers n val continue)
  123.   (controller
  124.      (assign continue fib-done)
  125.    fib-loop
  126.      (branch (< (fetch n) 2) immediate-answer)
  127.      (save continue)
  128.      (assign continue afterfib-n-1)
  129.      (save n)
  130.      (assign n (- (fetch n) 1))
  131.      (goto fib-loop)
  132.    afterfib-n-1
  133.      (restore n)
  134.      (restore continue)
  135.      (assign n (- (fetch n) 2))
  136.      (save continue)
  137.      (assign continue afterfib-n-2)
  138.      (save val)
  139.      (goto fib-loop)
  140.    afterfib-n-2
  141.      (assign n (fetch val))
  142.      (restore val)
  143.      (restore continue)
  144.      (assign val
  145.              (+ (fetch val)(fetch n)))
  146.      (goto (fetch continue))
  147.    immediate-answer
  148.      (assign val (fetch n))
  149.      (goto (fetch continue))
  150.    fib-done))
  151.  
  152. ;;; Exercise 5.4
  153.  
  154. ;;; Recursive EXPT from section 1.2.4
  155.  
  156. (define (expt b n)
  157.   (if (= n 0)
  158.       1
  159.       (* b (expt b (- n 1)))))
  160.  
  161. ;;; Iterative EXPT from section 1.2.4 but block-structured
  162.  
  163. (define (expt b n)
  164.   (define (exp-iter counter product)
  165.     (if (= counter 0)
  166.         product
  167.         (exp-iter (- counter 1) (* b product))))
  168.   (exp-iter n 1))
  169.  
  170. ;;; COUNTATOMS from section 2.2.2
  171.  
  172. (define (countatoms tree)
  173.   (cond ((null? tree) 0)
  174.         ((atom? tree) 1)
  175.         (else (+ (countatoms (car tree))
  176.                  (countatoms (cdr tree))))))
  177.  
  178. ;;; A version of COUNTATOMS not shown earlier
  179.  
  180. (define (countatoms tree)
  181.   (define (count-iter tree n)
  182.     (cond ((null? tree) n)
  183.           ((atom? tree) (1+ n))
  184.           (else (count-iter (cdr tree)
  185.                             (count-iter (car tree) n)))))
  186.   (count-iter tree 0))
  187.  
  188. ;;; Section 5.1.5 -- Register-machine simulator
  189.  
  190. ;;; Expansion of first GCD machine definition above
  191.  
  192. (define gcd
  193.   (build-model '(a b t)
  194.                '(test-b
  195.                  (branch (zero? (fetch b)) gcd-done)
  196.                  (assign t (remainder (fetch a) (fetch b)))
  197.                  (assign a (fetch b))
  198.                  (assign b (fetch t))
  199.                  (goto test-b)
  200.                  gcd-done)))
  201.  
  202. ;;; Start of Register-machine simulator
  203.  
  204. ;;; Constructing the machine model
  205.  
  206. (define (build-model registers controller)
  207.   (let ((machine (make-new-machine)))
  208.     (set-up-registers machine registers)
  209.     (set-up-controller machine controller)
  210.     machine))
  211.  
  212. (define (set-up-registers machine registers)
  213.   (mapc (lambda (register-name)
  214.           (make-machine-register machine register-name))
  215.         registers))
  216.  
  217. (define (mapc proc l)
  218.   (if (null? l)
  219.       'done
  220.       (sequence (proc (car l))
  221.                 (mapc proc (cdr l)))))
  222.  
  223. (define (set-up-controller machine controller)
  224.   (build-instruction-list machine
  225.                           (cons '*start* controller)))
  226.  
  227. (define (build-instruction-list machine op-list)
  228.   (if (null? op-list)
  229.       '()
  230.       (let ((rest-of-instructions
  231.              (build-instruction-list machine (cdr op-list))))
  232.         (if (label? (car op-list))
  233.             (sequence
  234.              (declare-label machine
  235.                             (car op-list)
  236.                             rest-of-instructions)
  237.              rest-of-instructions)
  238.             (cons (make-machine-instruction machine
  239.                                             (car op-list))
  240.                   rest-of-instructions)))))
  241.  
  242. (define (label? expression)
  243.   (symbol? expression))
  244.  
  245. ;;; Registers
  246.  
  247. (define (make-machine-register machine name)
  248.   (remote-define machine name (make-register name)))
  249.  
  250. (define (make-register name)
  251.   (define contents nil)
  252.   (define (get) contents)
  253.   (define (set value)
  254.     (set! contents value))
  255.   (define (dispatch message)
  256.     (cond ((eq? message 'get) (get))
  257.           ((eq? message 'set) set)
  258.           (else (error "Unknown request -- REGISTER"
  259.                        name
  260.                        message))))
  261.   dispatch)
  262.  
  263. (define (get-contents register)
  264.   (register 'get))
  265.  
  266. (define (set-contents register value)
  267.   ((register 'set) value))
  268.  
  269. ;;; Labels
  270.  
  271. (define (declare-label machine label labeled-entry)
  272.   (let ((defined-labels (remote-get machine '*labels*)))
  273.     (if (memq label defined-labels)
  274.         (error "Multiply-defined label" label)
  275.         (sequence
  276.          (remote-define machine label labeled-entry)
  277.          (remote-set machine
  278.                      '*labels*
  279.                      (cons label defined-labels))))))
  280.  
  281. ;;; The Stack
  282.  
  283. (define (make-stack)
  284.   (define s '())
  285.   (define (push x)
  286.     (set! s (cons x s)))
  287.   (define (pop)
  288.     (if (null? s)
  289.         (error "Empty stack -- POP")
  290.         (let ((top (car s)))
  291.           (set! s (cdr s))
  292.           top)))
  293.   (define (initialize)
  294.     (set! s '()))
  295.   (define (dispatch message)
  296.     (cond ((eq? message 'push) push)
  297.           ((eq? message 'pop) (pop))
  298.           ((eq? message 'initialize) (initialize))
  299.           (else (error "Unknown request -- STACK" message))))
  300.   dispatch)
  301.  
  302. (define (pop stack)
  303.   (stack 'pop))
  304.  
  305. (define (push stack value)
  306.   ((stack 'push) value))
  307.  
  308. ;;; Representation of machines as environments
  309.  
  310. (define (remote-get machine variable)
  311.   (eval variable machine))
  312.  
  313. (define (remote-set machine variable value)
  314.   (eval (list 'set! variable (list 'quote value))
  315.         machine))
  316.  
  317. (define (remote-define machine variable value)
  318.   (eval (list 'define variable (list 'quote value))
  319.         machine))
  320.  
  321. ;;; Instructions as procedures
  322.  
  323. (define (make-machine-instruction machine exp)
  324.   (eval (list 'lambda '() exp) machine))
  325.  
  326. ;;; Creating an initial machine (environment)
  327.  
  328. (define (make-new-machine)
  329.   (make-environment
  330.  
  331. (define *labels* '())
  332.  
  333. (define *the-stack* (make-stack))
  334.  
  335. (define (initialize-stack)
  336.   (*the-stack* 'initialize))
  337.  
  338. (define fetch get-contents)
  339.  
  340. (define *program-counter* '())
  341.  
  342. (define (execute sequence)
  343.   (set! *program-counter* sequence)
  344.   (if (null? *program-counter*)
  345.       'done
  346.       ((car *program-counter*))))
  347.  
  348. (define (normal-next-instruction)
  349.   (execute (cdr *program-counter*)))
  350.  
  351. (define (assign register value)
  352.   (set-contents register value)
  353.   (normal-next-instruction))
  354.  
  355. (define (save reg)
  356.   (push *the-stack* (get-contents reg))
  357.   (normal-next-instruction))
  358.  
  359. (define (restore reg)
  360.   (set-contents reg (pop *the-stack*))
  361.   (normal-next-instruction))
  362.  
  363. (define (goto new-sequence)
  364.   (execute new-sequence))
  365.  
  366. (define (branch predicate alternate-next)
  367.   (if predicate
  368.       (goto alternate-next)
  369.       (normal-next-instruction)))
  370.  
  371. (define (perform operation)
  372.   (normal-next-instruction))
  373.  
  374. )) ;;end of MAKE-NEW-MACHINE
  375.  
  376. ;;; External interface to a simulated machine
  377.  
  378. (define (remote-fetch machine register-name)
  379.   (get-contents (remote-get machine register-name)))
  380.  
  381. (define (remote-assign machine register-name value)
  382.   (set-contents (remote-get machine register-name) value)
  383.   'done)
  384.  
  385. (define (start machine)
  386.   (eval '(goto *start*) machine))
  387.  
  388. ;;; The monitored stack
  389. ;;; (MAKE-STACK and INITIALIZE-STACK can be substituted for the versions above)
  390.  
  391. (define (make-stack)
  392.   (define s '())
  393.   (define number-pushes 0)
  394.   (define max-depth 0)
  395.   (define (push x)
  396.     (set! s (cons x s))
  397.     (set! number-pushes (1+ number-pushes))
  398.     (set! max-depth (max (length s) max-depth)))
  399.   (define (pop)
  400.     (if (null? s)
  401.         (error "Empty stack -- POP")
  402.         (let ((top (car s)))
  403.           (set! s (cdr s))
  404.           top)))
  405.   (define (initialize)
  406.     (set! s '())
  407.     (set! number-pushes 0)
  408.     (set! max-depth 0))
  409.   (define (print-statistics)
  410.     (print (list 'total-pushes: number-pushes
  411.                  'maximum-depth: max-depth)))
  412.   (define (dispatch message)
  413.     (cond ((eq? message 'push) push)
  414.           ((eq? message 'pop) (pop))
  415.           ((eq? message 'initialize) (initialize))
  416.           ((eq? message 'print-statistics) 
  417.            (print-statistics))
  418.           (else (error "Unknown request -- STACK" message))))
  419.   dispatch)
  420.  
  421. (define (initialize-stack)
  422.   (*the-stack* 'print-statistics)
  423.   (*the-stack* 'initialize))
  424.  
  425. ;;; Section 5.2
  426.  
  427. eval-dispatch
  428.   (branch (self-evaluating? (fetch exp)) ev-self-eval)
  429.   (branch (quoted? (fetch exp)) ev-quote)
  430.   (branch (variable? (fetch exp)) ev-variable)
  431.   (branch (definition? (fetch exp)) ev-definition)
  432.   (branch (assignment? (fetch exp)) ev-assignment)
  433.   (branch (lambda? (fetch exp)) ev-lambda)
  434.   (branch (conditional? (fetch exp)) ev-cond)
  435.   (branch (no-args? (fetch exp)) ev-no-args)
  436.   (branch (application? (fetch exp)) ev-application)
  437.   (goto unknown-expression-type-error)
  438.  
  439. (define (no-args? exp)
  440.   (if (atom? exp)
  441.       nil
  442.       (null? (cdr exp))))
  443.  
  444. (define (application? exp)
  445.   (if (atom? exp)
  446.       nil
  447.       (not (null? (cdr exp)))))
  448.  
  449.  
  450. ev-self-eval
  451.   (assign val (fetch exp))
  452.   (goto (fetch continue))
  453. ev-quote
  454.   (assign val (text-of-quotation (fetch exp)))
  455.   (goto (fetch continue))
  456. ev-variable
  457.   (assign val
  458.           (lookup-variable-value (fetch exp) (fetch env)))
  459.   (goto (fetch continue))
  460. ev-lambda
  461.   (assign val (make-procedure (fetch exp) (fetch env)))
  462.   (goto (fetch continue))
  463.  
  464. ev-no-args
  465.   (assign exp (operator (fetch exp)))
  466.   (save continue)
  467.   (assign continue setup-no-arg-apply)
  468.   (goto eval-dispatch)
  469.  
  470. setup-no-arg-apply
  471.   (assign fun (fetch val))
  472.   (assign argl '())
  473.   (goto apply-dispatch)
  474.  
  475. ev-application
  476.   (assign unev (operands (fetch exp)))
  477.   (assign exp (operator (fetch exp)))
  478.   (save continue)
  479.   (save env)
  480.   (save unev)
  481.   (assign continue eval-args)
  482.   (goto eval-dispatch)
  483.  
  484. eval-args
  485.   (restore unev)
  486.   (restore env)
  487.   (assign fun (fetch val))
  488.   (save fun)
  489.   (assign argl '())
  490.   (goto eval-arg-loop)
  491.  
  492. (define (last-operand? args)
  493.   (null? (cdr args)))
  494.  
  495. eval-arg-loop
  496.   (save argl)
  497.   (assign exp (first-operand (fetch unev)))
  498.   (branch (last-operand? (fetch unev)) eval-last-arg)
  499.   (save env)
  500.   (save unev)
  501.   (assign continue accumulate-arg)
  502.   (goto eval-dispatch)
  503.  
  504. accumulate-arg
  505.   (restore unev)
  506.   (restore env)
  507.   (restore argl)
  508.   (assign argl (cons (fetch val) (fetch argl)))
  509.   (assign unev (rest-operands (fetch unev)))
  510.   (goto eval-arg-loop)
  511.  
  512. eval-last-arg
  513.   (assign continue accumulate-last-arg)
  514.   (goto eval-dispatch)
  515. accumulate-last-arg
  516.   (restore argl)
  517.   (assign argl (cons (fetch val) (fetch argl)))
  518.   (restore fun)
  519.   (goto apply-dispatch)
  520.  
  521. apply-dispatch
  522.   (branch (primitive-procedure? (fetch fun)) primitive-apply)
  523.   (branch (compound-procedure? (fetch fun)) compound-apply)
  524.   (goto unknown-procedure-type-error)
  525.  
  526. (define (apply-primitive-procedure p args)
  527.   (apply (eval (primitive-id p) user-initial-environment)
  528.          (reverse args)))
  529.  
  530. primitive-apply
  531.   (assign val
  532.           (apply-primitive-procedure (fetch fun)
  533.                                      (fetch argl)))
  534.   (restore continue)
  535.   (goto (fetch continue))
  536.  
  537. compound-apply
  538.   (assign env (make-bindings (fetch fun) (fetch argl)))
  539.   (assign unev (procedure-body (fetch fun)))
  540.   (goto eval-sequence)
  541.  
  542. (define (make-bindings proc args)
  543.   (extend-binding-environment (parameters proc)
  544.                               args
  545.                               (procedure-environment proc)))
  546.  
  547. (define (extend-binding-environment vars args env)
  548.   (extend-environment vars (reverse args) env))
  549.  
  550. (define no-more-exps? null?)
  551.  
  552. eval-sequence
  553.   (assign exp (first-exp (fetch unev)))
  554.   (branch (last-exp? (fetch unev)) last-exp)
  555.   (save unev)
  556.   (save env)
  557.   (assign continue eval-sequence-continue)
  558.   (goto eval-dispatch)
  559. eval-sequence-continue
  560.   (restore env)
  561.   (restore unev)
  562.   (assign unev (rest-exps (fetch unev)))
  563.   (goto eval-sequence)
  564. last-exp
  565.   (restore continue)
  566.   (goto eval-dispatch)
  567.  
  568. ;;; Non-tail-recursive version of EVAL-SEQUENCE
  569. eval-sequence
  570.   (branch (no-more-exps? (fetch unev)) end-sequence)  ;***
  571.   (assign exp (first-exp (fetch unev)))               ;***
  572.   (save unev)
  573.   (save env)
  574.   (assign continue eval-sequence-continue)
  575.   (goto eval-dispatch)
  576. eval-sequence-continue
  577.   (restore env)
  578.   (restore unev)
  579.   (assign unev (rest-exps (fetch unev)))
  580.   (goto eval-sequence)
  581. end-sequence
  582.   (restore continue)
  583.   (goto (fetch continue))                             ;***
  584.  
  585. (define (count n)
  586.   (print n)
  587.   (count (1+ n)))
  588.  
  589. ev-cond
  590.   (save continue)
  591.   (assign continue evcond-decide)
  592.   (assign unev (clauses (fetch exp)))
  593. evcond-pred
  594.   (branch (no-clauses? (fetch unev)) evcond-return-nil)
  595.   (assign exp (first-clause (fetch unev)))
  596.   (branch (else-clause? (fetch exp)) evcond-else-clause)
  597.   (save env)
  598.   (save unev)
  599.   (assign exp (predicate (fetch exp)))
  600.   (goto eval-dispatch)
  601. evcond-return-nil
  602.   (restore continue)
  603.   (assign val nil)
  604.   (goto (fetch continue))
  605.  
  606. evcond-decide
  607.   (restore unev)
  608.   (restore env)
  609.   (branch (true? (fetch val)) evcond-true-predicate)
  610.   (assign unev (rest-clauses (fetch unev)))
  611.   (goto evcond-pred)
  612.  
  613. evcond-true-predicate
  614.   (assign exp (first-clause (fetch unev)))
  615. evcond-else-clause
  616.   (assign unev (actions (fetch exp)))
  617.   (goto eval-sequence)
  618.  
  619. ev-assignment
  620.   (assign unev (assignment-variable (fetch exp)))
  621.   (save unev)
  622.   (assign exp (assignment-value (fetch exp)))
  623.   (save env)
  624.   (save continue)
  625.   (assign continue ev-assignment-1)
  626.   (goto eval-dispatch)
  627. ev-assignment-1
  628.   (restore continue)
  629.   (restore env)
  630.   (restore unev)
  631.   (perform (set-variable-value! (fetch unev) 
  632.                                 (fetch val) 
  633.                                 (fetch env)))
  634.   (goto (fetch continue))
  635.  
  636. ev-definition
  637.   (assign unev (definition-variable (fetch exp)))
  638.   (save unev)
  639.   (assign exp (definition-value (fetch exp)))
  640.   (save env)
  641.   (save continue)
  642.   (assign continue ev-definition-1)
  643.   (goto eval-dispatch)
  644. ev-definition-1
  645.   (restore continue)
  646.   (restore env)
  647.   (restore unev)
  648.   (perform
  649.    (define-variable! (fetch unev) (fetch val) (fetch env)))
  650.   (assign val (fetch unev))     ;return as value
  651.                                 ;the symbol being defined
  652.   (goto (fetch continue))
  653.  
  654. ;;; Controller starts here
  655. read-eval-print-loop
  656.   (perform (initialize-stack))
  657.   (perform (newline))
  658.   (perform (princ "EC-EVAL==> "))
  659.   (assign exp (read))
  660.   (assign env the-global-environment)
  661.   (assign continue print-result)
  662.   (goto eval-dispatch)
  663. print-result
  664.   (perform (user-print (fetch val)))
  665.   (goto read-eval-print-loop)
  666.  
  667. unknown-procedure-type-error
  668.   (assign val 'unknown-procedure-type-error)
  669.   (goto signal-error)
  670.  
  671. unknown-expression-type-error
  672.   (assign val 'unknown-expression-type-error)
  673.   (goto signal-error)
  674. signal-error
  675.   (perform (user-print (fetch val)))
  676.   (goto read-eval-print-loop)
  677.  
  678. (define the-global-environment (setup-environment))
  679.  
  680. (define-machine explicit-control-evaluator
  681.   (registers exp env val continue fun argl unev)
  682.   (controller
  683.     ;;body of the controller as given in this section
  684.    ))
  685.  
  686. (start explicit-control-evaluator)
  687.  
  688. ;;; Exercise 5.20
  689.  
  690. (define (factorial n)
  691.   (define (iter product counter)
  692.     (cond ((> counter n) product)
  693.           (else (iter (* counter product)
  694.                       (+ counter 1)))))
  695.   (iter 1 1))
  696.  
  697. ;;; Exercise 5.21
  698. (define (factorial n)
  699.   (cond ((= n 1) 1)
  700.         (else (* (factorial (- n 1)) n))))
  701.  
  702. ;;; Exercise 5.22
  703. (define (fib n)
  704.   (cond ((= n 0) 0)
  705.         ((= n 1) 1)
  706.         (else (+ (fib (- n 1)) (fib (- n 2))))))
  707.  
  708. ;;; Section 5.2.5 -- Lexical addressing
  709.  
  710. ;;; from exercise 5.27
  711. (let ((a 1))
  712.   (define (f x)
  713.     (define b (+ a x))
  714.     (define a 5)
  715.     (+ a b))
  716.   (f 10))
  717.  
  718. ;;; Section 5.3 -- Compilation
  719.  
  720. ;;; Section 5.3.1
  721.  
  722. (define (compile-expression exp c-t-env target cont)
  723.   (cond ((self-evaluating? exp)
  724.          (compile-constant exp c-t-env target cont))
  725.         ((quoted? exp)
  726.          (compile-constant (text-of-quotation exp)
  727.                            c-t-env target cont))
  728.         ((variable? exp)
  729.          (compile-variable-access exp c-t-env target cont))
  730.         ((assignment? exp)
  731.          (compile-assignment exp c-t-env target cont))
  732.         ((definition? exp)
  733.          (compile-definition exp c-t-env target cont))
  734.         ((lambda? exp)
  735.          (compile-lambda exp c-t-env target cont))
  736.         ((conditional? exp)
  737.          (compile-cond (clauses exp) c-t-env target cont))
  738.         ((no-args? exp)
  739.          (compile-no-args exp c-t-env target cont))
  740.         ((application? exp)
  741.          (compile-application exp c-t-env target cont))
  742.         (else
  743.          (error "Unknown expression type -- COMPILE" exp))))
  744.  
  745. (define (preserving reg seq1 seq2)
  746.   (if (and (needs-register seq2 reg)
  747.            (modifies-register seq1 reg))
  748.       (append-instruction-sequences
  749.        (wrap-save-restore seq1 reg)
  750.        seq2)
  751.       (append-instruction-sequences seq1 seq2)))
  752.  
  753. ;;; Section 5.3.2
  754.  
  755. (define (compile-continuation continuation)
  756.   (cond ((eq? continuation 'return) (compile-return))
  757.         ((eq? continuation 'next)
  758.          (empty-instruction-sequence))
  759.         (else (make-jump continuation))))
  760.  
  761. ;;; Simple expressions
  762.  
  763. (define (compile-constant constant c-t-env target cont)
  764.   (append-instruction-sequences
  765.    (make-register-assignment target (make-constant constant))
  766.    (compile-continuation cont)))
  767.  
  768. (define (compile-variable-access var c-t-env target cont)
  769.   (append-instruction-sequences
  770.    (make-register-assignment target
  771.                              (make-variable-access var
  772.                                                    c-t-env))
  773.    (compile-continuation cont)))
  774.  
  775. ;;; Procedure applications
  776.  
  777. (define (compile-application app c-t-env target cont)
  778.   (preserving
  779.    'env
  780.    (compile-expression (operator app) c-t-env 'fun 'next)
  781.    (preserving 'fun
  782.                (compile-operands (operands app) c-t-env)
  783.                (compile-call target cont))))
  784.  
  785. (define (compile-operands rands c-t-env)
  786.   (let ((first-operand-code
  787.          (compile-first-operand rands c-t-env)))
  788.     (if (last-operand? rands)
  789.         first-operand-code
  790.         (preserving
  791.          'env
  792.          first-operand-code
  793.          (compile-rest-operands (rest-operands rands)
  794.                                 c-t-env)))))
  795.  
  796. (define (compile-first-operand rands c-t-env)
  797.   (append-instruction-sequences
  798.    (compile-expression (first-operand rands)
  799.                        c-t-env 'val 'next)
  800.    (make-register-assignment
  801.     'argl
  802.     (make-singleton-arglist (make-fetch 'val)))))
  803.  
  804. (define (compile-rest-operands rands c-t-env)
  805.   (let ((next-operand-code
  806.          (compile-next-operand rands c-t-env)))
  807.     (if (last-operand? rands)
  808.         next-operand-code
  809.         (preserving
  810.          'env
  811.          next-operand-code
  812.          (compile-rest-operands (rest-operands rands)
  813.                                 c-t-env)))))
  814.  
  815. (define (compile-next-operand rands c-t-env)
  816.   (preserving 
  817.    'argl
  818.    (compile-expression (first-operand rands)
  819.                        c-t-env 'val 'next)
  820.    (make-register-assignment
  821.     'argl
  822.     (make-add-to-arglist (make-fetch 'val)
  823.                          (make-fetch 'argl)))))
  824.  
  825. (define (compile-no-args app c-t-env target cont)
  826.   (append-instruction-sequences
  827.    (compile-expression (operator app) c-t-env 'fun 'next)
  828.    (make-register-assignment 'argl (make-empty-arglist))
  829.    (compile-call target cont)))
  830.  
  831. (define (compile-call target cont)
  832.   (if (eq? target 'val)
  833.       (compile-call-result-in-val cont)
  834.       (append-instruction-sequences
  835.        (compile-call-result-in-val 'next)
  836.        (make-register-assignment target (make-fetch 'val))
  837.        (compile-continuation cont))))
  838.  
  839. (define (compile-call-result-in-val cont)
  840.   (cond ((eq? cont 'return)
  841.          (compile-call-return-to nil))
  842.         ((eq? cont 'next)
  843.          (let ((after-call (make-new-label 'after-call)))
  844.            (append-instruction-sequences
  845.             (compile-call-return-to after-call)
  846.             (make-entry-point-designator after-call))))
  847.         (else
  848.          (compile-call-return-to cont))))
  849.  
  850. (define (compile-return)
  851.   (append-instruction-sequences
  852.    (make-restore 'continue)
  853.    (make-return-from-procedure)))
  854.  
  855. (define (compile-call-return-to return-entry)
  856.   (if (null? return-entry)
  857.       (make-transfer-to-procedure)
  858.       (append-instruction-sequences
  859.        (make-register-assignment 'continue return-entry)
  860.        (make-save 'continue)
  861.        (make-transfer-to-procedure))))
  862.  
  863. ;;; Conditionals
  864.  
  865. (define (compile-cond clauses c-t-env target cont)
  866.   (if (eq? cont 'next)
  867.       (let ((end-of-cond (make-new-label 'cond-end)))
  868.         (append-instruction-sequences
  869.          (compile-clauses clauses c-t-env target end-of-cond)
  870.          (make-entry-point-designator end-of-cond)))
  871.       (compile-clauses clauses c-t-env target cont)))
  872.  
  873. (define (compile-clauses clauses c-t-env target cont)
  874.   (if (no-clauses? clauses)
  875.       (compile-constant nil c-t-env target cont)
  876.       (compile-a-clause (first-clause clauses)
  877.                         (rest-clauses clauses)
  878.                         c-t-env target cont)))
  879.  
  880. (define (compile-a-clause clause rest c-t-env target cont)
  881.   (let ((consequent (compile-sequence (actions clause)
  882.                                       c-t-env target cont)))
  883.     (if (else-clause? clause)
  884.         consequent
  885.         (let
  886.          ((alternative (compile-clauses rest
  887.                                         c-t-env target cont))
  888.           (pred (compile-expression (predicate clause)
  889.                                     c-t-env 'val 'next))
  890.           (true-branch (make-new-label 'true-branch)))
  891.          (let ((alternative-and-consequent
  892.                 (parallel-instruction-sequences
  893.                  alternative
  894.                  (append-instruction-sequences
  895.                   (make-entry-point-designator true-branch)
  896.                   consequent))))
  897.            (preserving
  898.             'env
  899.             pred
  900.             (append-instruction-sequences
  901.              (make-branch (make-test 'val) true-branch)
  902.              alternative-and-consequent)))))))
  903.  
  904. (define (compile-sequence seq c-t-env target cont)
  905.   (if (last-exp? seq)
  906.       (compile-expression (first-exp seq) 
  907.                           c-t-env target cont)
  908.       (preserving
  909.        'env
  910.        (compile-expression (first-exp seq) c-t-env nil 'next)
  911.        (compile-sequence (rest-exps seq) c-t-env target cont)
  912.        )))
  913.  
  914. ;;; Assignments
  915.  
  916. (define (compile-assignment exp c-t-env target cont)
  917.   (let ((hold-value (if (null? target) 'val target)))
  918.     (preserving
  919.      'env
  920.      (compile-expression (assignment-value exp)
  921.                          c-t-env hold-value 'next)
  922.      (append-instruction-sequences
  923.       (make-variable-assignment (assignment-variable exp)
  924.                                 c-t-env
  925.                                 (make-fetch hold-value))
  926.       (compile-continuation cont)))))
  927.  
  928. ;;; Definitions
  929.  
  930. (define (compile-definition exp c-t-env target cont)
  931.   (let ((hold-value (if (null? target) 'val target))
  932.         (var (definition-variable exp)))
  933.     (preserving
  934.      'env
  935.      (compile-expression (definition-value exp)
  936.                          c-t-env hold-value 'next)
  937.      (append-instruction-sequences
  938.       (make-variable-definition var
  939.                                 c-t-env
  940.                                 (make-fetch hold-value))
  941.       (make-register-assignment target (make-constant var))
  942.       (compile-continuation cont)))))
  943.  
  944. ;;; Lambda expressions
  945.  
  946. (define (compile-lambda exp c-t-env target cont)
  947.   (if (eq? cont 'next)
  948.       (let ((after-lambda (make-new-label 'after-lambda)))
  949.         (append-instruction-sequences
  950.          (compile-lambda-2 exp c-t-env target after-lambda)
  951.          (make-entry-point-designator after-lambda)))
  952.       (compile-lambda-2 exp c-t-env target cont)))
  953.  
  954. (define (compile-lambda-2 exp c-t-env target cont)
  955.   (let ((proc-entry (make-new-label 'entry)))
  956.     (tack-on-instruction-sequence
  957.      (append-instruction-sequences
  958.       (make-register-assignment
  959.        target
  960.        (make-procedure-constructor proc-entry))
  961.       (compile-continuation cont))
  962.      (compile-lambda-body exp c-t-env proc-entry))))
  963.  
  964. (define (compile-lambda-body exp c-t-env proc-entry)
  965.   (append-instruction-sequences
  966.    (make-entry-point-designator proc-entry)
  967.    (make-environment-switch (lambda-parameters exp))
  968.    (compile-sequence
  969.     (lambda-body exp)
  970.     (extend-compile-time-env (lambda-parameters exp) c-t-env)
  971.     'val
  972.     'return)))
  973.  
  974. ;;; New syntax procedures
  975. (define (lambda-parameters exp) (cadr exp))
  976.  
  977. (define (lambda-body exp) (cddr exp))
  978.  
  979.  
  980. ;;; Section 5.3.3 -- compiler data structures
  981.  
  982. ;;; Instruction sequences
  983.  
  984. (define (make-instruction-sequence needs modifies statements)
  985.   (list needs modifies statements))
  986.  
  987. (define (registers-needed s) (car s))
  988.  
  989. (define (registers-modified s) (cadr s))
  990.  
  991. (define (statements s) (caddr s))
  992.  
  993. (define (needs-register seq reg)
  994.   (element-of-set? reg (registers-needed seq)))
  995.  
  996. (define (modifies-register seq reg)
  997.   (element-of-set? reg (registers-modified seq)))
  998.  
  999. (define (make-instruction needed modified statement)
  1000.   (make-instruction-sequence needed 
  1001.                              modified 
  1002.                              (list statement)))
  1003.  
  1004. (define (empty-instruction-sequence)
  1005.   (make-instruction-sequence empty-set empty-set '()))
  1006.  
  1007. ;;; Combining instruction sequences
  1008.  
  1009. (define (append-instruction-sequences . seqs)
  1010.   (define (append-2-sequences seq1 seq2)
  1011.     (make-instruction-sequence
  1012.      (union-set (registers-needed seq1)
  1013.                 (difference-set (registers-needed seq2)
  1014.                                 (registers-modified seq1)))
  1015.      (union-set (registers-modified seq1)
  1016.                 (registers-modified seq2))
  1017.      (append (statements seq1) (statements seq2))))
  1018.  
  1019.   (define (append-seq-list seqs)
  1020.     (if (null? seqs)
  1021.         (empty-instruction-sequence)
  1022.         (append-2-sequences (car seqs)
  1023.                             (append-seq-list (cdr seqs)))))
  1024.   (append-seq-list seqs))
  1025.  
  1026. ;;; Combiner used by Compile-lambda
  1027.  
  1028. (define (tack-on-instruction-sequence seq body-seq)
  1029.   (append-instruction-sequences
  1030.    seq
  1031.    (make-instruction-sequence empty-set
  1032.                               empty-set
  1033.                               (statements body-seq))))
  1034.  
  1035. ;;; Combiner used by Compile-cond
  1036.  
  1037. (define (parallel-instruction-sequences seq1 seq2)
  1038.   (make-instruction-sequence
  1039.    (union-set (registers-needed seq1) 
  1040.               (registers-needed seq2))
  1041.    (union-set (registers-modified seq1) 
  1042.               (registers-modified seq2))
  1043.    (append (statements seq1) (statements seq2))))
  1044.  
  1045. ;;; Sets of registers
  1046.  
  1047. (define (union-set s1 s2)
  1048.   (cond ((null? s1) s2)
  1049.         ((memq (car s1) s2) (union-set (cdr s1) s2))
  1050.         (else (cons (car s1) (union-set (cdr s1) s2)))))
  1051.  
  1052. (define (difference-set s1 s2)
  1053.   (cond ((null? s1) '())
  1054.         ((memq (car s1) s2) (difference-set (cdr s1) s2))
  1055.         (else (cons (car s1) (difference-set (cdr s1) s2)))))
  1056.  
  1057. (define (element-of-set? x s) (memq x s))
  1058.  
  1059. (define (singleton x) (list x))
  1060.  
  1061. (define (make-set list-of-elements) list-of-elements)
  1062.  
  1063. (define empty-set '())
  1064.  
  1065. ;;; Value specifiers
  1066.  
  1067. (define (make-val-spec registers-needed expression)
  1068.   (list registers-needed expression))
  1069.  
  1070. (define (val-spec-registers-needed value)
  1071.   (car value))
  1072.  
  1073. (define (val-spec-expression value)
  1074.   (cadr value))
  1075.  
  1076. ;;; Section 5.3.4 -- Primitive code generators
  1077.  
  1078. ;;; Generators for any register machine
  1079.  
  1080. (define (make-constant c)
  1081.   (make-val-spec empty-set (list 'quote c)))
  1082.  
  1083. (define (make-label symbol)
  1084.   (make-val-spec empty-set symbol))
  1085.  
  1086. (define (make-new-label name)
  1087.   (make-label (make-new-symbol name)))
  1088.  
  1089. (define (make-fetch reg)
  1090.   (make-val-spec (singleton reg) (list 'fetch reg)))
  1091.  
  1092. (define (make-operation operation . inputs)
  1093.   (make-val-spec
  1094.    (union-all-sets (mapcar val-spec-registers-needed inputs))
  1095.    (cons operation (mapcar val-spec-expression inputs))))
  1096.  
  1097. (define (union-all-sets sets)
  1098.   (if (null? sets)
  1099.       empty-set
  1100.       (union-set (car sets) (union-all-sets (cdr sets)))))
  1101.  
  1102. (define (make-register-assignment reg val-spec)
  1103.   (if (null? reg)
  1104.       (empty-instruction-sequence)
  1105.       (make-instruction
  1106.        (val-spec-registers-needed val-spec)
  1107.        (singleton reg)
  1108.        (list 'assign reg (val-spec-expression val-spec)))))
  1109.  
  1110. (define (make-nonlocal-goto continuation cont-needs)
  1111.   (make-goto continuation (make-set cont-needs) all))
  1112.  
  1113. (define all (make-set '(fun env val argl continue)))
  1114.  
  1115. (define (make-jump continuation)
  1116.   (make-goto continuation empty-set empty-set))
  1117.  
  1118. (define (make-goto cont cont-needs cont-modifies)
  1119.   (make-instruction
  1120.    (union-set (val-spec-registers-needed cont) cont-needs)
  1121.    cont-modifies
  1122.    (list 'goto (val-spec-expression cont))))
  1123.  
  1124. (define (make-branch predicate true-branch)
  1125.   (make-instruction
  1126.    (union-set (val-spec-registers-needed predicate)
  1127.               (val-spec-registers-needed true-branch))
  1128.    empty-set
  1129.    (list 'branch
  1130.          (val-spec-expression predicate)
  1131.          (val-spec-expression true-branch))))
  1132.  
  1133. (define (make-save reg)
  1134.   (make-instruction (singleton reg)
  1135.                     empty-set
  1136.                     (list 'save reg)))
  1137.  
  1138. (define (make-restore reg)
  1139.   (make-instruction empty-set
  1140.                     (singleton reg)
  1141.                     (list 'restore reg)))
  1142.  
  1143. (define (make-perform action)
  1144.   (make-instruction
  1145.    (val-spec-registers-needed action)
  1146.    empty-set
  1147.    (list 'perform (val-spec-expression action))))
  1148.  
  1149. (define (make-entry-point-designator label-val-spec)
  1150.   (make-instruction empty-set
  1151.                     empty-set
  1152.                     (val-spec-expression label-val-spec)))
  1153.  
  1154. ;;; The following is used by Preserving
  1155.  
  1156. (define (wrap-save-restore seq reg)
  1157.   (make-instruction-sequence
  1158.    (registers-needed seq)
  1159.    (difference-set (registers-modified seq) (singleton reg))
  1160.    (append (statements (make-save reg))
  1161.            (statements seq)
  1162.            (statements (make-restore reg)))))
  1163.  
  1164. ;;; Generators for the evaluator machine
  1165.  
  1166. (define (make-variable-access var c-t-env)
  1167.   (make-operation 'lookup-variable-value
  1168.                   (make-constant var)
  1169.                   (make-fetch 'env)))
  1170.  
  1171. (define (make-test reg)
  1172.   (make-operation 'true? (make-fetch reg)))
  1173.  
  1174. (define (make-variable-assignment var c-t-env value)
  1175.   (make-perform
  1176.    (make-operation 'set-variable-value!
  1177.                    (make-constant var)
  1178.                    value
  1179.                    (make-fetch 'env))))
  1180.  
  1181. (define (make-variable-definition var c-t-env value)
  1182.   (make-perform
  1183.    (make-operation 'define-variable!
  1184.                    (make-constant var)
  1185.                    value
  1186.                    (make-fetch 'env))))
  1187.  
  1188. (define (make-procedure-constructor entry)
  1189.   (make-operation 'make-compiled-procedure
  1190.                   entry
  1191.                   (make-fetch 'env)))
  1192.  
  1193. (define (make-environment-switch formals)
  1194.   (append-instruction-sequences
  1195.    (make-register-assignment
  1196.     'env
  1197.     (make-operation 'compiled-procedure-env
  1198.                     (make-fetch 'fun)))
  1199.    (make-register-assignment
  1200.     'env
  1201.     (make-operation 'extend-binding-environment
  1202.                     (make-constant formals)
  1203.                     (make-fetch 'argl)
  1204.                     (make-fetch 'env)))))
  1205.  
  1206. (define (make-singleton-arglist first-arg-spec)
  1207.   (make-operation 'cons first-arg-spec (make-constant '())))
  1208.  
  1209. (define (make-add-to-arglist next-arg-spec rest-args-spec)
  1210.   (make-operation 'cons next-arg-spec rest-args-spec))
  1211.  
  1212. (define (make-empty-arglist)
  1213.   (make-constant '()))
  1214.  
  1215. (define (make-transfer-to-procedure)
  1216.   (make-nonlocal-goto (make-label 'apply-dispatch)
  1217.                       '(fun argl)))
  1218.  
  1219. (define (make-return-from-procedure)
  1220.   (make-nonlocal-goto (make-fetch 'continue)
  1221.                       '(val)))
  1222.  
  1223. ;;; Section 5.3.5 -- sample compilation
  1224.  
  1225. (compile-expression
  1226.  '(define (factorial n)
  1227.     (cond ((= n 1) 1)
  1228.           (else (* (factorial (- n 1)) n))))
  1229.  initial-c-t-env
  1230.  'val
  1231.  'next)
  1232.  
  1233. ;;; Exercise 5.30
  1234. (define (factorial-alt n)
  1235.   (cond ((= n 1) 1)
  1236.         (else (* n (factorial-alt (- n 1))))))
  1237.  
  1238. ;;; Exercise 5.31
  1239. (define (factorial-iter n)
  1240.   (define (iter product counter)
  1241.     (cond ((> counter n) product)
  1242.           (else (iter (* counter product) (+ counter 1)))))
  1243.   (iter 1 1))
  1244.  
  1245. ;;; Section 5.3.6 -- Compiler/evaluator interface
  1246.  
  1247. apply-dispatch
  1248.   (branch (primitive-procedure? (fetch fun)) primitive-apply)
  1249.   (branch (compound-procedure? (fetch fun)) compound-apply)
  1250.   (branch (compiled-procedure? (fetch fun)) compiled-apply)
  1251.   (goto unknown-procedure-type-error)
  1252.  
  1253. compiled-apply
  1254.    (assign val (compiled-procedure-entry (fetch fun)))
  1255.    (goto (fetch val))
  1256.  
  1257. (define (make-compiled-procedure entry env)
  1258.   (list 'compiled-procedure entry env))
  1259.  
  1260. (define (compiled-procedure? proc)
  1261.   (if (atom? proc)
  1262.       nil
  1263.       (eq? (car proc) 'compiled-procedure)))
  1264.  
  1265. (define (compiled-procedure-entry proc)
  1266.   (cadr proc))
  1267.  
  1268. (define (compiled-procedure-env proc)
  1269.   (caddr proc))
  1270.  
  1271.  
  1272. (define (compile-and-go expression)
  1273.   (remote-assign
  1274.    explicit-control-evaluator
  1275.    'val
  1276.    (build-instruction-list explicit-control-evaluator
  1277.                            (compile expression)))
  1278.   (eval '(goto external-entry)
  1279.         explicit-control-evaluator))
  1280.  
  1281.  
  1282. external-entry
  1283.    (perform (initialize-stack))
  1284.    (assign env the-global-environment)
  1285.    (assign continue print-result)
  1286.    (save continue)
  1287.    (goto (fetch val))
  1288.  
  1289.  (define (user-print object)}}}
  1290.    (cond ((compound-procedure? object)
  1291.           (print (list 'compound-procedure
  1292.                        (parameters object)
  1293.                        (procedure-body object)
  1294.                        '[procedure-env])))
  1295.          ((compiled-procedure? object)                  ;new clause
  1296.           (print '[compiled-procedure]))
  1297.          (else (print object))))
  1298.  
  1299. (define (compile expression)
  1300.   (statements (compile-expression expression
  1301.                                   initial-c-t-env
  1302.                                   'val
  1303.                                   'return)))
  1304.  
  1305. ;;; Section 5.3.7 -- Lexical addressing
  1306.  
  1307. (let ((x 3) (y 4))
  1308.   (lambda (a b c d e)
  1309.     (let ((y (* a b x))
  1310.           (z (+ c d x)))
  1311.       (* x y z))))
  1312.  
  1313. ((lambda (x y)
  1314.    (lambda (a b c d e)
  1315.      ((lambda (y z) (* x y z))
  1316.       (* a b x)
  1317.       (+ c d x))))
  1318.  3
  1319.  4)
  1320.  
  1321.  
  1322. (define (extend-compile-time-env params c-t-env)
  1323.   (cons params c-t-env))   
  1324.  
  1325. ;;; Exercise 5.39
  1326.  
  1327. ((lambda (n)
  1328.    ((lambda (fact-iter)
  1329.       (fact-iter fact-iter 1 1))
  1330.     (lambda (f-i product counter)
  1331.       (cond ((> counter n) product)
  1332.             (else (f-i f-i
  1333.                        (* counter product)
  1334.                        (+ counter 1)))))))
  1335.  4)
  1336.  
  1337. ;;; Section 5.4.2 -- Stop-and-copy garbage collector
  1338.  
  1339. begin-garbage-collection
  1340.   (assign free 0)
  1341.   (assign scan 0)
  1342.   (assign old (fetch root))
  1343.   (assign relocate-continue reassign-root)
  1344.   (goto relocate-old-result-in-new)
  1345. reassign-root
  1346.   (assign root (fetch new))
  1347.   (goto gc-loop)
  1348.  
  1349. gc-loop
  1350.   (branch (= (fetch scan) (fetch free)) gc-flip)
  1351.   (assign old (vector-ref (fetch new-cars) (fetch scan)))
  1352.   (assign relocate-continue update-car)
  1353.   (goto relocate-old-result-in-new)
  1354.  
  1355. update-car
  1356.   (perform
  1357.    (vector-set! (fetch new-cars) (fetch scan) (fetch new)))
  1358.   (assign old (vector-ref (fetch new-cdrs) (fetch scan)))
  1359.   (assign relocate-continue update-cdr)
  1360.   (goto relocate-old-result-in-new)
  1361.  
  1362. update-cdr
  1363.   (perform
  1364.    (vector-set! (fetch new-cdrs) (fetch scan) (fetch new)))
  1365.   (assign scan (1+ (fetch scan)))
  1366.   (goto gc-loop)
  1367.  
  1368. relocate-old-result-in-new
  1369.   (branch (pointer-to-pair? (fetch old)) pair)
  1370.   (assign new (fetch old))
  1371.   (goto (fetch relocate-continue))
  1372.  
  1373. pair
  1374.   (assign oldcr (vector-ref (fetch the-cars) (fetch old)))
  1375.   (branch (broken-heart? (fetch oldcr)) already-moved)
  1376.   (assign new (fetch free))         ;new location for pair
  1377.   (assign free (1+ (fetch free)))   ;update free pointer
  1378.  
  1379.   ;;Copy the car and cdr to new memory.
  1380.   (perform
  1381.    (vector-set! (fetch new-cars) (fetch new) (fetch oldcr)))
  1382.   (assign oldcr (vector-ref (fetch the-cdrs) (fetch old)))
  1383.   (perform
  1384.    (vector-set! (fetch new-cdrs) (fetch new) (fetch oldcr)))
  1385.  
  1386.   ;;Construct the broken heart.
  1387.   (perform
  1388.    (vector-set! (fetch the-cars) (fetch old) broken-heart))
  1389.   (perform
  1390.    (vector-set! (fetch the-cdrs) (fetch old) (fetch new)))
  1391.   (goto (fetch relocate-continue))
  1392.  
  1393. already-moved
  1394.   (assign new (vector-ref (fetch the-cdrs) (fetch old)))
  1395.   (goto (fetch relocate-continue))
  1396.  
  1397. gc-flip
  1398.   (assign temp (fetch the-cdrs))
  1399.   (assign the-cdrs (fetch new-cdrs))
  1400.   (assign new-cdrs (fetch temp))
  1401.   (assign temp (fetch the-cars))
  1402.   (assign the-cars (fetch new-cars))
  1403.   (assign new-cars (fetch temp))
  1404. (46)%