diff --git a/ex-5_07-xx.scm b/ex-5_07-xx.scm index 984ef3e..a733f1b 100644 --- a/ex-5_07-xx.scm +++ b/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") +