<< Previous exercise (5.47) | Index | Next exercise (5.49) >>


 ; this code will get executed by primitive-apply in ch5-eceval-compiler.scm 
 ; specifically, by (apply-primitive-procedure) 
 (define (compile-and-run expression) 
     (let ((stack (eceval 'stack)) 
                     (statements (compile expression 'val 'next)) 
                     ; print the result after executing statements 
                     '((goto (reg printres)))) 
         ; get rid of old value of continue 
         ; this is optional, because (initialize-stack) will  
         ; clear the stack after print-result 
         (stack 'pop)  
         ; the next 2 commands in primitive-apply are: 
         ; (restore continue) 
         ; (goto (reg continue)) 
         ; this forces eceval to jump to and execute instructions 
         ((stack 'push) instructions))) 
 ; -------------------------------------------------- 
 (define (test-5.48) 
     (load "ch5-compiler.scm") 
     (load "load-eceval-compiler.scm") 
     ; add and initialize new register printres to expose label print-result 
     ; cf. compadd from 5.47 
     (set! eceval (make-machine 
         (cons 'printres eceval-compiler-register-list) 
         eceval-operations   ; procedures accessible via (op) in asm code 
             '(assign printres (label print-result))  
     ; procedures accessible at the EC-Eval prompt 
     (append! primitive-procedures  
         (list (list 'compile-and-run compile-and-run)))     
 ; ;;; EC-Eval input: 
 ; (compile-and-run '(define (f n) (if (= n 1) 1 (* (f (- n 1)) n)))) 
 ; ;;; EC-Eval value: 
 ; ok 
 ; ;;; EC-Eval input: 
 ; (f 5) 
 ; ;;; EC-Eval value: 
 ; 120 


 (define (prim-compile-and-run expression) 
   (assemble (statements 
              (compile expression 'val 'return '())) 
 (define (compile-and-run? exp) 
   (tagged-list? exp 'compile-and-run)) 
 (define (compile-and-run-exp exp) 
   (cadadr exp)) 
 ; this is added to ev-dispatch 
        (test (op compile-and-run?) (reg exp)) 
        (branch (label ev-compile-and-run)) 
 ; here is ev-compile-and-run 
        (assign val (op compile-and-run-exp) (reg exp))  
        (assign val (op prim-compile-and-run) (reg val)) 
        (goto (label external-entry)) 
 ;;; EC-Eval input: 
  '(define (factorial n) 
     (if (= n 1) 
         (* (factorial (- n 1)) n)))) 
 (total-pushes = 0 max-depth = 0) 
 ;;; EC-Eval value: 
 ;;; EC-Eval input: 
 (factorial 5) 
 (total-pushes = 11 max-depth = 8) 
 ;;; EC-Eval value: 
 ;; from the stack data we can see that it is in fact the compiled version 
 ;; of factorial.  


To avoid having the compiler or evaluator direclty access the machine/eceval, I added a (dynamic) assemble instruction to the Register Machine's assembler.


  (define (statements-with-return exp)
      (compile exp empty-ctenv 'val 'return)))

Register Machine - Assembler

To keep it simple the assemble instruction doesn't take any parameters, it
reads the statetments from the val register, and then writes the assembled
instructions back to val:

  (define (make-assemble-val inst machine labels operations pc)
    (lambda ()
      (let* ((statements (get-register-contents machine 'val))
              (assemble statements machine)))
        (set-register-contents! machine 'val instructions)
        (advance-pc pc))))

This is called from make-execution-procedure:

  (define (make-execution-procedure ...)
    (cond ((eq? (car inst) 'assign)
           (make-assign inst machine labels ops pc))
          ((eq? (car inst) 'assemble-val)                     ;*
           (make-assemble-val inst machine labels ops pc))    ;*
          (else (error \"Unknown instruction type -- ASSEMBLE\" inst))))


The ec-evaluator compiles the expression to val, uses assemble-val to
replace the statements with the assembled instructions and then goes to
those instructions:

    (assign exp (op compile-and-run-exp) (reg exp))
    (assign val (op statements-with-return) (reg exp))
    (goto (reg val))

This is called from eval-dispatch:

    (test (op self-evaluating?) (reg exp))
    (branch (label ev-self-eval))
    (test (op compile-and-run?) (reg exp))                    ;*
    (branch (label compile-and-run))                          ;*
    (test (op application?) (reg exp))
    (branch (label ev-application))
    (goto (label unknown-expression-type))

These use the following additional primitive operations:

  (list 'compile-and-run?
       (lambda (exp) (tagged-list? exp 'compile-and-run)))
  (list 'statements-with-return statements-with-return)
  (list 'compile-and-run-exp cadr)