From bb870cbdf1805ba2580bbbe07fdf9e83566d84ac Mon Sep 17 00:00:00 2001
From: Felix Martin <mail@felixm.de>
Date: Tue, 30 Mar 2021 19:49:09 -0400
Subject: [PATCH] Implement till 5.18

---
 ex-5_14-xx.scm => ex-5_14-19.scm | 34 +++++++++++++++++++++++++---
 ex-5_20-xx.scm                   |  4 ++++
 misc/sicp-regsim.scm             | 38 ++++++++++++++++++++++++++++----
 3 files changed, 69 insertions(+), 7 deletions(-)
 rename ex-5_14-xx.scm => ex-5_14-19.scm (64%)
 create mode 100644 ex-5_20-xx.scm

diff --git a/ex-5_14-xx.scm b/ex-5_14-19.scm
similarity index 64%
rename from ex-5_14-xx.scm
rename to ex-5_14-19.scm
index 218b3e1..e4b9931 100644
--- a/ex-5_14-xx.scm
+++ b/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")
diff --git a/ex-5_20-xx.scm b/ex-5_20-xx.scm
new file mode 100644
index 0000000..cdda6a6
--- /dev/null
+++ b/ex-5_20-xx.scm
@@ -0,0 +1,4 @@
+(load "util.scm")
+(load "misc/sicp-regsim.scm")
+
+(display "\nex-5.20\n")
diff --git a/misc/sicp-regsim.scm b/misc/sicp-regsim.scm
index 1bfb17c..d32c690 100644
--- a/misc/sicp-regsim.scm
+++ b/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)
-             (lambda (value) (set! contents value)))
+            ((eq? message 'set) set)
             ((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