SICPch5

5.1

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_1.md

5.2

(controller
  (assign product (const 1))
  (assign counter (const 1))

test-n
  (test (op >) (reg counter) (reg n))
  (branch (label fact-done))
  (assign product (op *) (reg counter) (reg product))
  (assign counter (op +) (reg counter) (const 1))
  (goto (label test-n))

fact-done)

5.3

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_3.md

逐步展开

sqrt 机器，假设 good-enough?和 improve 是基础操作。

(controller
  (assign guess (const 1.0))
test-guess  
  (test (op good-enough?) (reg guess))
  (branch (label sqrt-done))
  (assign guess (op improve) (reg guess))
  (goto (label test-guess))
sqrt-done)

good-enough? 机器，假设 square 和 abs 是基础操作。

(controller
  (assign tmp (op square) (reg guess))
  (assign tmp (op -) (reg tmp) (reg x))
  (assign tmp (op abs) (reg tmp))
  (test (op <) (reg tmp) (const 0.001)))

good-enough?机器，展开 square 和 abs 为算术运算

(controller
  (assign tmp (op *) (reg guess) (reg guess))
  (assign tmp (op -) (reg tmp) (reg x))
  (test (op <) (reg tmp) (const 0))
  (branch (label abs-neg))
  (goto (label abs-done))
abs-neg
  (assign tmp (op -) (reg tmp))
abs-done
  (test (op <) (reg tmp) (const 0.001)))

improve 机器，假设 average 是基础操作。

(controller
  (assign tmp (op /) (reg x) (reg guess))
  (assign tmp (op average) (reg guess) (reg tmp)))

improve机器，展开 average 为算术运算。

(controller
  (assign tmp (op /) (reg x) (reg guess))
  (assign tmp (op +) (reg guess) (reg tmp))
  (assign tmp (op /) (reg tmp) (const 2)))

完整的sqrt机器

将 good-enough? 和 improve机器，嵌入到 sqrt机器中。得到最终的sqrt机器，只使用基本的算术运算实现。

(controller
  (assign guess (const 1.0))

test-good-enough
  (assign tmp (op *) (reg guess) (reg guess))
  (assign tmp (op -) (reg tmp) (reg x))
  (test (op <) (reg tmp) (const 0))
  (branch (label abs-neg))
  (goto (label abs-done))
abs-neg
  (assign tmp (op -) (reg tmp))
abs-done
  (test (op <) (reg tmp) (const 0.001))

  (branch (label sqrt-done))

  (assign tmp (op /) (reg x) (reg guess))
  (assign tmp (op +) (reg guess) (reg tmp))
  (assign guess (op /) (reg tmp) (const 2))

  (goto (label test-good-enough))
sqrt-done)

上述的sqrt机器，使用x、guess、tmp 三个寄存器。其中x为输入，guess 为最终输出。

数据通道图

控制器图

5.4

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_4.md

(controller
  (assign continue (label expt-done))
expt-loop
  (test (op =) (reg n) (const 0))
  (branch (label base-case))

  (save continue)
  (assign n (op -) (reg n) (const 1))
  (assign continue (label after-expt))
  (goto (label expt-loop))

after-expt
  (restore continue)
  (assign val (op *) (reg b) (reg val))
  (goto (reg continue))

base-case
  (assign val (const 1))
  (goto (reg continue))  
expt-done)

(controller
  (assign product (const 1))

expt-loop  
  (test (op =) (reg n) (const 0))
  (branch (label expt-done))

  (assign product (op *) (reg b) (reg product))
  (assign n (op -) (reg n) (const 1))
  (goto (label expt-loop))
expt-done)

5.5

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_5.md
(a)阶乘的计算过程，取 n = 3, 在 fact-loop、after-fact、base-case、fact-done 处，各寄存器和堆栈的值如下图:

其中 val = xxx, 表示 val 还没有初始化。

(b)斐波那契的计算过程，取 n = 2, 在 fib-loop、 afterfib-n-1、afterfib-n-2、immediate-answer、fib-done 处，各寄存器和堆栈的值如下图:

5.6

afterfib-n-1
  (restore n)
  (restore continue) ;;
  (assign n (op -) (reg n) (const 2))
  (save continue)    ;;
  (assign continue (label afterfib-n-2))
  (save val)
  (goto (label fib-loop))

5.7

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_7.scm

(define expt-machine
  (make-machine
    '(val b n continue)
    (list (list '- -) (list '= =) (list '* *))
    '(
      (assign continue (label expt-done))
      expt-loop
      (test (op =) (reg n) (const 0))
      (branch (label base-case))

      (save continue)
      (assign n (op -) (reg n) (const 1))
      (assign continue (label after-expt))
      (goto (label expt-loop))

      after-expt
      (restore continue)
      (assign val (op *) (reg b) (reg val))
      (goto (reg continue))

      base-case
      (assign val (const 1))
      (goto (reg continue))  
      expt-done
      )))

(set-register-contents! expt-machine 'b 2)
(set-register-contents! expt-machine 'n 10)
(start expt-machine)
(get-register-contents expt-machine 'val) ;; 1024

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define expt-machine-2
  (make-machine
    '(product b n continue)
    (list (list '- -) (list '= =) (list '* *))
    '(
      (assign product (const 1))

      expt-loop  
      (test (op =) (reg n) (const 0))
      (branch (label expt-done))

      (assign product (op *) (reg b) (reg product))
      (assign n (op -) (reg n) (const 1))
      (goto (label expt-loop))
      expt-done
      )))

(set-register-contents! expt-machine-2 'b 2)
(set-register-contents! expt-machine-2 'n 10)
(start expt-machine-2)
(get-register-contents expt-machine-2 'product) ;; 1024

5.8

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
        (lambda (insts labels)
          (let ((next-inst (car text)))
            (if (symbol? next-inst)
                (if (assoc next-inst labels)
                    (error "repeated label!" next-inst)
                    (receive insts
                             (cons (make-label-entry next-inst
                                                     insts)
                                   labels))
                    (receive (cons (make-instruction next-inst)
                                   insts)
                             labels))))))))

5.9

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (if (label-exp? e)
                    (error "can't operate on LABELS!" e)
                    (make-primitive-exp e machine labels)))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

5.10

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_10.md

功能	前缀	原来语法	新语法
label	:	(label fact-done)	:fact-done
reg	(reg n)
op	@	(op =)	@=
const	无	(const 1)	1

(define (symbol-starting-with? symbol prefix)
  (and (symbol? symbol)
       (equal? (substring (symbol->string symbol) 0 1) prefix)))

(define (symbol-without-prefix symbol)
  (string->symbol (substring (symbol->string symbol) 1)))

(define (register-exp? exp) (symbol-starting-with? exp 
(define (register-exp-reg exp) (symbol-without-prefix exp))

(define (constant-exp? exp) 
  (and (not (pair? exp))
       (not (register-exp? exp))
       (not (label-exp? exp))
       (not (operation-exp? exp))))

(define (constant-exp-value exp) exp)

(define (label-exp? exp) (symbol-starting-with? exp ":"))
(define (label-exp-label exp) (symbol-without-prefix exp))

(define (operation-exp? exp) 
  (and (pair? exp) 
       (symbol-starting-with? (car exp) "@")))
(define (operation-exp-op operation-exp) 
  (symbol-without-prefix (car operation-exp)))
(define (operation-exp-operands operation-exp) 
  (cdr operation-exp))

5.11

(a)

afterfib-n-2
  (restore n)
  (restore continue)
  (assign val
          (op +) (reg val) (reg n)) 

(b)

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst)))
        (reg-name (stack-inst-reg-name inst)))
    (lambda ()
      (push stack (cons reg-name (get-contents reg)))
      (advance-pc pc))))
(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst)))
        (reg-name (stack-inst-reg-name inst)))
    (lambda ()
      (if (eq? reg-name (car (pop stack)))
          (begin
            (set-contents! reg (pop stack))
            (advance-pc pc))
          (error "the value is not from the register:" reg-name)))))

(c)

(define (make-register name)
  (let ((contents '*unassigned*)
        (stack (make-stack)))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value) (set! contents value)))
            ((eq? message 'stack) stack)
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))
(define (make-save inst machine pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (push (reg 'stack) (get-contents reg))
      (advance-pc pc))))

(define (make-restore inst machine pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (set-contents! reg (pop (reg 'stack)))
      (advance-pc pc))))

看了https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_11.md，
还需要删除make-new-machine和make-execution-procedure的stack

(redefine (make-new-machine)
  (let* ((pc (make-register 'pc))
         (flag (make-register 'flag))
         (the-instruction-sequence '())
         (register-table
           (list (list 'pc pc) (list 'flag flag))))
    (let ((the-ops
            (list (list 'initialize-stack
                        (lambda () 
                          (for-each (lambda (reg-pair)
                                      (let ((stack ((cdr reg-pair) 'stack)))
                                        (stack 'initialize))
                                      register-table))))
                  ;;**next for monitored stack (as in section 5.2.4)
                  ;;  -- comment out if not wanted
                  (list 'print-stack-statistics
                        (lambda () 
                          (for-each (lambda (reg-pair)
                                      (let ((stack ((cdr reg-pair) 'stack)))
                                        (stack 'print-statistics))
                                      register-table)))))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(define (make-execution-procedure inst labels machine
                                  pc flag ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign inst machine labels ops pc))
        ((eq? (car inst) 'test)
         (make-test inst machine labels ops flag pc))
        ((eq? (car inst) 'branch)
         (make-branch inst machine labels flag pc))
        ((eq? (car inst) 'goto)
         (make-goto inst machine labels pc))
        ((eq? (car inst) 'save)
         (make-save inst machine pc))
        ((eq? (car inst) 'restore)
         (make-restore inst machine pc))
        ((eq? (car inst) 'perform)
         (make-perform inst machine labels ops pc))
        (else (error "Unknown instruction type -- ASSEMBLE"
                     inst))))

5.12

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_12.md

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine-dataset)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)    
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

(define (make-dataset)
  (let ((dataset '()))            
    (define (insert! datum)
      (if (not (is-in-dataset? datum))
          (set! dataset (cons datum dataset))))                
    (define (print)
      (for-each (lambda (inst)
                  (display inst)
                  (newline))
                dataset))    
    (define (is-in-dataset? datum)
      (cond ((symbol? datum) (memq datum dataset))
            ((list? datum) (member datum dataset))
            (else (error "Unknown data type -- IS-IN-dataset?" datum))))
    (define (dispatch message)
      (cond ((eq? message 'insert!) insert!)
            ((eq? message 'print) (print))
            (else (error "Unknown operation -- DATASET" message))))
    dispatch))

(define (insert-to-dataset! dataset datum)
  ((dataset 'insert!) datum))

(define (print-dataset dataset)
  (dataset 'print))

(define (make-new-machine-dataset)
  (let ((machine (make-new-machine))
        (inst-dataset-table '())
        (register-dataset-table '())
        (assign-dataset-table '()))

    (define (get-dataset dataset-table name set-fn)
      (let ((val (assoc name dataset-table)))
        (if val
            (cadr val)
            (let ((dataset (list name (make-dataset))))
              (set-fn (cons dataset dataset-table))
              (cadr dataset)))))

    (define (get-inst-dataset name)
      (get-dataset inst-dataset-table 
                   name 
                   (lambda (table) (set! inst-dataset-table table))))

    (define (get-register-dataset name)
      (get-dataset register-dataset-table 
                   name
                   (lambda (table) (set! register-dataset-table table))))

    (define (get-assign-dataset name)
      (get-dataset assign-dataset-table 
                   name
                   (lambda (table) (set! assign-dataset-table table))))

    (define (print-all-dataset-table)
      (define (print-dataset-table t name)
        (display name)
        (newline)
        (display "==============")
        (newline)
        (for-each (lambda (dataset)
                    (display (car dataset))
                    (display ": ")
                    (newline)
                    (print-dataset (cadr dataset))
                    (newline))
                  t))
      (print-dataset-table inst-dataset-table "Instructions: ")
      (print-dataset-table register-dataset-table "Register: ")
      (print-dataset-table assign-dataset-table "Assign: "))

    (define (dispatch message)
      (cond ((eq? message 'get-inst-dataset) get-inst-dataset)
            ((eq? message 'get-register-dataset) get-register-dataset)
            ((eq? message 'get-assign-dataset) get-assign-dataset)
            ((eq? message 'print-all-dataset-table) print-all-dataset-table)
            (else (machine message))))                      
    dispatch))

(define (insert-inst-to-dataset! machine inst)
  (let ((dataset ((machine 'get-inst-dataset) (car inst))))
    (insert-to-dataset! dataset inst)))

(define (insert-assign-to-dataset! machine inst)
  (let ((dataset ((machine 'get-assign-dataset) (assign-reg-name inst))))
    (insert-to-dataset! dataset (assign-value-exp inst))))

(define (insert-register-to-dataset! machine inst-name reg-name)
  (let ((dataset ((machine 'get-register-dataset) inst-name)))
    (insert-to-dataset! dataset reg-name)))

(redefine (make-execution-procedure inst labels machine
                                    pc flag stack ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign-dataset inst machine labels ops pc))
        ((eq? (car inst) 'test)
         (insert-inst-to-dataset! machine inst)
         (make-test inst machine labels ops flag pc))
        ((eq? (car inst) 'branch)
         (insert-inst-to-dataset! machine inst)
         (make-branch inst machine labels flag pc))
        ((eq? (car inst) 'goto)
         (make-goto-dataset inst machine labels pc))
        ((eq? (car inst) 'save)
         (make-save-dataset inst machine stack pc))
        ((eq? (car inst) 'restore)
         (make-restore-dataset inst machine stack pc))
        ((eq? (car inst) 'perform)
         (insert-inst-to-dataset! machine inst)
         (make-perform inst machine labels ops pc))
        (else (error "Unknown instruction type -- ASSEMBLE"
                     inst))))

(define (make-assign-dataset inst machine labels ops pc)
  (insert-inst-to-dataset! machine inst)
  (insert-assign-to-dataset! machine inst)
  (make-assign inst machine labels ops pc))

(define (make-goto-dataset inst machine labels pc)
  (insert-inst-to-dataset! machine inst)
  (let ((dest (goto-dest inst)))
    (cond ((register-exp? dest) 
           (insert-register-to-dataset! machine 'goto (register-exp-reg dest)))))
  (make-goto inst machine labels pc))

(define (make-save-dataset inst machine stack pc)
  (insert-inst-to-dataset! machine inst)
  (insert-register-to-dataset! machine 'save (stack-inst-reg-name inst))
  (make-save inst machine stack pc))

(define (make-restore-dataset inst machine stack pc)
  (insert-inst-to-dataset! machine inst)
  (insert-register-to-dataset! machine 'restore (stack-inst-reg-name inst))
  (make-restore inst machine stack pc))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define fib-machine
  (make-machine
    '(continue n val)
    (list (list '< <)
          (list '- -)
          (list '+ +)
          )
    '(
      (assign continue (label fib-done))
      fib-loop
      (test (op <) (reg n) (const 2))
      (branch (label immediate-answer))
      ;; set up to compute Fib(n - 1)
      (save continue)
      (assign continue (label afterfib-n-1))
      (save n)                           ; save old value of n
      (assign n (op -) (reg n) (const 1)); clobber n to n - 1
      (goto (label fib-loop))            ; perform recursive call
      afterfib-n-1                         ; upon return, val contains Fib(n - 1)
      (restore n)
      (restore continue)
      ;; set up to compute Fib(n - 2)
      (assign n (op -) (reg n) (const 2))
      (save continue)
      (assign continue (label afterfib-n-2))
      (save val)                         ; save Fib(n - 1)
      (goto (label fib-loop))
      afterfib-n-2                         ; upon return, val contains Fib(n - 2)
      (assign n (reg val))               ; n now contains Fib(n - 2)
      (restore val)                      ; val now contains Fib(n - 1)
      (restore continue)
      (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
              (op +) (reg val) (reg n)) 
      (goto (reg continue))              ; return to caller, answer is in val
      immediate-answer
      (assign val (reg n))               ; base case:  Fib(n) = n
      (goto (reg continue))
      fib-done
      )))

其中inst-dataset-table用于保存指令表。对应问题 1。
register-dataset-table用于保存goto、save、restore 所用到的寄存器。对应问题 2、3。
assign-dataset-table保存赋值的来源。对应问题 4。

5.13

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '()))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (set! register-table
                  (cons (list name (make-register name))
                        register-table))
              (cadr reg))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

5.14

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_14.scm

(define fact-machine
  (make-machine
    '(continue n val)
    (list (list '= =)
          (list '- -)
          (list '* *)
          )
    '(
      (perform (op initialize-stack))
      (assign continue (label fact-done))     ; set up final return address
      fact-loop
      (test (op =) (reg n) (const 1))
      (branch (label base-case))
      ;; Set up for the recursive call by saving n and continue.
      ;; Set up continue so that the computation will continue
      ;; at after-fact when the subroutine returns.
      (save continue)
      (save n)
      (assign n (op -) (reg n) (const 1))
      (assign continue (label after-fact))
      (goto (label fact-loop))
      after-fact
      (restore n)
      (restore continue)
      (assign val (op *) (reg n) (reg val))   ; val now contains n(n - 1)!
      (goto (reg continue))                   ; return to caller
      base-case
      (assign val (const 1))                  ; base case: 1! = 1
      (goto (reg continue))                   ; return to caller
      fact-done
      (perform (op print-stack-statistics))
      )))

(define (loop start end f)
  (cond ((<= start end) 
         (f start)
         (loop (+ start 1) end f))))

5.15

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (count 0))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))
                 (list 'print-count
                       (lambda ()
                         (display count)
                         (newline)
                         (set! count 0)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (set! count (+ count 1))
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

在需要的机器后面加上(perform (op print-count))

5.16

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (trace-on false))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (cond (trace-on
                        (display (instruction-text (car insts)))
                        (newline)))
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              ((eq? message 'trace-on) (set! trace-on true))
              ((eq? message 'trace-off) (set! trace-on false))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

5.17

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_17.scm

;; make-instruction 中，添加 label。并且在 extract-labels 过程中设置 label。

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)    
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (instruction-number 0)
        (trace-on false))
    (let ((the-ops
            (list (list 'initialize-stack
                        (lambda () (stack 'initialize)))
                  (list 'print-stack-statistics
                        (lambda () (stack 'print-statistics)))
                  (list 'print-instruction-number
                        (lambda () 
                          (display "instruction-number: ")
                          (display instruction-number)
                          (newline)
                          (set! instruction-number 0)))))
          (register-table
            (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (cond (trace-on
                        (if (null? (instruction-label (car insts)))
                            (begin
                              (display (instruction-text (car insts)))
                              (newline))
                            (begin
                              (display (instruction-label (car insts)))
                              (newline)
                              (display (instruction-text (car insts)))
                              (newline)))))
                (set! instruction-number (+ instruction-number 1))
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              ((eq? message 'trace-on) (set! trace-on true))
              ((eq? message 'trace-off) (set! trace-on false))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(define (assemble controller-text machine)
  (extract-labels controller-text
                  (lambda (insts labels)
                    (update-insts! insts labels machine)
                    insts)))

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels 
        (cdr text)
        (lambda (insts labels)
          (let ((next-inst (car text)))
            (if (symbol? next-inst)
                (begin
                  (set-instruction-label! (car insts) next-inst)
                  (receive insts
                           (cons (make-label-entry next-inst insts) labels)))
                (receive (cons (make-instruction next-inst) insts)
                         labels)))))))

(define (update-insts! insts labels machine)
  (let ((pc (get-register machine 'pc))
        (flag (get-register machine 'flag))
        (stack (machine 'stack))
        (ops (machine 'operations)))
    (for-each
      (lambda (inst)
        (set-instruction-execution-proc! 
          inst
          (make-execution-procedure
            (instruction-text inst) labels machine
            pc flag stack ops)))
      insts)))

(define (make-instruction text)
  (list text '() '()))

(define (instruction-text inst)
  (car inst))

(define (instruction-execution-proc inst)
  (cadr inst))

(define (set-instruction-execution-proc! inst proc)
  (set-car! (cdr inst) proc))

(define (instruction-label inst)
  (caddr inst))

(define (set-instruction-label! inst label)
  (set-car! (cddr inst) label))

5.18

(define (make-register name)
  (let ((contents '*unassigned*)
        (trace-on false))
    (define (set value)
      (cond (trace-on
             (display name)
             (display ":")
             (display contents)
             (display "->")
             (display value)
             (newline)))
      (set! contents value))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set) set)
            ((eq? message 'trace-on) (set! trace-on true))
            ((eq? message 'trace-off) (set! trace-on false))
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))
(define (trace-on-register! machine reg-name)
  ((get-register machine reg-name) 'trace-on))

(define (trace-off-register! machine reg-name)
  ((get-register machine reg-name) 'trace-off))

5.19

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_19.scm

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)
    (let ((result (assemble controller-text machine)))
      ((machine 'install-instruction-sequence) (car result))
      ((machine 'install-instruction-labels) (cdr result)))
    machine))

(define (filter predicate sequence)
  (if (null? sequence)
      '()
      (if (predicate (car sequence))
          (cons (car sequence) (filter predicate (cdr sequence)))
          (filter predicate (cdr sequence)))))

(define (remove item lst)
  (filter (lambda (x) (not (eq? x item)))
          lst))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (the-instruction-labels '())
        (the-breakpoint-instructions '()))
    (let ((the-ops
            (list (list 'initialize-stack
                        (lambda () (stack 'initialize)))
                  ;;**next for monitored stack (as in section 5.2.4)
                  ;;  -- comment out if not wanted
                  (list 'print-stack-statistics
                        (lambda () (stack 'print-statistics)))))
          (register-table
            (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))

      ;; 打印在断点时的一些信息
      (define (print-breakpoint breakpoint inst)
        (display "break on ")
        (display (car breakpoint))
        (display ":")
        (display (cdr breakpoint))
        (display " ")
        (display (instruction-text inst))
        (newline)
        (display "register: ")
        (for-each (lambda (reg)
                    (let ((name (car reg))
                          (val (get-contents (cadr reg))))
                      (cond ((number? val)
                             (display name)
                             (display " = ")
                             (display val)
                             (display ", ")))))
                  register-table)
        (newline))

      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (let ((breakpoint (instruction-breakpoint (car insts))))
                (if (null? breakpoint)
                    (begin
                      ((instruction-execution-proc (car insts)))
                      (execute))
                    (print-breakpoint breakpoint (car insts)))))))

      (define (set-breakpoint label n)
        (let* ((insts (lookup-label the-instruction-labels label))
               (inst (list-ref insts (- n 1))))
          (cond ((null? (instruction-breakpoint inst))
                 (set! the-breakpoint-instructions (cons inst the-breakpoint-instructions))
                 (set-instruction-breakpoint! inst (cons label n))))))

      (define (cancel-breakpoint label n)
        (let* ((insts (lookup-label the-instruction-labels label))
               (inst (list-ref insts (- n 1))))
          (cond ((not (null? (instruction-breakpoint inst)))
                 (set! the-breakpoint-instructions (remove inst the-breakpoint-instructions))
                 (set-instruction-breakpoint! inst '())))))

      (define (cancel-all-breakpoints)
        (for-each (lambda (inst)
                    (set-instruction-breakpoint! inst '()))
                  the-breakpoint-instructions)
        (set! the-breakpoint-instructions '()))

      (define (proceed)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))

      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'install-instruction-labels)
               (lambda (labels) (set! the-instruction-labels labels)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              ((eq? message 'set-breakpoint) set-breakpoint)
              ((eq? message 'cancel-breakpoint) cancel-breakpoint)
              ((eq? message 'cancel-all-breakpoints) cancel-all-breakpoints)
              ((eq? message 'proceed) proceed)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(define (set-breakpoint machine label n)
  ((machine 'set-breakpoint) label n))

(define (cancel-breakpoint machine label n)
  ((machine 'cancel-breakpoint) label n))

(define (cancel-all-breakpoints machine)
  ((machine 'cancel-all-breakpoints)))

(define (proceed-machine machine)
  ((machine 'proceed)))

(define (assemble controller-text machine)
  (extract-labels controller-text
                  (lambda (insts labels)
                    (update-insts! insts labels machine)
                    (cons insts labels))))

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
                      (lambda (insts labels)
                        (let ((next-inst (car text)))
                          (if (symbol? next-inst)
                              (receive insts
                                       (cons (make-label-entry next-inst
                                                               insts)
                                             labels))
                              (receive (cons (make-instruction next-inst)
                                             insts)
                                       labels)))))))

(define (update-insts! insts labels machine)
  (let ((pc (get-register machine 'pc))
        (flag (get-register machine 'flag))
        (stack (machine 'stack))
        (ops (machine 'operations)))
    (for-each
      (lambda (inst)
        (set-instruction-execution-proc! 
          inst
          (make-execution-procedure
            (instruction-text inst) labels machine
            pc flag stack ops)))
      insts)))

(define (make-instruction text)
  (list text '() '()))

(define (instruction-text inst)
  (car inst))

(define (instruction-execution-proc inst)
  (cadr inst))

(define (set-instruction-execution-proc! inst proc)
  (set-car! (cdr inst) proc))

(define (instruction-breakpoint inst)
  (caddr inst))

(define (set-instruction-breakpoint! inst breakpoint)
  (set-car! (cddr inst) breakpoint))

5.20

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_20.md

(define x (cons 1 2))
(define y (list x x))

的盒子指针图，和存储器向量图如下

y 相当于
(cons x (cons x '()))
这里假设分配顺序是从右往左，先分配 (cons x ‘())。因而 y 指向 Index = 3 的位置。
如果分配顺序是从左往右，Index 2、3 位置存储的具体数据会有所调整，y 就指向 Index = 2 的位置。

5.21

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_21.scm

;; a)
(define (count-leaves-a tree)
  (cond ((null? tree) 0)
        ((not (pair? tree)) 1)
        (else (+ (count-leaves-a (car tree))
                 (count-leaves-a (cdr tree))))))

(define count-leaves-machine-a
  (make-machine
    '(tree result continue temp)
    (list (list 'null? null?)
          (list 'pair? pair?) 
          (list 'car car) 
          (list 'cdr cdr) 
          (list '+ +))
    '(
      (assign continue (label count-done))

    count-loop
      (test (op null?) (reg tree))
      (branch (label null-tree))

      (test (op pair?) (reg tree))
      (branch (label count-car))

      ;; (not (pair? tree))
      (assign result (const 1))
      (goto (reg continue))

    null-tree
      (assign result (const 0))
      (goto (reg continue))

    count-car
      (save continue)
      (save tree)

      (assign tree (op car) (reg tree))
      (assign continue (label count-cdr))
      (goto (label count-loop))

    count-cdr
      (restore tree)
      (save result)

      (assign tree (op cdr) (reg tree))
      (assign continue (label after-count))
      (goto (label count-loop))

    after-count
      (assign temp (reg result))  ; cdr-result
      (restore result)            ; car-result
      (restore continue)
      (assign result (op +) (reg temp) (reg result))
      (goto (reg continue))

    count-done
      )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; b)
(define (count-leaves-b tree)
  (define (count-iter tree n)
    (cond ((null? tree) n)
          ((not (pair? tree)) (+ n 1))
          (else (count-iter (cdr tree)
                            (count-iter (car tree) n)))))
  (count-iter tree 0))

(define count-leaves-machine-b
  (make-machine
    '(tree result continue)
    (list (list 'null? null?)
          (list 'pair? pair?) 
          (list 'car car) 
          (list 'cdr cdr) 
          (list '+ +))
    '(
      (assign result (const 0))
      (assign continue (label count-done))

    count-loop
      (test (op null?) (reg tree))
      (branch (label null-tree))

      (test (op pair?) (reg tree))
      (branch (label count-car))

      ;; (not (pair? tree))
      (assign result (op +) (reg result) (const 1))
      (goto (reg continue))

    null-tree
      (goto (reg continue))

    count-car
      (save continue)
      (save tree)

      (assign tree (op car) (reg tree))
      (assign continue (label count-cdr))
      (goto (label count-loop))

    count-cdr
      (restore tree)

      (assign tree (op cdr) (reg tree))
      (assign continue (label after-count))
      (goto (label count-loop))

    after-count
      (restore continue)
      (goto (reg continue))

    count-done
      )))

5.22

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_22.scm

(define (append x y)
  (if (null? x)
      y 
      (cons (car x) (append (cdr x) y))))

(define append-machine
  (make-machine
    '(x y result continue)
    (list (list 'null? null?)
          (list 'car car) 
          (list 'cdr cdr) 
          (list 'cons cons))
    '(
      (assign continue (label append-done))
    append-loop
      (test (op null?) (reg x))
      (branch (label null-x))

      (save continue)
      (save x)

      (assign continue (label after-append-cdr))
      (assign x (op cdr) (reg x))
      (goto (label append-loop))

    after-append-cdr
      (restore x)
      (restore continue)
      (assign x (op car) (reg x))
      (assign result (op cons) (reg x) (reg result))
      (goto (reg continue))

    null-x
      (assign result (reg y))
      (goto (reg continue))

    append-done
      )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (append! x y)
  (set-cdr! (last-pair x) y)
  x)

(define (last-pair x)
  (if (null? (cdr x))
      x 
      (last-pair (cdr x))))

(define append!-machine
  (make-machine
    '(x y result cdr-x iter-x)
    (list (list 'null? null?)
          (list 'cdr cdr) 
          (list 'set-cdr! set-cdr!))
    '(
      (assign iter-x (reg x))

    loop
      (assign cdr-x (op cdr) (reg iter-x))
      (test (op null?) (reg cdr-x))
      (branch (label do-append))

      (assign iter-x (reg cdr-x))
      (goto (label loop))

    do-append
      (perform (op set-cdr!) (reg iter-x) (reg y))
      (assign result (reg x))
      )))

5.23

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_23.md
我们实现 cond 和 let、let* 语法。其中

练习 4.6 已实现了 let->combination。
练习 4.7 已实现了 let*->nested-lets。
这些可以作为求值器的基础过程。在 ch5-eceval.scm 的基础上修改。注册基础过程

(list 'cond? cond?)
(list 'cond->if cond->if)
(list 'let? let?)
(list 'let->combination let->combination)
(list 'let*? let*?)
(list 'let*->nested-lets let*->nested-lets)

机器指令中 eval-dispatch 标签添加

eval-dispatch
  ...
  (test (op cond?) (reg exp))
  (branch (label ev-cond))
  (test (op let?) (reg exp))
  (branch (label ev-let))
  (test (op let*?) (reg exp))
  (branch (label ev-let*))
  (test (op lambda?) (reg exp))
  ...
ev-cond
  (assign exp (op cond->if) (reg exp))
  (goto (label eval-dispatch))
ev-let 
  (assign exp (op let->combination) (reg exp))
  (goto (label eval-dispatch))
ev-let*
  (assign exp (op let*->nested-lets) (reg exp))
  (goto (label eval-dispatch))

5.24

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_24.md
参考 练习 4.5 中的 b)，我们先将 cond 实现为 Scheme 代码

(define (eval-cond-clauses clauses env)
  (if (null? clauses)
      false
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-else-clause? first)
            (if (null? rest)
                (eval-sequence (cond-actions first) env)
                (error "ELSE clause isn't last -- EVAL-COND" clauses))
            (let ((predicate-val (eval (cond-predicate first) env)))
              (if (true? predicate-val)
                  (eval-sequence (cond-actions first) env)
                  (eval-cond-clauses rest env))))))

(define (eval-cond exp env)
  (eval-cond-clauses (cond-clauses exp) env))
 ```
接下来手动将其翻译成求值器指令
```scheme
ev-cond
  (assign exp (op cond-clauses) (reg exp))
ev-cond-clauses
  (test (op null?) (reg exp))
  (branch (label ev-cond-null))

  (assign unev (op car) (reg exp))  ; first
  (assign exp (op cdr) (reg exp))   ; rest

  (test (op cond-else-clause?) (reg unev))
  (branch (label ev-cond-else))

  (save env)
  (save continue)
  (save exp)
  (save unev)
  (assign exp (op cond-predicate) (reg unev))
  (assign continue (label ev-cond-else-decide))
  (goto (label eval-dispatch))
ev-cond-else-decide
  (restore unev)
  (restore exp)
  (restore continue)
  (restore env)
  (test (op true?) (reg val))
  (branch (label ev-cond-sequence))
  (goto (label ev-cond-clauses))  
ev-cond-else
  (test (op null?) (reg exp))
  (branch (label ev-cond-sequence))
  (goto (label unknown-expression-type))
ev-cond-sequence
  (assign unev (op cond-actions) (reg unev))
  (save continue)
  (goto (label ev-sequence))
ev-cond-null
  (assign val (const false))
  (goto (reg continue))

5.25

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_25.md

(define (delay-it exp env) (list 'thunk exp env))
(define (thunk? obj) (tagged-list? obj 'thunk))
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define eceval-operations
  (list
    ;;primitive Scheme operations
    (list 'read read)

    ;;operations in syntax.scm
    (list 'self-evaluating? self-evaluating?)
    (list 'quoted? quoted?)
    (list 'text-of-quotation text-of-quotation)
    (list 'variable? variable?)
    (list 'assignment? assignment?)
    (list 'assignment-variable assignment-variable)
    (list 'assignment-value assignment-value)
    (list 'definition? definition?)
    (list 'definition-variable definition-variable)
    (list 'definition-value definition-value)
    (list 'lambda? lambda?)
    (list 'lambda-parameters lambda-parameters)
    (list 'lambda-body lambda-body)
    (list 'if? if?)
    (list 'if-predicate if-predicate)
    (list 'if-consequent if-consequent)
    (list 'if-alternative if-alternative)
    (list 'begin? begin?)
    (list 'begin-actions begin-actions)
    (list 'last-exp? last-exp?)
    (list 'first-exp first-exp)
    (list 'rest-exps rest-exps)
    (list 'application? application?)
    (list 'operator operator)
    (list 'operands operands)
    (list 'no-operands? no-operands?)
    (list 'first-operand first-operand)
    (list 'rest-operands rest-operands)

    ;;operations in eceval-support.scm
    (list 'true? true?)
    (list 'make-procedure make-procedure)
    (list 'compound-procedure? compound-procedure?)
    (list 'procedure-parameters procedure-parameters)
    (list 'procedure-body procedure-body)
    (list 'procedure-environment procedure-environment)
    (list 'extend-environment extend-environment)
    (list 'lookup-variable-value lookup-variable-value)
    (list 'set-variable-value! set-variable-value!)
    (list 'define-variable! define-variable!)
    (list 'primitive-procedure? primitive-procedure?)
    (list 'apply-primitive-procedure apply-primitive-procedure)
    (list 'prompt-for-input prompt-for-input)
    (list 'announce-output announce-output)
    (list 'user-print user-print)
    (list 'empty-arglist empty-arglist)
    (list 'adjoin-arg adjoin-arg)
    (list 'last-operand? last-operand?)
    (list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine
    (list 'get-global-environment get-global-environment)

    ;; 练习 5.25 改动
    (list 'delay-it delay-it)
    (list 'thunk? thunk?)
    (list 'thunk-env thunk-env)
    (list 'thunk-exp thunk-exp)
    (list 'print display)
))

(define eceval
  (make-machine
   '(exp env val proc argl continue unev)
   eceval-operations
  '(
;;SECTION 5.4.4
read-eval-print-loop
  (perform (op initialize-stack))
  (perform
   (op prompt-for-input) (const ";;; EC-Eval input:"))
  (assign exp (op read))
  (assign env (op get-global-environment))
  (assign continue (label print-result))
  (goto (label actual-value))
print-result
;;**following instruction optional -- if use it, need monitored stack
  (perform (op print-stack-statistics))
  (perform
   (op announce-output) (const ";;; EC-Eval value:"))
  (perform (op user-print) (reg val))
  (goto (label read-eval-print-loop))

unknown-expression-type
  (assign val (const unknown-expression-type-error))
  (goto (label signal-error))

unknown-procedure-type
  (restore continue)
  (assign val (const unknown-procedure-type-error))
  (goto (label signal-error))

signal-error
  (perform (op user-print) (reg val))
  (goto (label read-eval-print-loop))

;;SECTION 5.4.1
eval-dispatch
  (test (op self-evaluating?) (reg exp))
  (branch (label ev-self-eval))
  (test (op variable?) (reg exp))
  (branch (label ev-variable))
  (test (op quoted?) (reg exp))
  (branch (label ev-quoted))
  (test (op assignment?) (reg exp))
  (branch (label ev-assignment))
  (test (op definition?) (reg exp))
  (branch (label ev-definition))
  (test (op if?) (reg exp))
  (branch (label ev-if))
  (test (op lambda?) (reg exp))
  (branch (label ev-lambda))
  (test (op begin?) (reg exp))
  (branch (label ev-begin))
  (test (op application?) (reg exp))
  (branch (label ev-application))
  (goto (label unknown-expression-type))

ev-self-eval
  (assign val (reg exp))
  (goto (reg continue))
ev-variable
  (assign val (op lookup-variable-value) (reg exp) (reg env))
  (goto (reg continue))
ev-quoted
  (assign val (op text-of-quotation) (reg exp))
  (goto (reg continue))
ev-lambda
  (assign unev (op lambda-parameters) (reg exp))
  (assign exp (op lambda-body) (reg exp))
  (assign val (op make-procedure)
              (reg unev) (reg exp) (reg env))
  (goto (reg continue))

;; 练习 5.25 改动  
ev-application
  (save continue)
  (save env)
  (assign unev (op operands) (reg exp))
  (save unev)
  (assign exp (op operator) (reg exp))
  (assign continue (label ev-appl-did-operator))
  (goto (label actual-value))
ev-appl-did-operator
  (restore unev)
  (restore env)
  (assign proc (reg val))
  (goto (label apply-dispatch))

apply-dispatch
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-apply))
  (test (op compound-procedure?) (reg proc))
  (branch (label compound-apply))
  (goto (label unknown-procedure-type))
primitive-apply
  (save proc)
  (assign proc (label actual-value))
  (assign continue (label primitive-apply-after-args))
  (goto (label ev-map-operands))
primitive-apply-after-args
  (restore proc)
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (restore continue)
  (goto (reg continue))
compound-apply
  (save continue)
  (save proc)
  (assign proc (label delay-it))
  (assign continue (label compound-apply-after-args))
  (goto (label ev-map-operands))
compound-apply-after-args
  (restore proc)
  (restore continue)
  (assign unev (op procedure-parameters) (reg proc))
  (assign env (op procedure-environment) (reg proc))
  (assign env (op extend-environment) (reg unev) (reg argl) (reg env))
  (assign unev (op procedure-body) (reg proc))
  (goto (label ev-sequence))

;; input: exp、env
;; ouput: val
actual-value
  (save continue)
  (assign continue (label actual-value-after-eval))
  (goto (label eval-dispatch))
actual-value-after-eval
  (restore continue)
  (assign exp (reg val))
  (goto (label force-it))

;; 为了简化实现，这里的 force-it 没有记忆功能  
force-it
  (test (op thunk?) (reg exp))
  (branch (label force-it-thunk))
  (goto (reg continue))
force-it-thunk
  (assign env (op thunk-env) (reg exp))
  (assign exp (op thunk-exp) (reg exp))
  (goto (label actual-value))  

;; input: exp, env
;; output: val
delay-it
  (assign val (op delay-it) (reg exp) (reg env))
  (goto (reg continue))

;; input: unev, proc, env
;; ouput: argl
ev-map-operands
  (assign argl (op empty-arglist))

ev-map-operand-loop  
  (test (op no-operands?) (reg unev))
  (branch (label ev-map-no-args))

  (save continue)
  (save proc)
  (save argl)
  (save env)
  (save unev)

  (assign exp (op first-operand) (reg unev))
  (assign continue (label ev-map-accumulate-arg))
  (goto (reg proc))

ev-map-accumulate-arg
  (restore unev)
  (restore env)
  (restore argl)
  (restore proc)
  (restore continue)

  (assign argl (op adjoin-arg) (reg val) (reg argl))
  (assign unev (op rest-operands) (reg unev))
  (goto (label ev-map-operand-loop))

ev-map-no-args
  (goto (reg continue))


;;;SECTION 5.4.2
ev-begin
  (assign unev (op begin-actions) (reg exp))
  (save continue)
  (goto (label ev-sequence))

ev-sequence
  (assign exp (op first-exp) (reg unev))
  (test (op last-exp?) (reg unev))
  (branch (label ev-sequence-last-exp))
  (save unev)
  (save env)
  (assign continue (label ev-sequence-continue))
  (goto (label eval-dispatch))
ev-sequence-continue
  (restore env)
  (restore unev)
  (assign unev (op rest-exps) (reg unev))
  (goto (label ev-sequence))
ev-sequence-last-exp
  (restore continue)
  (goto (label eval-dispatch))

;;;SECTION 5.4.3

ev-if
  (save exp)
  (save env)
  (save continue)
  (assign continue (label ev-if-decide))
  (assign exp (op if-predicate) (reg exp))
  (goto (label actual-value))
ev-if-decide
  (restore continue)
  (restore env)
  (restore exp)
  (test (op true?) (reg val))
  (branch (label ev-if-consequent))
ev-if-alternative
  (assign exp (op if-alternative) (reg exp))
  (goto (label eval-dispatch))
ev-if-consequent
  (assign exp (op if-consequent) (reg exp))
  (goto (label eval-dispatch))

ev-assignment
  (assign unev (op assignment-variable) (reg exp))
  (save unev)
  (assign exp (op assignment-value) (reg exp))
  (save env)
  (save continue)
  (assign continue (label ev-assignment-1))
  (goto (label eval-dispatch))
ev-assignment-1
  (restore continue)
  (restore env)
  (restore unev)
  (perform
   (op set-variable-value!) (reg unev) (reg val) (reg env))
  (assign val (const ok))
  (goto (reg continue))

ev-definition
  (assign unev (op definition-variable) (reg exp))
  (save unev)
  (assign exp (op definition-value) (reg exp))
  (save env)
  (save continue)
  (assign continue (label ev-definition-1))
  (goto (label eval-dispatch))
ev-definition-1
  (restore continue)
  (restore env)
  (restore unev)
  (perform
   (op define-variable!) (reg unev) (reg val) (reg env))
  (assign val (const ok))
  (goto (reg continue))

   )))

参考第 4 章的 惰性求值器, 需要增改：
改动标记 ev-application， 对应eval函数中的 application? 分支。
改动标记apply-dispatch， 对应apply 过程。
增加标记 actual-value，对应 actual-value 过程。
增加标记 ev-map-operands, 对应 list-of-arg-values 和 list-of-delayed-args。
原始代码中 list-of-arg-values 和 list-of-delayed-args 可以改写成如下样子

(define (map-operands exps proc env)
  (if (no-operands? exps)
      '()
      (cons (proc (first-operand exps) env)
            (map-operands (rest-operands exps) proc env))))

(define (list-of-arg-values exps env)
  (map-operands exps actual-value env))

(define (list-of-delayed-args exps env)
  (map-operands exps delay-it env))

5.26

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_26.md

n	1	2	3	4	5	6	7	8	9	10
maximum-depth	10	10	10	10	10	10	10	10	10	10
total-pushes	64	99	134	169	204	239	274	309	344	379

a)可以看出，最大堆栈深度 maximum-depth 跟 n 无关，都为 10。
b)
从表格中，分析 total-pushes 的数值，可以看出

99 - 64 = 35
134 - 99 = 35
169 - 134 = 35
...

于是 total-pushes 的数值为等差数列，两项间相差 35。可以推算出
total-pushes = 64 + 35 * (n - 1) = 35 * n + 29

5.27

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_27.md

maximum-depth = 8 + (n - 1) * 5 = 5 * n + 3
total-pushes = 16 + 32 * (n - 1) = 32 * n - 16

5.28

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_28.md

没有尾递归优化时，阶乘的统计结果如下：

	maximum-depth	total-pushes
递归的阶乘（练习 5.27 的代码）	8 * n + 3	34 * n – 16
迭代的阶乘（练习 5.26 的代码）	3 * n + 14	37 * n + 33

对比 练习 5.27 中的结果，原始的 ev-sequence，有尾递归优化时，阶乘的统计结果如下：

	maximum-depth	total-pushes
递归的阶乘（练习 5.27 的代码）	5 * n + 3	32 * n – 16
迭代的阶乘（练习 5.26 的代码）	10	35 * n + 29

可见，有尾递归优化时，堆栈的利用空间会有很大的改善，特别是对于迭代过程。

5.29

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_29.md

n	2	3	4	5	6	7	8	9	10
maximum-depth	13	18	23	28	33	38	43	48	53
total-pushes	72	128	240	408	688	1136	1864	3040	4944
Fib(n)	1	2	3	5	8	13	21	34	55

a)从表格可以看出，maximum-depth 的值是个等差数列，两项间相差 5，可以推算出
maximum-depth = 13 + (n - 2) * 5 = 5 * n + 3
其中 n >= 2。
b)为了方便表示，我们用 S(n) 来表示 total-pushes，其中 n >= 2。于是有

S(2) = 72
S(3) = 128
S(4) = 240
S(5) = 408
S(6) = 688
....

根据上面的数值，可以推算出
S(n) = S(n - 1) + S(n - 2) + 40 ; n >= 4
比较 S(n) 和 Fib(n+1) 的数值

n	2	3	4	5	6	7	8	9
S(n)	72	128	240	408	688	1136	1864	3040
Fib(n+1)	2	3	5	8	13	21	34	55

根据题目提示，两者是线性关系。列个方程，可以求出
S(n) = 56 * Fib(n+1) - 40 ; n >= 2
c)
现在来证明 b) 中 S(n) 和 Fib(n+1) 的线性关系。采用数学归纳法。
首先 n = 2 和 n = 3 时候，基础情况下，关系成立。

S(2) = 56 * Fib(3) - 40 = 56 * 2 - 40 = 72
S(3) = 56 * Fib(4) - 40 = 56 * 3 - 40 = 128

于是递归情况下，有

S(n) = S(n - 1) + S(n - 2) + 40
=> S(n) = [56 * Fib(n) - 40] + [56 * Fib(n - 1) - 40] + 40
=> S(n) = 56 * [Fib(n) + Fib(n - 1)] - 40
=> S(n) = 56 * Fib(n+1) - 40

所以，在递归情况下，关系也成立。因而下面线性关系成立。
S(n) = 56 * Fib(n+1) - 40 ; n >= 2

5.30

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_30.md

a)

(define (error-code info) (cons '*error-code* info))
(define (error-code? obj) (and (pair? obj) (eq? (car obj) '*error-code*)))
(define (error-code-info obj) (cdr obj))

(define (lookup-variable-value-e var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (car vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error-code (list "Unbound variable" var))
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

...

(define eceval-operations
  (list
    ...
    (list 'error-code? error-code?)
    (list 'error-code-info error-code-info)
    (list 'lookup-variable-value-e lookup-variable-value-e)
    ))  

模拟器指令修改如下

error-happen
  (assign val (op error-code-info) (reg val))
  (goto (label signal-error))  

signal-error
  (perform (op user-print) (reg val))
  (goto (label read-eval-print-loop))

...

ev-variable
  (assign val (op lookup-variable-value-e) (reg exp) (reg env))
  (test (op error-code?) (reg val))
  (branch (label error-happen))
  (goto (reg continue)) 
b)

为 car, cdr, / 这个三个基本过程添加错误处理

(define (car-e pair)
  (if (pair? pair)
      (car pair)
      (error-code "expected pair? -- CAR")))

(define (cdr-e pair)
  (if (pair? pair)
      (car pair)
      (error-code "expected pair? -- CDR")))

(define (div-e a b)
  (if (zero? b)
      (error-code "zero division error")
      (/ a b)))

...

(define primitive-procedures
  (list (list 'car car-e)
        (list 'cdr cdr-e)
        (list '/ div-e)
        ...
        ))

模拟器指令修改如下

primitive-apply
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (test (op error-code?) (reg val))
  (branch (label error-happen))
  (restore continue)
  (goto (reg continue))

5.31

5.32

5.33

5.34

5.35

5.36

5.37

5.38

5.39

5.40

5.41

5.42

5.43

5.44

5.45

5.46

5.47

5.48

5.49

5.50