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))
</code></pre>

<h2>5.25</h2>

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

<pre><code class="language-scheme line-numbers">(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))

   )))
</code></pre>

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

<pre><code class="language-scheme line-numbers">(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))
</code></pre>

<h2>5.26</h2>

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

<table>
<thead>
<tr>
  <th>n</th>
  <th>1</th>
  <th>2</th>
  <th>3</th>
  <th>4</th>
  <th>5</th>
  <th>6</th>
  <th>7</th>
  <th>8</th>
  <th>9</th>
  <th>10</th>
</tr>
</thead>
<tbody>
<tr>
  <td>maximum-depth</td>
  <td>10</td>
  <td>10</td>
  <td>10</td>
  <td>10</td>
  <td>10</td>
  <td>10</td>
  <td>10</td>
  <td>10</td>
  <td>10</td>
  <td>10</td>
</tr>
<tr>
  <td>total-pushes</td>
  <td>64</td>
  <td>99</td>
  <td>134</td>
  <td>169</td>
  <td>204</td>
  <td>239</td>
  <td>274</td>
  <td>309</td>
  <td>344</td>
  <td>379</td>
</tr>
</tbody>
</table>

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

<pre><code class="language-scheme line-numbers">99 - 64 = 35
134 - 99 = 35
169 - 134 = 35
...
</code></pre>

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

<h2>5.27</h2>

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

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

<h2>5.28</h2>

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

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

<table>
<thead>
<tr>
  <th></th>
  <th>maximum-depth</th>
  <th>total-pushes</th>
</tr>
</thead>
<tbody>
<tr>
  <td>递归的阶乘（练习 5.27 的代码）</td>
  <td>8 * n + 3</td>
  <td>34 * n - 16</td>
</tr>
<tr>
  <td>迭代的阶乘（练习 5.26 的代码）</td>
  <td>3 * n + 14</td>
  <td>37 * n + 33</td>
</tr>
</tbody>
</table>

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

<table>
<thead>
<tr>
  <th></th>
  <th>maximum-depth</th>
  <th>total-pushes</th>
</tr>
</thead>
<tbody>
<tr>
  <td>递归的阶乘（练习 5.27 的代码）</td>
  <td>5 * n + 3</td>
  <td>32 * n - 16</td>
</tr>
<tr>
  <td>迭代的阶乘（练习 5.26 的代码）</td>
  <td>10</td>
  <td>35 * n + 29</td>
</tr>
</tbody>
</table>

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

<h2>5.29</h2>

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

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

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

<pre><code class="language-scheme line-numbers">S(2) = 72
S(3) = 128
S(4) = 240
S(5) = 408
S(6) = 688
....
</code></pre>

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

<table>
<thead>
<tr>
  <th>n</th>
  <th>2</th>
  <th>3</th>
  <th>4</th>
  <th>5</th>
  <th>6</th>
  <th>7</th>
  <th>8</th>
  <th>9</th>
</tr>
</thead>
<tbody>
<tr>
  <td>S(n)</td>
  <td>72</td>
  <td>128</td>
  <td>240</td>
  <td>408</td>
  <td>688</td>
  <td>1136</td>
  <td>1864</td>
  <td>3040</td>
</tr>
<tr>
  <td>Fib(n+1)</td>
  <td>2</td>
  <td>3</td>
  <td>5</td>
  <td>8</td>
  <td>13</td>
  <td>21</td>
  <td>34</td>
  <td>55</td>
</tr>
</tbody>
</table>

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

<pre><code class="language-scheme line-numbers">S(2) = 56 * Fib(3) - 40 = 56 * 2 - 40 = 72
S(3) = 56 * Fib(4) - 40 = 56 * 3 - 40 = 128
</code></pre>

于是递归情况下，有

<pre><code class="language-scheme line-numbers">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
</code></pre>

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

<h2>5.30</h2>

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

a)

<pre><code class="language-scheme line-numbers">(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)
    ))  
</code></pre>

模拟器指令修改如下

<pre><code class="language-scheme line-numbers">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)
</code></pre>

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

<pre><code class="language-scheme line-numbers">(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)
        ...
        ))
</code></pre>

模拟器指令修改如下

<pre><code class="language-scheme line-numbers">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))
</code></pre>

<h2>5.31</h2>

a和b都不需要save和restore
c:若求值顺序是从左往右，需要proc argl env
若为从右往左，需要proc，argl
d的话需要proc和argl

<h2>5.32</h2>

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_32.md
新增 <code>ev-simple-application</code> 标记

<pre><code class="language-scheme line-numbers">ev-simple-application
  (save continue)
  (assign unev (op operands) (reg exp))
  (assign proc (op operator) (reg exp))
  (assign proc (op lookup-variable-value) (reg proc) (reg env))
  (assign argl (op empty-arglist))
  (test (op no-operands?) (reg unev))
  (branch (label apply-dispatch))
  (save proc)
  (goto (label ev-appl-operand-loop))
 ```
我觉得 Alyssa P.Hacker 说得不对，求值器无论识别多少特殊情况，也不能完全剔除编译器的优势。
首先，假如求值器考虑的特殊情况越多，求值器就会变得越复杂，越难以维护。
其次，求值器要识别特殊情况，必然需要做判断，并且每次解释代码的时候都需要做判断。做判断本身也需要时间。假如判断本身过多，对于非特殊的情况，反而会拖慢运行速度。
而编译器只需要做一次编译，就可以多次运行。并且编译和执行阶段可以分开。预先编译，对特殊情况做了优化，真正执行时就不用做过多判断，速度就可提升。
## 5.33
```scheme
'((env)
  (val)
  ((assign val (op make-compiled-procedure) (label entry1) (reg env))
   (goto (label after-lambda2))
   entry1
   (assign env (op compiled-procedure-env) (reg proc))
   (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
   (save continue)
   (save env)
   (assign proc (op lookup-variable-value) (const =) (reg env))
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch6))
   compiled-branch7
   (assign continue (label after-call8))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch6
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call8
   (restore env)
   (restore continue)
   (test (op false?) (reg val))
   (branch (label false-branch4))
   true-branch3
   (assign val (const 1))
   (goto (reg continue))
   false-branch4
   (assign proc (op lookup-variable-value) (const *) (reg env))
   (save continue)
   (save proc)
   (save env)
   (assign proc (op lookup-variable-value) (const factorial-atl) (reg env))
   (save proc)
   (assign proc (op lookup-variable-value) (const -) (reg env))
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch9))
   compiled-branch10
   (assign continue (label after-call11))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch9
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call11
   (assign argl (op list) (reg val))
   (restore proc)
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch12))
   compiled-branch13
   (assign continue (label after-call14))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch12
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call14
   (assign argl (op list) (reg val))
   (restore env)
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (restore proc)
   (restore continue)
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch15))
   compiled-branch16
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch15
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   (goto (reg continue))
   after-call17
   after-if5
   after-lambda2
   (perform (op define-variable!) (const factorial-atl) (reg val) (reg env))
   (assign val (const ok))))

编译 factorial 的乘法表达式时，需要保存恢复 argl，并不需要保存恢复 env。
编译 factorial-atl 的乘法表达式时，需要保存恢复 env，并不需要保存恢复 argl。
两者保存恢复的寄存器数目相同，效率一样。

5.34

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

(define compiled-code
  '(
    ; 定义 factorial 过程
    ((assign val (op make-compiled-procedure) (label entry1) (reg env))
     (goto (label after-lambda2))

     ;; factorial 入口
   entry1
     (assign env (op compiled-procedure-env) (reg proc))
     (assign env (op extend-environment) (const (n)) (reg argl) (reg env))

     ; 定义 iter 过程
     (assign val (op make-compiled-procedure) (label entry3) (reg env))
     (goto (label after-lambda4))

     ; iter 入口
   entry3
     (assign env (op compiled-procedure-env) (reg proc))
     (assign env (op extend-environment) (const (product counter)) (reg argl) (reg env))

     (save continue)
     (save env)

     ; (> counter n)
     (assign proc (op lookup-variable-value) (const >) (reg env))
     (assign val (op lookup-variable-value) (const n) (reg env))
     (assign argl (op list) (reg val))
     (assign val (op lookup-variable-value) (const counter) (reg env))
     (assign argl (op cons) (reg val) (reg argl))
     (test (op primitive-procedure?) (reg proc))
     (branch (label primitive-branch8))
   compiled-branch9
     (assign continue (label after-call10))
     (assign val (op compiled-procedure-entry) (reg proc))
     (goto (reg val))
   primitive-branch8
     (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call10
     (restore env)
     (restore continue)

     ; 判断 (if (> counter n)
     (test (op false?) (reg val))
     (branch (label false-branch6))

   true-branch5
     ; product
     (assign val (op lookup-variable-value) (const product) (reg env))
     (goto (reg continue))

   false-branch6
      ; 查找 iter 运算符
     (assign proc (op lookup-variable-value) (const iter) (reg env))
     (save continue)

     (save proc)
     (save env)

     ; (+ counter 1)
     (assign proc (op lookup-variable-value) (const +) (reg env))
     (assign val (const 1))
     (assign argl (op list) (reg val))
     (assign val (op lookup-variable-value) (const counter) (reg env))
     (assign argl (op cons) (reg val) (reg argl))
     (test (op primitive-procedure?) (reg proc))
     (branch (label primitive-branch14))
   compiled-branch15
     (assign continue (label after-call16))
     (assign val (op compiled-procedure-entry) (reg proc))
     (goto (reg val))
   primitive-branch14
     (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call16

     ; argl 收集第一个参数
     (assign argl (op list) (reg val))
     (restore env)
     (save argl)

     ; (* counter product)
     (assign proc (op lookup-variable-value) (const *) (reg env))
     (assign val (op lookup-variable-value) (const product) (reg env))
     (assign argl (op list) (reg val))
     (assign val (op lookup-variable-value) (const counter) (reg env))
     (assign argl (op cons) (reg val) (reg argl))
     (test (op primitive-procedure?) (reg proc))
     (branch (label primitive-branch11))
   compiled-branch12
     (assign continue (label after-call13))
     (assign val (op compiled-procedure-entry) (reg proc))
     (goto (reg val))
   primitive-branch11
     (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call13
     (restore argl)

     ; argl 收集第二个参数
     (assign argl (op cons) (reg val) (reg argl))
     (restore proc)
     (restore continue)

     ; 尾递归调用 (iter (* counter product) (+ counter 1))))，
     ; 注意这里设置好 proc 和 argl 后，直接跳转，并不用将寄存器保存到堆栈中。
     ; 堆栈只使用常量空间
     (test (op primitive-procedure?) (reg proc))
     (branch (label primitive-branch17))
   compiled-branch18
     (assign val (op compiled-procedure-entry) (reg proc))
     (goto (reg val))
   primitive-branch17
     (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
     (goto (reg continue))
   after-call19
   after-if7

   after-lambda4
      ; (define (iter xx)) 的最后，设置名字
     (perform (op define-variable!) (const iter) (reg val) (reg env))
     (assign val (const ok))

     ; 调用 (iter 1)
     (assign proc (op lookup-variable-value) (const iter) (reg env))
     (assign val (const 1))
     (assign argl (op list) (reg val))
     (assign val (const 1))
     (assign argl (op cons) (reg val) (reg argl))
     (test (op primitive-procedure?) (reg proc))
     (branch (label primitive-branch20))
   compiled-branch21
     (assign val (op compiled-procedure-entry) (reg proc))
     (goto (reg val))
   primitive-branch20
     (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
     (goto (reg continue))
     after-call22

   after-lambda2
      ; (define (factorial xx)) 的最后，设置名字
     (perform (op define-variable!) (const factorial) (reg val) (reg env))
     (assign val (const ok)))))

5.35

(compile
  '(define (f x)
     (+ x (g (+ x 2)))
     )
  'val
  'next)

5.36

求值顺序是从右到左,construct-arglist这一过程决定了顺序，
改为这个：

(define (construct-arglist operand-codes)
  (if (null? operand-codes)
      (make-instruction-sequence '() '(argl)
       '((assign argl (const ()))))
      (let ((code-to-get-last-arg
             (append-instruction-sequences
              (car operand-codes)
              (make-instruction-sequence '(val) '(argl)
               '((assign argl (op list) (reg val)))))))
        (if (null? (cdr operand-codes))
            code-to-get-last-arg
            (preserving '(env)
             code-to-get-last-arg
             (code-to-get-rest-args
              (cdr operand-codes)))))))

(define (code-to-get-rest-args operand-codes)
  (let ((code-for-next-arg
         (preserving '(argl)
          (car operand-codes)
          (make-instruction-sequence '(val argl) '(argl)
           '((assign argl
              (op adjoin-arg) (reg val) (reg argl)))))))
    (if (null? (cdr operand-codes))
        code-for-next-arg
        (preserving '(env)
         code-for-next-arg
         (code-to-get-rest-args (cdr operand-codes))))))

在效率上无显著差别

5.37

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

(define (preserving regs seq1 seq2)
  (if (null? regs)
      (append-instruction-sequences seq1 seq2)
      (let ((first-reg (car regs)))
        (preserving (cdr regs)
          (make-instruction-sequence
            (list-union (list first-reg)
                        (registers-needed seq1))
            (list-difference (registers-modified seq1)
                             (list first-reg))
            (append `((save ,first-reg))
                    (statements seq1)
                    `((restore ,first-reg))))
          seq2))))
b)

修改后，我们编译表达式 (f 1 2)

(compile
  '(f 1 2)
  'val
  'next)

编译结果为:

'((save continue)     ; 不必要
  (save env)          ; 不必要
  (save continue)     ; 不必要
  (assign proc (op lookup-variable-value) (const f) (reg env))
  (restore continue)  ; 不必要
  (restore env)       ; 不必要
  (restore continue)  ; 不必要
  (save continue)     ; 不必要
  (save proc)         ; 不必要
  (save env)          ; 不必要
  (save continue)     ; 不必要
  (assign val (const 2))
  (restore continue)  ; 不必要
  (assign argl (op list) (reg val))
  (restore env)       ; 不必要
  (save argl)         ; 不必要
  (save continue)     ; 不必要
  (assign val (const 1))
  (restore continue)  ; 不必要
  (restore argl)      ; 不必要
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc)      ; 不必要
  (restore continue)  ; 不必要
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch1))
  compiled-branch2
  (assign continue (label after-call3))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch1
  (save continue)     ; 不必要
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (restore continue)  ; 不必要

5.38

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

(redefine (compile exp target linkage)
  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage))
        ((assignment? exp)
         (compile-assignment exp target linkage))
        ((definition? exp)
         (compile-definition exp target linkage))
        ((if? exp) (compile-if exp target linkage))
        ((lambda? exp) (compile-lambda exp target linkage))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target
                           linkage))
        ((cond? exp) (compile (cond->if exp) target linkage))
        ((open-code? exp) (compile-open-code exp target linkage))
        ((application? exp)
         (compile-application exp target linkage))
        (else
          (error "Unknown expression type -- COMPILE" exp))))

(define (open-code? exp)
  (and (pair? exp)
       (memq (operator exp) '(+ * - =))))

; a)
(define (spread-arguments operands)
  (let ((operand-code1 (compile (car operands) 'arg1 'next))
        (operand-code2 (compile (cadr operands) 'arg2 'next)))
    (preserving '(env arg1)
      operand-code1
      operand-code2)))

; b) 所有的基本过程 =、*、-、+ 都可共用这个函数。只处理两个参数。
(define (compile-open-code-two-args exp target linkage)
  (preserving '(env continue)
    (spread-arguments (operands exp))
    (end-with-linkage linkage
      (make-instruction-sequence '(arg1 arg2) (list target)
        `((assign ,target (op ,(operator exp)) (reg arg1) (reg arg2)))))))

; d) 
; 可处理多个参数, 主要为了 + *。比如 (+ 1 2 3 4) 会编译成
; ((assign arg1 (const 1))
;  (assign arg2 (const 2))
;  (assign arg1 (op +) (reg arg1) (reg arg2))
;  (assign arg2 (const 3))
;  (assign arg1 (op +) (reg arg1) (reg arg2))
;  (assign arg2 (const 4))
;  (assign val (op +) (reg arg1) (reg arg2)))
; 可重复使用 arg1 寄存器
(define (compile-open-code-many-args exp target linkage)
  (let ((proc (operator exp))
      (first-operand (car (operands exp)))
      (rest-operands (cdr (operands exp))))
    (preserving '(env continue)
      (compile first-operand 'arg1 'next)
      (compile-open-coded-rest-args proc rest-operands target linkage))))

(define (compile-open-coded-rest-args proc operands target linkage)
  (if (null? (cdr operands))
      (preserving '(arg1 continue)
        (compile (car operands) 'arg2 'next)
        (end-with-linkage linkage
          (make-instruction-sequence '(arg1 arg2) (list target)
            `((assign ,target (op ,proc) (reg arg1) (reg arg2))))))
      (preserving '(env continue)
        (preserving '(arg1)
          (compile (car operands) 'arg2 'next)
          (make-instruction-sequence '(arg1 arg2) '(arg1)
            `((assign arg1 (op ,proc) (reg arg1) (reg arg2)))))
        (compile-open-coded-rest-args proc (cdr operands) target linkage))))

(define (compile-open-code exp target linkage)
  (if (memq (operator exp) '(+ *))
      (compile-open-code-many-args exp target linkage)
      (compile-open-code-two-args exp target linkage)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; c) 
(
(pretty-print (compile
                '(define (factorial n)
                   (if (= n 1)
                       1
                       (* (factorial (- n 1)) n)))
                'val
                'next))

(pretty-print (compile
                '(begin
                   (+ 1 2 3 4)
                   (* x (f x) y (+ 1 2)))
                'val
                'next))

5.39

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

(define (env-frame-values env offset)
  (if (= offset 0)
      (frame-values (first-frame env))
      (env-frame-values (enclosing-environment env) (- offset 1))))

(define (list-ref lst offset)
  (if (= offset 0)
      (car lst)
      (list-ref (cdr lst) (- offset 1))))

(define (list-set! lst offset val)
  (if (= offset 0)
      (set-car! lst val)
      (list-set! (cdr lst) (- offset 1) val)))

(define (lexical-address-lookup address env)
  (if (eq? address '*unassigned*)
      (error "the address is unassigned -- LEXICAL-ADDRESS-LOOKUP" address)
      (list-ref (env-frame-values env (car address)) (cadr address))))

(define (lexical-address-set! address val env)
  (if (eq? address '*unassigned*)
      (error "the address is unassigned -- LEXICAL-ADDRESS-SET!" address)
      (list-set! (env-frame-values env (car address)) (cadr address) val)))

5.40

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

;; 主要修改 compile-lambda-body，扩展编译时环境。compile 过程也添加了 env 参数，传递下去。
(define (empty-compile-time-env) '())
(define (extend-compile-time-environment formals env) (cons formals env))

(define (compile exp target linkage env)
  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage env))
        ((assignment? exp)
         (compile-assignment exp target linkage env))
        ((definition? exp)
         (compile-definition exp target linkage env))
        ((if? exp) (compile-if exp target linkage env))
        ((lambda? exp) (compile-lambda exp target linkage env))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target
                           linkage
                           env))
        ((cond? exp) (compile (cond->if exp) target linkage env))
        ((application? exp)
         (compile-application exp target linkage env))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

(define (compile-variable exp target linkage env)
  (end-with-linkage linkage
   (make-instruction-sequence '(env) (list target)
    `((assign ,target
              (op lookup-variable-value)
              (const ,exp)
              (reg env))))))

(define (compile-assignment exp target linkage env)
  (let ((var (assignment-variable exp))
        (get-value-code
         (compile (assignment-value exp) 'val 'next env)))
    (end-with-linkage linkage
     (preserving '(env)
      get-value-code
      (make-instruction-sequence '(env val) (list target)
       `((perform (op set-variable-value!)
                  (const ,var)
                  (reg val)
                  (reg env))
         (assign ,target (const ok))))))))

(define (compile-definition exp target linkage env)
  (let ((var (definition-variable exp))
        (get-value-code
         (compile (definition-value exp) 'val 'next env)))
    (end-with-linkage linkage
     (preserving '(env)
      get-value-code
      (make-instruction-sequence '(env val) (list target)
       `((perform (op define-variable!)
                  (const ,var)
                  (reg val)
                  (reg env))
         (assign ,target (const ok))))))))


(define (compile-if exp target linkage env)
  (let ((t-branch (make-label 'true-branch))
        (f-branch (make-label 'false-branch))                    
        (after-if (make-label 'after-if)))
    (let ((consequent-linkage
           (if (eq? linkage 'next) after-if linkage)))
      (let ((p-code (compile (if-predicate exp) 'val 'next env))
            (c-code
             (compile
              (if-consequent exp) target consequent-linkage env))
            (a-code
             (compile (if-alternative exp) target linkage env)))
        (preserving '(env continue)
         p-code
         (append-instruction-sequences
          (make-instruction-sequence '(val) '()
           `((test (op false?) (reg val))
             (branch (label ,f-branch))))
          (parallel-instruction-sequences
           (append-instruction-sequences t-branch c-code)
           (append-instruction-sequences f-branch a-code))
          after-if))))))

;;; sequences
(define (compile-sequence seq target linkage env)
  (if (last-exp? seq)
      (compile (first-exp seq) target linkage env)
      (preserving '(env continue)
       (compile (first-exp seq) target 'next env)
       (compile-sequence (rest-exps seq) target linkage env))))

;;;lambda expressions
(define (compile-lambda exp target linkage env)
  (let ((proc-entry (make-label 'entry))
        (after-lambda (make-label 'after-lambda)))
    (let ((lambda-linkage
           (if (eq? linkage 'next) after-lambda linkage)))
      (append-instruction-sequences
       (tack-on-instruction-sequence
        (end-with-linkage lambda-linkage
         (make-instruction-sequence '(env) (list target)
          `((assign ,target
                    (op make-compiled-procedure)
                    (label ,proc-entry)
                    (reg env)))))
        (compile-lambda-body exp proc-entry env))
       after-lambda))))

;; 主要是这里，需要扩展编译时环境
(define (compile-lambda-body exp proc-entry env)
  (let ((formals (lambda-parameters exp)))
    (append-instruction-sequences
     (make-instruction-sequence '(env proc argl) '(env)
      `(,proc-entry
        (assign env (op compiled-procedure-env) (reg proc))
        (assign env
                (op extend-environment)
                (const ,formals)
                (reg argl)
                (reg env))))
     (compile-sequence (lambda-body exp) 
                       'val 
                       'return 
                       (extend-compile-time-environment formals env)))))

(define (compile-application exp target linkage env)
  (let ((proc-code (compile (operator exp) 'proc 'next env))
        (operand-codes
         (map (lambda (operand) (compile operand 'val 'next env))
              (operands exp))))
    (preserving '(env continue)
     proc-code
     (preserving '(proc continue)
      (construct-arglist operand-codes)
      (compile-procedure-call target linkage)))))

5.41

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

(define (find-variable var env)
  (define (position-in-frame var frame position)
    (if (null? frame)
        'not-found
        (if (eq? var (car frame))
            position
            (position-in-frame var (cdr frame) (+ position 1)))))

  (define (loop var env offset)
    (if (null? env)
        'not-found
        (let ((position (position-in-frame var (car env) 0)))
          (if (not (eq? position 'not-found))
              (list offset position)
              (loop var (cdr env) (+ offset 1))))))

  (loop var env 0))
  ```
## 5.42

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_42.scm
```scheme
(define (empty-compile-time-env) '())
(define (extend-compile-time-environment formals env) (cons formals env))

(define (compile exp target linkage env)
  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage env))
        ((assignment? exp)
         (compile-assignment exp target linkage env))
        ((definition? exp)
         (compile-definition exp target linkage env))
        ((if? exp) (compile-if exp target linkage env))
        ((lambda? exp) (compile-lambda exp target linkage env))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target
                           linkage
                           env))
        ((cond? exp) (compile (cond->if exp) target linkage env))
        ((application? exp)
         (compile-application exp target linkage env))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

;; 使用了 (op get-global-environment) 来获取全局环境
(define (compile-variable exp target linkage env)
  (let ((address (find-variable exp env)))
    (if (eq? address 'not-found)
        (end-with-linkage linkage
          (make-instruction-sequence '(env) (list target 'env)
            `((assign env (op get-global-environment))
              (assign ,target (op lookup-variable-value) (const ,exp) (reg env)))))

        (end-with-linkage linkage
          (make-instruction-sequence '(env) (list target)
            `((assign ,target (op lexical-address-lookup) (const ,address) (reg env))))))))

(define (compile-assignment exp target linkage env)
  (let ((var (assignment-variable exp))
        (get-value-code (compile (assignment-value exp) 'val 'next env)))
    (let ((address (find-variable var env)))
      (if (eq? address 'not-found)
          (end-with-linkage linkage
            (preserving '(env)
              get-value-code
              (make-instruction-sequence '(env val) (list target 'env)
                `((assign env (op get-global-environment))
                  (perform (op set-variable-value!) (const ,var) (reg val) (reg env))
                  (assign ,target (const ok))))))
          (end-with-linkage linkage
            (preserving '(env)
              get-value-code
              (make-instruction-sequence '(env val) (list target)
                `((perform (op lexical-address-set!) (const ,address) (reg val) (reg env))
                  (assign ,target (const ok))))))))))

(define (compile-definition exp target linkage env)
  (let ((var (definition-variable exp))
        (get-value-code
         (compile (definition-value exp) 'val 'next env)))
    (end-with-linkage linkage
     (preserving '(env)
      get-value-code
      (make-instruction-sequence '(env val) (list target)
       `((perform (op define-variable!)
                  (const ,var)
                  (reg val)
                  (reg env))
         (assign ,target (const ok))))))))


(define (compile-if exp target linkage env)
  (let ((t-branch (make-label 'true-branch))
        (f-branch (make-label 'false-branch))                    
        (after-if (make-label 'after-if)))
    (let ((consequent-linkage
           (if (eq? linkage 'next) after-if linkage)))
      (let ((p-code (compile (if-predicate exp) 'val 'next env))
            (c-code
             (compile
              (if-consequent exp) target consequent-linkage env))
            (a-code
             (compile (if-alternative exp) target linkage env)))
        (preserving '(env continue)
         p-code
         (append-instruction-sequences
          (make-instruction-sequence '(val) '()
           `((test (op false?) (reg val))
             (branch (label ,f-branch))))
          (parallel-instruction-sequences
           (append-instruction-sequences t-branch c-code)
           (append-instruction-sequences f-branch a-code))
          after-if))))))

;;; sequences
(define (compile-sequence seq target linkage env)
  (if (last-exp? seq)
      (compile (first-exp seq) target linkage env)
      (preserving '(env continue)
       (compile (first-exp seq) target 'next env)
       (compile-sequence (rest-exps seq) target linkage env))))

;;;lambda expressions
(define (compile-lambda exp target linkage env)
  (let ((proc-entry (make-label 'entry))
        (after-lambda (make-label 'after-lambda)))
    (let ((lambda-linkage
           (if (eq? linkage 'next) after-lambda linkage)))
      (append-instruction-sequences
       (tack-on-instruction-sequence
        (end-with-linkage lambda-linkage
         (make-instruction-sequence '(env) (list target)
          `((assign ,target
                    (op make-compiled-procedure)
                    (label ,proc-entry)
                    (reg env)))))
        (compile-lambda-body exp proc-entry env))
       after-lambda))))

(define (compile-lambda-body exp proc-entry env)
  (let ((formals (lambda-parameters exp)))
    (append-instruction-sequences
     (make-instruction-sequence '(env proc argl) '(env)
      `(,proc-entry
        (assign env (op compiled-procedure-env) (reg proc))
        (assign env
                (op extend-environment)
                (const ,formals)
                (reg argl)
                (reg env))))
     (compile-sequence (lambda-body exp) 
                       'val 
                       'return 
                       (extend-compile-time-environment formals env)))))

(define (compile-application exp target linkage env)
  (let ((proc-code (compile (operator exp) 'proc 'next env))
        (operand-codes
         (map (lambda (operand) (compile operand 'val 'next env))
              (operands exp))))
    (preserving '(env continue)
     proc-code
     (preserving '(proc continue)
      (construct-arglist operand-codes)
      (compile-procedure-call target linkage)))))
  ```
## 5.43
```scheme
(define (compile-lambda-body exp proc-entry env)
  (let ((formals (lambda-parameters exp)))
    (append-instruction-sequences
     (make-instruction-sequence '(env proc argl) '(env)
      `(,proc-entry
        (assign env (op compiled-procedure-env) (reg proc))
        (assign env
                (op extend-environment)
                (const ,formals)
                (reg argl)
                (reg env))))
     (compile-sequence (scan-out-defines (lambda-body exp))
                       'val 
                       'return 
                       (extend-compile-time-environment formals env)))))

5.44

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

(define (open-code? exp env)
  (and (pair? exp)
       (memq (operator exp) '(+ * - =))
       (eq? (find-variable (operator exp) env) 'not-found)))

(define (compile-open-code exp target linkage env)
  (let ((proc (operator exp))
      (first-operand (car (operands exp)))
      (rest-operands (cdr (operands exp))))
    (preserving '(env continue)
      (compile first-operand 'arg1 'next env)
      (compile-open-coded-rest-args proc rest-operands target linkage env))))

(define (compile-open-coded-rest-args proc operands target linkage env)
  (if (null? (cdr operands))
      (preserving '(arg1 continue)
        (compile (car operands) 'arg2 'next env)
        (end-with-linkage linkage
          (make-instruction-sequence '(arg1 arg2) (list target)
            `((assign ,target (op ,proc) (reg arg1) (reg arg2))))))
      (preserving '(env continue)
        (preserving '(arg1)
          (compile (car operands) 'arg2 'next env)
          (make-instruction-sequence '(arg1 arg2) '(arg1)
            `((assign arg1 (op ,proc) (reg arg1) (reg arg2)))))
        (compile-open-coded-rest-args proc (cdr operands) target linkage env))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(redefine (compile exp target linkage env)
  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage env))
        ((assignment? exp)
         (compile-assignment exp target linkage env))
        ((definition? exp)
         (compile-definition exp target linkage env))
        ((if? exp) (compile-if exp target linkage env))
        ((lambda? exp) (compile-lambda exp target linkage env))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target
                           linkage
                           env))
        ((cond? exp) (compile (cond->if exp) target linkage env))
        ((open-code? exp env) (compile-open-code exp target linkage env))
        ((let? exp) (compile (let->combination exp) target linkage env))
        ((application? exp)
         (compile-application exp target linkage env))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

5.45

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

n	1	2	3	4	5	6	7	8	9	10
total-pushes	7	13	19	25	31	37	43	49	55	61
maximum-depth	3	5	8	11	14	17	20	23	26	29

观察知道，n >= 2 时，total-pushes 和 maximum-depth 都是等差数列
total-pushes = 13 + (n - 2) * 6 = 6 * n + 1
maximum-depth = 5 + (n - 2) * 3 = 3 * n - 1
对比 练习 5.27 中的解释器版本。n 变大时，可忽略常数项，编译器和解释器的比率为：
total-pushes: (6 * n + 1) / (32 * n - 16) => 6/32 = 0.1875
maximum-depth: (3 * n - 1) / (5 * n + 3) => 3/5 = 0.6
对比 练习 5.14 中，手工打造的阶乘专用机器。n 变大时，编译器和专用机器的比率为：
total-pushes: (6 * n + 1) / (2 * n - 2) => 6/2 = 3
maximum-depth: (3 * n - 1) / (2 * n - 2) => 3/2 = 1.5
从上面的对比可知，手工打造的专用机器优于编译器版本，编译器版本优于解释器版本。
b)
要使编译器生成的代码跟手工版本接近。可以先应用 练习 5.38 的开放代码。这假设 + * – = 都是基本函数。
应用开放代码后，编译生成的阶乘代码在最后面，其堆栈利用率为
total-pushes = 2 * n + 3
maximum-depth = 2 * n - 2
已经跟手工打造的代码有点接近了。主要还有两点不同
手工打造的代码，n 和 factorial 直接存放在寄存器中。编译生成的代码，这两个数据放到了环境 env 中，有个查找环境的过程。
手工打造的代码，对 factorial 的递归调用是直接跳转。编译生成的代码，有一个查找 factorial，显式调用的过程。
我们可以根据上述两点，对编译器进行修改。
改进编译器的寄存器使用方式。优先将数据放到寄存器中，而不是放到环境中。
编译递归调用时，直接跳转到入口处。避免显式查找环境，再调用的过程。

5.46

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

n	2	3	4	5	6	7	8	9	10
maximum-depth	5	8	11	14	17	20	23	26	26
total-pushes	17	27	47	77	127	207	337	547	887
Fib(n+1)	2	3	5	8	13	21	34	55	–

maximum-depth = 5 + (n - 2) * 3 = 3 * n - 1
total-pushes = 10 * Fib(n+1) - 3
执行手工打造的专用 fib 机器, 得到 total-pushes 和 maximum-depth 的信息

n	2	3	4	5	6	7	8	9	10
maximum-depth	2	4	6	8	10	12	14	16	18
total-pushes	4	8	16	28	48	80	132	216	352
Fib(n+1)	2	3	5	8	13	21	34	55	–

maximum-depth = 2 + (n - 2) * 2 = 2 * n - 2
total-pushes = 4 * Fib(n+1) - 4
从 练习 5.29 得到，使用求值器解释运行 fib，其堆栈信息为
maximum-depth = 13 + (n - 2) * 5 = 5 * n + 3
total-pushes = 56 * Fib(n+1) - 40
对比堆栈操作的利用率。手工打造的 fib 机器优于编译，而编译版本优于解释执行。

5.47

(define (compile-procedure-call target linkage)
  (let ((primitive-branch (make-label 'primitive-branch))
        (compiled-branch (make-label 'compiled-branch))
        (compound-branch (make-label 'compound-branch))
        (after-call (make-label 'after-call)))
    (let ((compiled-linkage (if (eq? linkage 'next) after-call linkage)))
      (append-instruction-sequences
       (make-instruction-sequence '(proc) '()
        `((test (op primitive-procedure?) (reg proc))
          (branch (label ,primitive-branch))
          (test (op compound-procedure?) (reg proc))
          (branch (label ,compound-branch))))
       (parallel-instruction-sequences
        (append-instruction-sequences
         compiled-branch
         (compile-proc-appl target compiled-linkage))
        (parallel-instruction-sequences
          (append-instruction-sequences
           compound-branch
           (compile-compound-appl target compiled-linkage)) 
          (append-instruction-sequences
           primitive-branch
           (end-with-linkage linkage
            (make-instruction-sequence '(proc argl) (list target)
             `((assign ,target
                       (op apply-primitive-procedure)
                       (reg proc)
                       (reg argl))))))))
       after-call))))

(define (compile-compound-appl target linkage)
  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
       (make-instruction-sequence '(proc) all-regs
         `((assign continue (label ,linkage))
           (save continue)
           (goto (reg compapp)))))
      ((and (not (eq? target 'val))
            (not (eq? linkage 'return)))
       (let ((proc-return (make-label 'proc-return)))
         (make-instruction-sequence '(proc) all-regs
          `((assign continue (label ,proc-return))
            (save continue)
            (goto (reg compapp))
            ,proc-return
            (assign ,target (reg val))
            (goto (label ,linkage))))))
      ((and (eq? target 'val) (eq? linkage 'return))
       (make-instruction-sequence '(proc continue) all-regs
        '((save continue)
          (goto (reg compapp)))))
      ((and (not (eq? target 'val)) (eq? linkage 'return))
       (error "return linkage, target not val -- COMPILE"
              target))))

5.48

https://github.com/hjcapple/reading-sicp/blob/master/chapter_5/exercise_5_48.md
在原始 编译器-求值器 基础上，添加过程

(define (compile-scheme expression)
  (assemble (statements
              (compile expression 'val 'return))
            eceval))

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      false))

(define (compile-and-run? exp)
  (tagged-list? exp 'compile-and-run))

(define (compile-and-run-exp exp)
  (cadadr exp))

...

(define eceval-operations
  (list
    (list 'compile-and-run? compile-and-run?)
    (list 'compile-scheme compile-scheme)
    (list 'compile-and-run-exp compile-and-run-exp)
    ...))

再在求值器中添加指令

eval-dispatch
  ...
  (test (op compile-and-run?) (reg exp))
  (branch (label ev-compile-and-run))
  ...
ev-compile-and-run
  (assign val (op compile-and-run-exp) (reg exp))  
  (assign val (op compile-scheme) (reg val))
  (goto (label external-entry))

5.49

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

(define (compile-scheme expression)
  (assemble (statements
              (compile expression 'val 'return))
            eceval))

(define (user-print object)
  (cond ((compound-procedure? object)
         (display (list 'compound-procedure
                        (procedure-parameters object)
                        (procedure-body object)
                        '<procedure-env>)))
        ((compiled-procedure? object)
         (display '<compiled-procedure>))
        (else (display object))))

(define eceval-operations
  (list
    (list 'compile-scheme compile-scheme)

    ;;primitive Scheme operations
    (list 'read read)           ;used by eceval

    ;;used by compiled code
    (list 'list list)
    (list 'cons cons)

    ;;operations in eceval-support.scm
    (list 'true? true?)
    (list 'false? false?)       ;for compiled code
    (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)

    ;;for compiled code (also in eceval-support.scm)
    (list 'make-compiled-procedure make-compiled-procedure)
    (list 'compiled-procedure? compiled-procedure?)
    (list 'compiled-procedure-entry compiled-procedure-entry)
    (list 'compiled-procedure-env compiled-procedure-env)
    ))

(define eceval
  (make-machine
   '(exp env val proc argl continue unev)
   eceval-operations
  '(
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))

  (assign val (op compile-scheme) (reg exp))
  (goto (reg val))

5.50

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

(define metacircular-code
  '(begin
    (define (eval exp env)
      (cond ((self-evaluating? exp) exp)
            ((variable? exp) (lookup-variable-value exp env))
            ((quoted? exp) (text-of-quotation exp))
            ((assignment? exp) (eval-assignment exp env))
            ((definition? exp) (eval-definition exp env))
            ((if? exp) (eval-if exp env))
            ((lambda? exp)
             (make-procedure (lambda-parameters exp)
                             (lambda-body exp)
                             env))
            ((begin? exp) 
             (eval-sequence (begin-actions exp) env))
            ((cond? exp) (eval (cond->if exp) env))
            ((let? exp) (eval (let->combination exp) env))
            ((application? exp)
             (apply (eval (operator exp) env)
                    (list-of-values (operands exp) env)))
            (else
              (error "Unknown expression type -- EVAL" exp))))

    (define (apply procedure arguments)
      (cond ((primitive-procedure? procedure)
             (apply-primitive-procedure procedure arguments))
            ((compound-procedure? procedure)
             (eval-sequence
               (procedure-body procedure)
               (extend-environment
                 (procedure-parameters procedure)
                 arguments
                 (procedure-environment procedure))))
            (else
              (error
                "Unknown procedure type -- APPLY" procedure))))


    (define (list-of-values exps env)
      (if (no-operands? exps)
          '()
          (cons (eval (first-operand exps) env)
                (list-of-values (rest-operands exps) env))))

    (define (eval-if exp env)
      (if (true? (eval (if-predicate exp) env))
          (eval (if-consequent exp) env)
          (eval (if-alternative exp) env)))

    (define (eval-sequence exps env)
      (cond ((last-exp? exps) (eval (first-exp exps) env))
            (else (eval (first-exp exps) env)
                  (eval-sequence (rest-exps exps) env))))

    (define (eval-assignment exp env)
      (set-variable-value! (assignment-variable exp)
                           (eval (assignment-value exp) env)
                           env)
      'ok)

    (define (eval-definition exp env)
      (define-variable! (definition-variable exp)
                        (eval (definition-value exp) env)
                        env)
      'ok)

    ;; SECTION 4.1.2
    (define (self-evaluating? exp)
      (cond ((number? exp) true)
            ((string? exp) true)
            ((boolean? exp) true)
            (else false)))

    (define (quoted? exp)
      (tagged-list? exp 'quote))

    (define (text-of-quotation exp) (cadr exp))

    (define (tagged-list? exp tag)
      (if (pair? exp)
          (eq? (car exp) tag)
          false))

    (define (variable? exp) (symbol? exp))

    (define (assignment? exp)
      (tagged-list? exp 'set!))

    (define (assignment-variable exp) (cadr exp))

    (define (assignment-value exp) (caddr exp))


    (define (definition? exp)
      (tagged-list? exp 'define))

    (define (definition-variable exp)
      (if (symbol? (cadr exp))
          (cadr exp)
          (caadr exp)))

    (define (definition-value exp)
      (if (symbol? (cadr exp))
          (caddr exp)
          (make-lambda (cdadr exp)
                       (cddr exp))))

    (define (lambda? exp) (tagged-list? exp 'lambda))

    (define (lambda-parameters exp) (cadr exp))
    (define (lambda-body exp) (cddr exp))

    (define (make-lambda parameters body)
      (cons 'lambda (cons parameters body)))


    (define (if? exp) (tagged-list? exp 'if))

    (define (if-predicate exp) (cadr exp))

    (define (if-consequent exp) (caddr exp))

    (define (if-alternative exp)
      (if (not (null? (cdddr exp)))
          (cadddr exp)
          'false))

    (define (make-if predicate consequent alternative)
      (list 'if predicate consequent alternative))


    (define (begin? exp) (tagged-list? exp 'begin))

    (define (begin-actions exp) (cdr exp))

    (define (last-exp? seq) (null? (cdr seq)))
    (define (first-exp seq) (car seq))
    (define (rest-exps seq) (cdr seq))

    (define (sequence->exp seq)
      (cond ((null? seq) seq)
            ((last-exp? seq) (first-exp seq))
            (else (make-begin seq))))

    (define (make-begin seq) (cons 'begin seq))


    (define (application? exp) (pair? exp))
    (define (operator exp) (car exp))
    (define (operands exp) (cdr exp))

    (define (no-operands? ops) (null? ops))
    (define (first-operand ops) (car ops))
    (define (rest-operands ops) (cdr ops))


    (define (cond? exp) (tagged-list? exp 'cond))

    (define (cond-clauses exp) (cdr exp))

    (define (cond-else-clause? clause)
      (eq? (cond-predicate clause) 'else))

    (define (cond-predicate clause) (car clause))

    (define (cond-actions clause) (cdr clause))

    (define (cond->if exp)
      (expand-clauses (cond-clauses exp)))

    ;; 练习 4.6
    (define (let? exp) (tagged-list? exp 'let))

    (define (let->combination exp)
      (define (let-body exp) (cddr exp))
      (define (let-vars exp) (map car (cadr exp)))
      (define (let-exps exp) (map cadr (cadr exp)))
      (cons (make-lambda (let-vars exp) 
                         (let-body exp)) 
            (let-exps exp)))

    (define (expand-clauses clauses)
      (if (null? clauses)
          'false                          ; no else clause
          (let ((first (car clauses))
                (rest (cdr clauses)))
            (if (cond-else-clause? first)
                (if (null? rest)
                    (sequence->exp (cond-actions first))
                    (error "ELSE clause isn't last -- COND->IF"
                           clauses))
                (make-if (cond-predicate first)
                         (sequence->exp (cond-actions first))
                         (expand-clauses rest))))))

    ;; SECTION 4.1.3
    (define (true? x)
      (not (eq? x false)))

    (define (false? x)
      (eq? x false))

    (define (make-procedure parameters body env)
      (list 'procedure parameters body env))

    (define (compound-procedure? p)
      (tagged-list? p 'procedure))

    (define (procedure-parameters p) (cadr p))
    (define (procedure-body p) (caddr p))
    (define (procedure-environment p) (cadddr p))

    (define (enclosing-environment env) (cdr env))

    (define (first-frame env) (car env))

    (define the-empty-environment '())

    (define (make-frame variables values)
      (cons variables values))

    (define (frame-variables frame) (car frame))
    (define (frame-values frame) (cdr frame))

    (define (add-binding-to-frame! var val frame)
      (set-car! frame (cons var (car frame)))
      (set-cdr! frame (cons val (cdr frame))))

    (define (extend-environment vars vals base-env)
      (if (= (length vars) (length vals))
          (cons (make-frame vars vals) base-env)
          (if (< (length vars) (length vals))
              (error "Too many arguments supplied" vars vals)
              (error "Too few arguments supplied" vars vals))))

    (define (lookup-variable-value 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 "Unbound variable" var)
            (let ((frame (first-frame env)))
              (scan (frame-variables frame)
                    (frame-values frame)))))
      (env-loop env))

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

    (define (define-variable! var val env)
      (let ((frame (first-frame env)))
        (define (scan vars vals)
          (cond ((null? vars)
                 (add-binding-to-frame! var val frame))
                ((eq? var (car vars))
                 (set-car! vals val))
                (else (scan (cdr vars) (cdr vals)))))
        (scan (frame-variables frame)
              (frame-values frame))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; SECTION 4.1.4
    (define primitive-procedures
      (list (list 'car car)
            (list 'cdr cdr)
            (list 'cons cons)
            (list 'null? null?)
            (list 'pair? pair?)
            (list '= =)
            (list '+ +)
            (list '- -)
            (list '* *)
            (list '/ /)
            (list '< <)))

    (define (primitive-procedure-names)
      (map car
           primitive-procedures))

    (define (primitive-procedure-objects)
      (map (lambda (proc) (list 'primitive (cadr proc)))
           primitive-procedures))

    (define (setup-environment)
      (let ((initial-env
              (extend-environment (primitive-procedure-names)
                                  (primitive-procedure-objects)
                                  the-empty-environment)))
        (define-variable! 'true true initial-env)
        (define-variable! 'false false initial-env)
        initial-env))

    (define (primitive-procedure? proc)
      (tagged-list? proc 'primitive))

    (define (primitive-implementation proc) (cadr proc))

    (define (apply-primitive-procedure proc args)
      (apply-in-underlying-scheme
        (primitive-implementation proc) args))

    (define input-prompt "M-Eval input:")
    (define output-prompt "M-Eval value:")

    (define (driver-loop)
      (prompt-for-input input-prompt)
      (let ((input (read)))
        (let ((output (eval input the-global-environment)))
          (announce-output output-prompt)
          (user-print output)))
      (driver-loop))

    (define (prompt-for-input string)
      (newline) (newline) (display string) (newline))

    (define (announce-output string)
      (newline) (display string) (newline))

    (define (user-print object)
      (if (compound-procedure? object)
          (display (list 'compound-procedure
                         (procedure-parameters object)
                         (procedure-body object)
                         '<procedure-env>))
          (display object)))

    ; 一些额外函数，直接实现，避免注册到环境中
    (define (map op sequence)
      (if (null? sequence)
          '()
          (cons (op (car sequence)) (map op (cdr sequence)))))

    (define (cadr lst) (car (cdr lst)))
    (define (cddr lst) (cdr (cdr lst)))
    (define (caadr lst) (car (car (cdr lst))))
    (define (caddr lst) (car (cdr (cdr lst))))
    (define (cdadr lst) (cdr (car (cdr lst))))
    (define (cdddr lst) (cdr (cdr (cdr lst))))
    (define (cadddr lst) (car (cdr (cdr (cdr lst)))))
    (define (not x) (if x false true))

    (define (length items)
      (if (null? items)
          0
          (+ 1 (length (cdr items)))))



    ;;;Following are commented out so as not to be evaluated when
    ;;; the file is loaded.
    (define the-global-environment (setup-environment))

    (driver-loop)
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 设置环境
(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        ;;above from book -- here are some more
        (list 'display display)
        (list 'newline newline)
        (list '+ +)
        (list '- -)
        (list '* *)
        (list '= =)
        (list '/ /)
        (list '> >)
        (list '< <)

        (list 'list list)
        (list 'pair? pair?)
        (list 'eq? eq?)
        (list 'set-car! set-car!)
        (list 'set-cdr! set-cdr!)
        (list 'read read)
        (list 'number? number?)
        (list 'string? string?)
        (list 'symbol? symbol?)
        (list 'boolean? boolean?)
        (list 'apply-in-underlying-scheme apply-primitive-procedure)
        (list 'error error)
        ))

(define (primitive-procedure-names)
  (map car primitive-procedures))

(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))

(define (setup-environment)
  (let ((initial-env (extend-environment (primitive-procedure-names)
                                         (primitive-procedure-objects)
                                         the-empty-environment)))
    (define-variable! 'true true initial-env)
    (define-variable! 'false false initial-env)
    initial-env))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define eceval-operations
  (list
    ;;used by compiled code
    (list 'list list)
    (list 'cons cons)

    ;;operations in eceval-support.scm
    (list 'true? true?)
    (list 'false? false?)   ;for compiled code
    (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)

    ;;for compiled code (also in eceval-support.scm)
    (list 'make-compiled-procedure make-compiled-procedure)
    (list 'compiled-procedure? compiled-procedure?)
    (list 'compiled-procedure-entry compiled-procedure-entry)
    (list 'compiled-procedure-env compiled-procedure-env)
    ))

(define (compile-scheme expression)
  (statements (compile expression 'val 'return)))


(define eceval-machine
  (make-machine
    '(exp env val proc argl continue unev)
    eceval-operations
    (compile-scheme metacircular-code)
    ))

(set-register-contents! eceval-machine 'env (setup-environment))
(start eceval-machine)

5.51

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

5.52

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