计算机程序的构造和解释(SICP) 第5章 习题解析 Part2

这次回顾第五章第二部分习题。

学习资料：

https://ocw.mit.edu/courses/electrical-engineering-and-computer-science/6-001-structure-and-interpretation-of-computer-programs-spring-2005/index.htm

https://github.com/DeathKing/Learning-SICP

https://mitpress.mit.edu/sites/default/files/sicp/index.html

https://www.bilibili.com/video/BV1Xx41117tr?from=search&seid=14983483066585274454

参考资料：

https://sicp.readthedocs.io/en/latest

http://community.schemewiki.org/?SICP-Solutions

http://community.schemewiki.org/?sicp

https://liujiacai.net/blog/2016/02/22/recursion-without-name/

https://mvanier.livejournal.com/2897.html

https://github.com/jiacai2050/sicp

https://liujiacai.net/

5.9(p371)

删除make-primitive-exp中

(label-exp? dest)

对应得分支即可。

5.10(p371)

增加语法形式：

(add a)

效果为使得寄存器a的值增加1。

添加内容如下：

在make-execution-procedure函数的分支中添加：

((eq? (car inst) 'add)
(make-add inst machine labels ops pc))

然后添加如下代码：

; 5.10 add begin
(define (make-add inst machine labels ops pc)
  (let ((target
          (get-register machine (add-reg-name inst))))
    (lambda ()                ; execution procedure for add
        (set-contents! target (+ (get-contents target) 1))
        (advance-pc pc))))

(define (add-reg-name assign-instruction)
  (cadr assign-instruction))
; 5.10 add end

测试代码：

(load "ch5-regsim.scm")

(define test-machine
    (make-machine
        '(a)
        (list)
        '((assign a (const 3))
          (add a))))

(start test-machine)

(get-register-contents test-machine 'a)

实验结果：

1 ]=> (get-register-contents test-machine 'a)
;Value: 4

5.11(p371)

测试代码为：

(load "ch5-regsim.scm")

(define test-machine
    (make-machine
        '(x y)
        (list)
        '((assign x (const 1))
          (assign y (const 2))
          (save y)
          (save x)
          (restore y)
          (restore x))))

(start test-machine)

(get-register-contents test-machine 'y)

(get-register-contents test-machine 'x)

(a)

可以删除afterfib-n-1中如下语句：

(restore continue)
(save continue)

实验结果：

1 ]=> (get-register-contents test-machine 'y)
;Value: 1

1 ]=> (get-register-contents test-machine 'x)
;Value: 2

(b)

添加如下代码：

; 5.11 b add start
(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (list reg (get-contents reg)))
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (let ((pair (pop stack)))
        (if (eq? reg (car pair))
          (begin 
            (set-contents! reg (cadr (pop stack)))   
            (advance-pc pc)
          )
          (error "Register must be same" (stack-inst-reg-name inst)))))))
; 5.11 b add end

实验结果：

1 ]=> (start test-machine)
;Register must be same y
;To continue, call RESTART with an option number:
; (RESTART 1) => Return to read-eval-print level 1.

(c)

思路：给每个寄存器保存一个stack。

添加如下代码：

; 5.11 c add begin
(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        ; change
        (stack ())
        (the-instruction-sequence '()))
    (let ((the-ops
           (list ;;**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)))
          (stack-table
           (list)))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (begin 
              (set! register-table
                  (cons (list name (make-register name))
                        register-table))
              ; add
              (set! stack
                  (cons (list name (make-stack))
                        stack))))
        '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 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))
; 5.11 c add end

; 5.11 c add begin
(define (get-stack name stack-list)
  (define (iter cur-stack-list)
    (if (eq? name (caar cur-stack-list))
      (car cur-stack-list)
      (iter (cdr cur-stack-list))))
  ; iter return (y #[compound-procedure 14])
  (cadr (iter stack-list)))

(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 (get-stack reg-name stack) (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 ()
      (set-contents! reg (pop (get-stack reg-name stack)))    
      (advance-pc pc))))
; 5.11 c add end

实验结果：

1 ]=> (get-register-contents test-machine 'y)
;Value: 2

1 ]=> (get-register-contents test-machine 'x)
;Value: 1

5.14(p373)

在make-execution-procedure函数的分支添加：

; 5.14
((eq? (car inst) 'print-statistics)
(make-print-statistics inst machine stack pc))

由于包含read的代码没有调试通过，所以使用如下版本的测试代码：

(load "ch5-regsim.scm")

(define factorial-machine
    (make-machine
        '(n val continue)
        (list (list '= =)
              (list '- -)
              (list '* *))
        '(controller
            (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
          (print-statistics))))

; (set-register-contents! factorial-machine 'n 1)
; (start factorial-machine)

; (set-register-contents! factorial-machine 'n 2)
; (start factorial-machine)

; (set-register-contents! factorial-machine 'n 3)
; (start factorial-machine)

; (set-register-contents! factorial-machine 'n 4)
; (start factorial-machine)

实验结果分别为：

0
2
4
6

函数关系为：

$$2(n-1)$$

5.15(p373)

思路：

添加寄存器cnt。

添加代码：

; 5.15 add begin
(define (init-cnt cnt)
  (set-contents! cnt 0))

(define (add-cnt cnt)
    (set-contents! cnt (+ 1 (get-contents cnt))))

(define (make-print-cnt inst machine stack pc)
  (let ((cnt (machine 'cnt)))
    (lambda ()
      (newline)
      (display "operation cnt is: ")
      ; 不包括print-cnt指令
      (display (- (get-contents cnt) 1))
      (init-cnt cnt)
      (advance-pc pc)))
    )
; 5.15 add end

测试代码：

(load "ch5-regsim.scm")

(define test-machine
    (make-machine
        '(x y)
        (list)
        '((assign x (const 1))
          (assign y (const 2))
          (save y)
          (print-cnt)
          (save x)
          (restore y)
          (print-cnt)
          (restore x)
          )))

(start test-machine)

实验结果：

1 ]=> (start test-machine)
operation cnt is: 3
operation cnt is: 2
;Value: done

5.16(p373)

思路：

添加寄存器trace-flag标志状态。

在make-execution-procedure的分支中添加如下代码：

((eq? (car inst) 'trace-on)
 (trace-on inst machine stack pc))
((eq? (car inst) 'trace-off)
 (trace-off inst machine stack pc))

其余添加的代码：

; 5.16 add begin
(define (init-trace-flag trace-flag)
  (set-contents! trace-flag #f))
; 5.16 add end

; 5.16 add begin
(define (trace-on inst machine stack pc)
  (let ((target
          (get-register machine 'trace-flag)))
    (lambda ()                ; execution procedure for add
        (set-contents! target #t)
        (advance-pc pc))))

(define (trace-off inst machine stack pc)
  (let ((target
          (get-register machine 'trace-flag)))
    (lambda ()                ; execution procedure for add
        (set-contents! target #f)
        (advance-pc pc))))
; 5.16 add end

测试代码：

(load "ch5-regsim.scm")

(define test-machine
    (make-machine
        '(x y)
        (list)
        '((assign x (const 1))
        (trace-on)
          (assign y (const 2))
          (save y)
        (trace-off)
          (save x)
          (restore y)
        (trace-on)
          (restore x)
          )))

(start test-machine)

实验结果：

1 ]=> (start test-machine)
2: (assign y (const 2))
3: (save y)
8: (restore x)
;Value: done

备注：序号是5.17添加的结果。

5.17(p373)

思路：

添加寄存器line-num。

添加代码：

; 5.17 add begin
(define (init-line-num line-num)
  (set-contents! line-num 0))

(define (add-line-num line-num)
    (set-contents! line-num (+ 1 (get-contents line-num))))
; 5.17 add end

测试代码和实验结果同5.16。

5.18(p373)

在make-execution-procedure函数的分支添加：

; 5.18
((eq? (car inst) 'trace-on-register)
(trace-on-register inst machine stack pc))
((eq? (car inst) 'trace-off-register)
(trace-off-register inst machine stack pc))

其余添加代码：

; 5.18 add begin
(define (make-register name)
  (let ((contents '*unassigned*)
        ; add
        (flag #f))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value) (set! contents value)))
            ; add
            ((eq? message 'get-flag) flag)
            ((eq? message 'set-flag)
             (lambda (value)
              (if (or (eq? value #t) (eq? value #f))
               (set! flag value)
               (error "Your should set #t or #f!" message))))
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))

(define (get-flag register)
  (register 'get-flag))

(define (set-flag register value)
  ((register 'set-flag) value))
; 5.18 add end

; 5.18 add begin
(define (trace-on-register inst machine stack pc)
  (let ((register-name (cadr inst)))
    (let ((register
            (get-register machine register-name)))
        (lambda ()   
          (set-flag register #t)
          (advance-pc pc)))))

(define (trace-off-register inst machine stack pc)
  (let ((register-name (cadr inst)))
    (let ((register
            (get-register machine register-name)))
        (lambda ()   
          (set-flag register #f)
          (advance-pc pc)))))
; 5.18 add end

(define (make-assign inst machine labels operations pc)
  (let ((target
         (get-register machine (assign-reg-name inst)))
        (value-exp (assign-value-exp inst)))
    (let ((value-proc
           (if (operation-exp? value-exp)
               (make-operation-exp
                value-exp machine labels operations)
               (make-primitive-exp
                (car value-exp) machine labels))))
      (lambda ()                ; execution procedure for assign
        ; 5.18 add begin
        (if (get-flag target)
        (begin
          (newline)
          (display "register-name: ")
          (display (assign-reg-name inst))
          (display ", ")
          (display "old value: ")
          (display (get-contents target))
          (display ", ")
          (display "new value: ")
          (display (value-proc))
        ))
        ; 5.18 add end
        (set-contents! target (value-proc))
        (advance-pc pc)))))

测试代码：

(load "ch5-regsim.scm")

(define test-machine
    (make-machine
        '(x y)
        (list)
        '((assign x (const 1))
          (assign y (const 2))
        (trace-on-register x)
          (assign x (const 3))
        (trace-on-register y)
          (assign y (const 4))
        (trace-off-register x)
          (assign x (const 5)))))

(start test-machine)

(get-register-contents test-machine 'y)

(get-register-contents test-machine 'x)

实验结果：

1 ]=> (start test-machine)
register-name: x, old value: 1, new value: 3
register-name: y, old value: 2, new value: 4
;Value: done