Implement till 5.18

ex-5_14-19.scm

@@ -34,7 +34,6 @@
   ((factorial-machine 'stack) 'initialize)
   (set-register-contents! factorial-machine 'n n)
   (start factorial-machine)
-  ; (assert (get-register-contents factorial-machine 'val) 720)
   ((factorial-machine 'stack) 'print-statistics)
   (newline))
 
@@ -44,6 +43,35 @@
 ; total-pushes(n) = (n - 1) * 2
 ; max-depth: (n - 1) * 2
 
-(display "\nex-5.15 - instruction-counting\n")
+(display "\nex-5.15 - instruction-count\n")
+
+(set-register-contents! factorial-machine 'n 1)
+(factorial-machine 'reset-instruction-acount)
+(start factorial-machine)
+(assert (factorial-machine 'instruction-count) 5)
+
+(display "\nex-5.16 - instruction-tracing\n")
+
+(display "[ok]\n")
+
+(display "\nex-5.17 - instruction-tracing-labels\n")
+
+(factorial-machine 'trace-on)
+(start factorial-machine)
+(factorial-machine 'trace-off)
+(start factorial-machine)
+
+(display "\nex-5.18 - register-tracing\n")
+
+((factorial-machine 'trace-on-reg) 'val)
+(set-register-contents! factorial-machine 'n 5)
+(start factorial-machine)
+(assert (get-register-contents factorial-machine 'val) 120)
+
+((factorial-machine 'trace-off-reg) 'val)
+(set-register-contents! factorial-machine 'n 5)
+(start factorial-machine)
+
+(display "\nex-5.19 - breakpoint\n")
+
 
-(display "\nex-5.16\n")

ex-5_20-xx.scm

@@ -0,0 +1,4 @@
+(load "util.scm")
+(load "misc/sicp-regsim.scm")
+
+(display "\nex-5.20\n")

misc/sicp-regsim.scm

@@ -24,12 +24,21 @@
     machine))
 
 (define (make-register name)
-  (let ((contents '*unassigned*))
+  (let ((contents '*unassigned*)
+        (trace #f))
+    (define (set value)
+      (if trace
+        (begin
+          (display "set! ") (display name)
+          (display " from ") (display contents)
+          (display " to ") (display value) (newline)))
+      (set! contents value))
     (define (dispatch message)
       (cond ((eq? message 'get) contents)
-            ((eq? message 'set)
+            ((eq? message 'set) set)
-             (lambda (value) (set! contents value)))
             ((eq? message 'name?) name)
+            ((eq? message 'trace-on) (set! trace #t))
+            ((eq? message 'trace-off) (set! trace #f))
             (else
              (error "Unknown request -- REGISTER" message))))
     dispatch))
@@ -110,6 +119,8 @@
   (let ((pc (make-register 'pc))
         (flag (make-register 'flag))
         (stack (make-stack))
+        (instruction-count 0)
+        (instruction-trace #f)
         (the-instruction-sequence '()))
     (let ((the-ops
            (list (list 'initialize-stack
@@ -138,6 +149,12 @@
               'done
               (begin
                 ((instruction-execution-proc (car insts)))
+                (if instruction-trace
+                  (begin
+                    (display (instruction-text (car insts)))
+                    (newline)))
+                (if (not (eq? 'label (car (instruction-text (car insts)))))
+                  (set! instruction-count (+ instruction-count 1)))
                 (execute)))))
       (define (dispatch message)
         (cond ((eq? message 'start)
@@ -145,6 +162,15 @@
                (execute))
               ((eq? message 'install-instruction-sequence)
                (lambda (seq) (set! the-instruction-sequence seq)))
+              ((eq? message 'instruction-count) instruction-count)
+              ((eq? message 'reset-instruction-acount)
+               (set! instruction-count 0) 'ok)
+              ((eq? message 'trace-on) (set! instruction-trace #t) 'ok)
+              ((eq? message 'trace-off) (set! instruction-trace #f) 'ok)
+              ((eq? message 'trace-on-reg)
+               (lambda (reg-name) ((lookup-register reg-name) 'trace-on)))
+              ((eq? message 'trace-off-reg)
+               (lambda (reg-name) ((lookup-register reg-name) 'trace-off)))
               ((eq? message 'allocate-register) allocate-register)
               ((eq? message 'get-register) lookup-register)
               ((eq? message 'install-operations)
@@ -181,7 +207,7 @@
        (lambda (insts labels)
          (let ((next-inst (car text)))
            (if (symbol? next-inst)
-               (receive insts
+               (receive (cons (make-instruction (list 'label next-inst)) insts)
                         (cons (make-label-entry next-inst
                                                 insts)
                               labels))
@@ -239,6 +265,8 @@
          (make-save inst machine stack pc))
         ((eq? (car inst) 'restore)
          (make-restore inst machine stack pc))
+        ((eq? (car inst) 'label)
+         (make-label pc))
         ((eq? (car inst) 'perform)
          (make-perform inst machine labels ops pc))
         ((eq? (car inst) 'inc)
@@ -246,6 +274,8 @@
         (else (error "Unknown instruction type -- ASSEMBLE"
                      inst))))
 
+(define (make-label pc)
+  (lambda () (advance-pc pc)))
 
 (define (make-assign inst machine labels operations pc)
   (let ((target