Begin chapter 5 part 2

2 files changed, 517 insertions, 1 deletions

diff --git a/chap5/part1.rkt b/chap5/part1.rkt
index e878ace..394c3d0 100644
--- a/chap5/part1.rkt
+++ b/chap5/part1.rkt
@@ -317,7 +317,7 @@
 
 (define expt-controller
   '(controller
-      (assign (continue (label expt-done)))
+      (assign continue (label expt-done))
     expt-loop
       (test (op =) (reg n) (const 0))
       (branch (label base-case))
diff --git a/chap5/part2.rkt b/chap5/part2.rkt
new file mode 100644
index 0000000..1f4a551
--- /dev/null
+++ b/chap5/part2.rkt
@@ -0,0 +1,516 @@
+#lang sicp
+(#%require (only racket/base print-as-expression print-mpair-curly-braces))
+(print-as-expression #f)
+(print-mpair-curly-braces #f)
+
+;; Chapter 5
+;; Computing with Register Machines
+
+;; 5.2
+;; A Register-Machine Simulator
+
+#| 5.7 |#
+
+(#%provide expt-controller)
+(define expt-controller
+  '(controller
+      (assign continue (label expt-done))
+    expt-loop
+      (test (op =) (reg n) (const 0))
+      (branch (label base-case))
+      (save continue)
+      (save n)
+      (assign n (op -) (reg n) (const 1))
+      (assign continue (label after-expt))
+      (goto (label expt-loop))
+    after-expt
+      (restore n)
+      (restore continue)
+      (assign val (op *) (reg b) (reg val))
+      (goto (reg continue))
+    base-case
+      (assign val (const 1))
+      (goto (reg continue))
+    expt-done))
+
+(#%provide expt-iter-controller)
+(define expt-iter-controller
+  '(controller
+      (assign counter (reg n))
+      (assign product (const 1))
+    test-counter
+      (test (op =) (reg counter) (const 0))
+      (branch (label expt-done))
+      (assign counter (op -) (reg counter) (const 1))
+      (assign product (op *) (reg b) (reg product))
+      (goto (label test-counter))
+    expt-done))
+
+(#%provide test-expt)
+(define (test-expt)
+  (let
+    ((expt-machine
+      (make-machine
+        '(n b val continue)
+        (list (list '- -) (list '* *) (list '= =))
+        expt-controller)))
+    (set-register-contents! expt-machine 'b 5)
+    (set-register-contents! expt-machine 'n 4)
+    (start expt-machine)
+    (get-register-contents expt-machine 'val)))
+
+(#%provide test-expt-iter)
+(define (test-expt-iter)
+  (let
+    ((expt-machine
+      (make-machine
+        '(n b product counter)
+        (list (list '- -) (list '* *) (list '= =))
+        expt-iter-controller)))
+    (set-register-contents! expt-machine 'b 10)
+    (set-register-contents! expt-machine 'n 4)
+    (start expt-machine)
+    (get-register-contents expt-machine 'product)))
+
+;; The Machine Model
+
+(#%provide make-register)
+(define (make-register name)
+  (let ((contents '*unassigned*))
+    (define (dispatch message)
+      (cond
+        ((eq? message 'get) contents)
+        ((eq? message 'set)
+         (lambda (value) (set! contents value)))
+        (else
+         (error "Unknown request -- REGISTER" message))))
+    dispatch))
+
+(#%provide get-contents)
+(define (get-contents register)
+  (register 'get))
+
+(#%provide set-contents!)
+(define (set-contents! register value)
+  ((register 'set) value))
+
+(#%provide make-stack)
+(define (make-stack)
+  (let ((s '()))
+    (define (push x)
+      (set! s (cons x s)))
+    (define (pop)
+      (if (null? s)
+        (error "Empty stack -- POP")
+        (let ((top (car s)))
+          (set! s (cdr s))
+          top)))
+    (define (initialize)
+      (set! s '())
+      'done)
+    (define (dispatch message)
+      (cond
+        ((eq? message 'push) push)
+        ((eq? message 'pop) (pop))
+        ((eq? message 'initialize) (initialize))
+        (else (error "Unknown request -- STACK" message))))
+    dispatch))
+
+(#%provide pop)
+(define (pop stack)
+  (stack 'pop))
+
+(#%provide push)
+(define (push stack value)
+  ((stack 'push) value))
+
+(define (make-instruction text)
+  (cons text '()))
+
+(define (instruction-text inst)
+  (car inst))
+
+(define (instruction-execution-proc inst)
+  (cdr inst))
+
+(define (set-instruction-execution-proc! inst proc)
+  (set-cdr! inst proc))
+
+(#%provide make-new-machine)
+(define (make-new-machine)
+  (let
+    ((pc (make-register 'pc))
+     (flag (make-register 'flag))
+     (stack (make-stack))
+     (the-instruction-sequence '()))
+    (let
+      ((the-ops
+        (list
+          (list
+            'initialize-stack
+            (lambda () (stack 'initialize)))))
+       (register-table
+         (list (list 'pc pc) (list 'flag flag))))
+      (define (allocate-register name)
+        (if (assoc name register-table)
+          (error "Multiply-defined register: " name)
+          (set! register-table
+            (cons
+              (list name (make-register name))
+              register-table)))
+        '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)))
+
+(#%provide start)
+(define (start machine)
+  (machine 'start))
+
+(define (get-register machine reg-name)
+  ((machine 'get-register) reg-name))
+
+(#%provide get-register-contents)
+(define (get-register-contents machine register-name)
+  (get-contents (get-register machine register-name)))
+
+(#%provide set-register-contents!)
+(define (set-register-contents! machine register-name value)
+  (set-contents! (get-register machine register-name) value)
+  'done)
+
+(#%provide make-machine)
+(define (make-machine register-names ops controller-text)
+  (let ((machine (make-new-machine)))
+    (for-each
+      (lambda (register-name)
+        ((machine 'allocate-register) register-name))
+      register-names)
+    ((machine 'install-operations) ops)
+    ((machine 'install-instruction-sequence)
+     (assemble controller-text machine))
+    machine))
+
+;; The Assembler
+
+(define (make-label-entry label-name insts)
+  (cons label-name insts))
+
+(#%provide lookup-label)
+(define (lookup-label labels label-name)
+  (let ((val (assoc label-name labels)))
+    (if val
+      (cdr val)
+      (error "Undefined label -- ASSEMBLE" label-name))))
+
+(#%provide extract-labels)
+(define (extract-labels text receive)
+  (if (null? text)
+    (receive '() '())
+    (extract-labels
+      (cdr text)
+      (lambda (insts labels)
+        (let ((next-inst (car text)))
+          (if (symbol? next-inst)
+            (if (assoc next-inst labels)
+              (error "Duplicate label -- ASSEMBLE" next-inst)
+              (receive
+                insts
+                (cons
+                  (make-label-entry next-inst insts)
+                  labels)))
+            (receive
+              (cons
+                (make-instruction next-inst)
+                insts)
+              labels)))))))
+
+(define (update-insts! insts labels machine)
+  (let
+    ((pc (get-register machine 'pc))
+     (flag (get-register machine 'flag))
+     (stack (machine 'stack))
+     (ops (machine 'operations)))
+    (for-each
+      (lambda (inst)
+        (set-instruction-execution-proc!
+          inst
+          (make-execution-procedure
+            (instruction-text inst)
+            labels
+            machine
+            pc
+            flag
+            stack
+            ops)))
+      insts)))
+
+(define (assemble controller-text machine)
+  (extract-labels
+    controller-text
+    (lambda (insts labels)
+      (update-insts! insts labels machine)
+      insts)))
+
+#| 5.8 |#
+
+(#%provide ambiguous-labels)
+(define ambiguous-labels
+  '(start
+      (goto (label here))
+    here
+      (assign a (const 3))
+      (goto (label there))
+    here
+      (assign a (const 4))
+      (goto (label there))
+    there))
+
+#| (if (assoc next-inst labels) |#
+#|   (error "Duplicate label -- ASSEMBLE" next-inst) |#
+#|   (receive |#
+#|     insts |#
+#|     (cons |#
+#|       (make-label-entry next-inst insts) |#
+#|       labels))) |#
+
+;; Generating Execution Procedures for Instructions
+
+(define (make-execution-procedure
+          inst
+          labels
+          machine
+          pc
+          flag
+          stack
+          ops)
+  (cond
+    ((eq? (car inst) 'assign)
+     (make-assign inst machine labels ops pc))
+    ((eq? (car inst) 'test)
+     (make-test inst machine labels ops flag pc))
+    ((eq? (car inst) 'branch)
+     (make-branch inst machine labels flag pc))
+    ((eq? (car inst) 'goto)
+     (make-goto inst machine labels pc))
+    ((eq? (car inst) 'save)
+     (make-save inst machine stack pc))
+    ((eq? (car inst) 'restore)
+     (make-restore inst machine stack pc))
+    ((eq? (car inst) 'perform)
+     (make-perform inst machine labels ops pc))
+    (else
+      (error "Unknown instruction type -- ASSEMBLE" inst))))
+
+(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 ()
+        (set-contents! target (value-proc))
+        (advance-pc pc)))))
+
+(define (assign-reg-name assign-instruction)
+  (cadr assign-instruction))
+
+(define (assign-value-exp assign-instruction)
+  (cddr assign-instruction))
+
+(define (advance-pc pc)
+  (set-contents! pc (cdr (get-contents pc))))
+
+(define (make-test inst machine labels operations flag pc)
+  (let ((condition (test-condition inst)))
+    (if (operation-exp? condition)
+      (let
+        ((condition-proc
+          (make-operation-exp
+            condition
+            machine
+            labels
+            operations)))
+        (lambda ()
+          (set-contents! flag (condition-proc))
+          (advance-pc pc)))
+      (error "Bad TEST instruction -- ASSEMBLE" inst))))
+
+(define (test-condition test-instruction)
+  (cdr test-instruction))
+
+(define (make-branch inst machine labels flag pc)
+  (let ((dest (branch-dest inst)))
+    (if (label-exp? dest)
+      (let ((insts (lookup-label labels (label-exp-label dest))))
+        (lambda ()
+          (if (get-contents flag)
+            (set-contents! pc insts)
+            (advance-pc pc))))
+      (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+
+(define (branch-dest branch-instruction)
+  (cadr branch-instruction))
+
+(define (make-goto inst machine labels pc)
+  (let ((dest (goto-dest inst)))
+    (cond
+      ((label-exp? dest)
+       (let
+         ((insts (lookup-label labels (label-exp-label dest))))
+         (lambda () (set-contents! pc insts))))
+      ((register-exp? dest)
+       (let
+         ((reg (get-register machine (register-exp-reg dest))))
+         (lambda () (set-contents! pc (get-contents reg)))))
+      (else (error "Bad GOTO instruction -- ASSEMBLE" inst)))))
+
+(define (goto-dest goto-instruction)
+  (cadr goto-instruction))
+
+(define (make-save inst machine stack pc)
+  (let
+    ((reg
+      (get-register
+        machine
+        (stack-inst-reg-name inst))))
+    (lambda ()
+      (push stack (get-contents reg))
+      (advance-pc pc))))
+
+(define (make-restore inst machine stack pc)
+  (let
+    ((reg
+      (get-register
+        machine
+        (stack-inst-reg-name inst))))
+    (lambda ()
+      (set-contents! reg (pop stack))
+      (advance-pc pc))))
+
+(define (stack-inst-reg-name stack-instruction)
+  (cadr stack-instruction))
+
+(define (make-perform inst machine labels operations pc)
+  (let ((action (perform-action inst)))
+    (if (operation-exp? action)
+      (let
+        ((action-proc
+          (make-operation-exp
+            action
+            machine
+            labels
+            operations)))
+        (lambda ()
+          (action-proc)
+          (advance-pc pc)))
+      (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+
+(define (perform-action inst) (cdr inst))
+
+(define (make-primitive-exp exp machine labels)
+  (cond
+    ((constant-exp? exp)
+     (let ((c (constant-exp-value exp)))
+       (lambda () c)))
+    ((label-exp? exp)
+     (let ((insts (lookup-label labels (label-exp-label exp))))
+       (lambda () insts)))
+    ((register-exp? exp)
+     (let ((r (get-register machine (register-exp-reg exp))))
+       (lambda () (get-contents r))))
+    (else
+     (error "Unknown expression type -- ASSEMBLE" exp))))
+
+(define (tagged-list? exp tag)
+  (if (pair? exp)
+    (eq? (car exp) tag)
+    false))
+
+(define (register-exp? exp) (tagged-list? exp 'reg))
+
+(define (register-exp-reg exp) (cadr exp))
+
+(define (constant-exp? exp) (tagged-list? exp 'const))
+
+(define (constant-exp-value exp) (cadr exp))
+
+(define (label-exp? exp) (tagged-list? exp 'label))
+
+(define (label-exp-label exp) (cadr exp))
+
+(define (make-operation-exp exp machine labels operations)
+  (let
+    ((op (lookup-prim (operation-exp-op exp) operations))
+     (aprocs
+      (map
+        (lambda (e)
+          (make-primitive-exp e machine labels))
+        (operation-exp-operands exp))))
+    (lambda ()
+      (apply op (map (lambda (p) (p)) aprocs)))))
+
+(define (operation-exp? exp)
+  (and (pair? exp) (tagged-list? (car exp) 'op)))
+
+(define (operation-exp-op operation-exp)
+  (cadr (car operation-exp)))
+
+(define (operation-exp-operands operation-exp)
+  (cdr operation-exp))
+
+(define (lookup-prim symbol operations)
+  (let ((val (assoc symbol operations)))
+    (if val
+      (cadr val)
+      (error "Unknown operation -- ASSEMBLE" symbol))))
+
+#| 5.9 |#
+#| 5.10 |#
+#| 5.11 |#
+#| 5.12 |#
+#| 5.13 |#
+
+;; Monitoring Machine Performance
+
+#| 5.14 |#
+#| 5.15 |#
+#| 5.16 |#
+#| 5.17 |#
+#| 5.18 |#
+#| 5.19 |#