Finish 5.11 - this was a challenging one - nice

ex-5_07-xx.scm

@@ -150,14 +150,18 @@
 (assert (get-register-contents fib-machine 'val) 21)
 
 ; b.
-(define stack-content car)
-(define stack-register cadr)
+
+; If we install the following stack procedure before the optimzed fib
+; implementation above it will raise an error because we restore val into n.
+
+(define stack-register car)
+(define stack-content cadr)
 
 (define (make-save inst machine stack pc)
   (let ((reg (get-register machine
                            (stack-inst-reg-name inst))))
     (lambda ()
-      (push stack (list (get-contents reg) reg))
+      (push stack (list reg (get-contents reg)))
       (advance-pc pc))))
 
 (define (make-restore inst machine stack pc)
@@ -174,14 +178,89 @@
 
 (display "b. [implemented]\n")
 
-(display "c. ACTIVE!!!\n")
-;c.  (restore y) puts into y the last value saved from y regardless of what
-;other registers were saved after y and not restored. Modify the simulator to
-;behave this way. You will have to associate a separate stack with each
-;register. You should make the initialize-stack operation initialize all the
-;register stacks.
+
+(display "c.\n")
+
+(define (make-save inst machine stack pc)
+  (let* ((reg-name (stack-inst-reg-name inst))
+         (reg (get-register machine reg-name)))
+    (lambda ()
+      ((stack 'push) (get-contents reg) reg-name)
+      (advance-pc pc))))
+
+(define (make-restore inst machine stack pc)
+  (let* ((reg-name (stack-inst-reg-name inst))
+         (reg (get-register machine reg-name)))
+    (lambda ()
+      (let ((content ((stack 'pop) reg-name)))
+        (set-contents! reg content)
+        (advance-pc pc)))))
+
+(define (make-stack)
+  ;; stack that maintains a separate stack for each register internally
+  (let ((stacks '()))
+    (define (push x reg)
+      (let ((s (assoc reg stacks)))
+        (if s
+          (begin
+            (set-cdr! s (cons x (cdr s))))
+          (begin
+            (set! stacks (cons (cons reg (list x)) stacks))))))
+    (define (pop reg)
+      (let ((s (assoc reg stacks)))
+        (if (not s)
+          (error "stack does not exist -- POP" reg)
+          (if (null? s)
+              (error "Empty stack -- POP")
+              (let ((top (cadr s)))
+                (set-cdr! s (cddr s))
+                top)))))
+    (define (initialize)
+      (set! stacks '())
+      'done)
+    (define (dispatch message)
+      (cond ((eq? message 'push) push)
+            ((eq? message 'pop) pop)
+            ((eq? message 'initialize) (initialize))
+            (else (error "Unknown request -- STACK"
+                         message))))
+    dispatch))
+
+(define stack-test-machine
+  (make-machine
+    '(a b c)
+    '()
+    '(controller
+       (assign a (const 1))
+       (assign b (const 2))
+       (assign c (const 3))
+       ; order doesn't matter
+       (save a)
+       (save c)
+       (save b)
+       (assign a (const 4))
+       (assign b (const 5))
+       (assign c (const 6))
+       (save b)
+       (save a)
+       (save c)
+       (assign a (const 0))
+       (assign b (const 0))
+       (assign c (const 0))
+       (restore a)
+       (restore a)
+       (restore b)
+       (restore c)
+       stack-test-machine-done)))
+
+(start stack-test-machine)
+(assert (get-register-contents stack-test-machine 'a) 1)
+(assert (get-register-contents stack-test-machine 'b) 5)
+(assert (get-register-contents stack-test-machine 'c) 6)
 
 (display "\nex-5.12\n")
 
-; (display "\nex-5.13\n")
+
+(display "\nex-5.13\n")
+