Add chapter 5 part 3

1 files changed, 219 insertions, 0 deletions

diff --git a/chap5/part3.rkt b/chap5/part3.rkt
new file mode 100644
index 0000000..2fad35d
--- /dev/null
+++ b/chap5/part3.rkt
@@ -0,0 +1,219 @@
+#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.3
+;; Storage Allocation and Garbage Collection
+
+;; Memory as Vectors
+
+#| 5.20 |#
+
+#| (define x (cons 1 2)) |#
+#| (define y (list x x)) |#
+
+#|          |  0 |  1 |  2 |  3 |  4 | |#
+#| ---------|----|----|----|----|----| |#
+#| the-cars | n1 | p0 | p0 | |#
+#| the-cdrs | n2 | e0 | p1 | |#
+
+#| x = p0 |#
+#| y = p2 |#
+#| free = 3 |#
+
+#| 5.21 |#
+
+(define (count-leaves tree)
+  (cond
+    ((null? tree) 0)
+    ((not (pair? tree)) 1)
+    (else
+      (+
+        (count-leaves (car tree))
+        (count-leaves (cdr tree))))))
+
+(define count-leaves-controller
+  '(controller
+       (assign continue (label count-leaves-done))
+       (assign tree (op read))
+     count-leaves
+       (test (op null?) (reg tree))
+       (branch (label if-null))
+       (assign t (op pair?) (reg tree))
+       (test (op not) (reg t))
+       (branch (label if-leaf))
+       (save continue)
+       (save tree)
+       (assign continue (label after-car-tree))
+       (assign tree (op car) (reg tree))
+       (goto (label count-leaves))
+     after-car-tree
+       (restore tree)
+       (save tree)
+       (save val)
+       (assign tree (op cdr) (reg tree))
+       (assign continue (label after-cdr-tree))
+       (goto (label count-leaves))
+     after-cdr-tree
+       (assign t (reg val))
+       (restore val)
+       (restore tree)
+       (restore continue)
+       (assign val (op +) (reg t) (reg val))
+       (goto (reg continue))
+     if-null
+       (assign val (const 0))
+       (goto (reg continue))
+     if-leaf
+       (assign val (const 1))
+       (goto (reg continue))
+     count-leaves-done))
+
+(define (count-leaves- tree)
+  (define (count-iter tree n)
+    (cond
+      ((null? tree) n)
+      ((not (pair? tree)) (+ n 1))
+      (else
+        (count-iter
+          (cdr tree)
+          (count-iter (car tree) n)))))
+  (count-iter tree 0))
+
+(define count-leaves-iter-controller
+  '(controller
+       (assign continue (label count-leaves-done))
+       (assign tree (op read))
+       (assign n (const 0))
+     count-iter
+       (test (op null?) (reg tree))
+       (branch (label if-null))
+       (assign t (op pair?) (reg tree))
+       (test (op not) (reg t))
+       (branch (label if-leaf))
+       (save tree)
+       (save continue)
+       (assign tree (car tree))
+       (assign continue (label after-car-tree))
+       (goto (label count-iter))
+     after-car-tree
+       (restore continue)
+       (restore tree)
+       (assign tree (cdr tree))
+       (goto (label count-iter))
+     if-null
+       (goto (reg continue))
+     if-leaf
+       (assign n (op +) (reg n) (const 1))
+       (goto (reg continue))
+     count-leaves-done))
+
+#| 5.22 |#
+
+(define (append x y)
+  (if (null? x)
+    y
+    (cons (car x) (append (cdr x) y))))
+
+(define append-controller
+  '(controller
+      (assign x (op read))
+      (assign y (op read))
+      (assign continue (label append-done))
+    append
+      (test (op null?) (reg x))
+      (branch (label if-null))
+      (save x)
+      (save continue)
+      (assign x (op cdr) (reg x))
+      (assign continue (label after-append))
+      (goto (label append))
+    after-append
+      (restore continue)
+      (restore x)
+      (assign x (op car) (reg x))
+      (assign val (op cons) (reg x) (reg val))
+      (goto (reg continue))
+    if-null
+      (assign val (reg y))
+      (goto (reg continue))
+    append-done))
+
+(#%provide append!)
+(define (append! x y)
+  (set-cdr! (last-pair x) y)
+  x)
+
+(define append!-controller
+  '(controller
+      (assign x (op read))
+      (assign y (op read))
+      (assign head (reg x))
+      (assign rest (op cdr) (reg x))
+    last-pair
+      (test (op null?) (reg rest))
+      (branch (label found-last-pair))
+      (assign head (reg rest))
+      (assign rest (op cdr) (reg rest))
+      (goto (label last-pair))
+    found-last-pair
+      (perform (op set-cdr!) (reg head) (reg y))))
+
+;; Maintaining the Illusion of Infinite Memory
+
+(define gc-controller
+  '(begin-garbage-collection
+      (assign free (const 0))
+      (assign scan (const 0))
+      (assign old (reg root))
+      (assign relocate-continue (label reassign-root))
+      (goto (label relocate-old-result-in-new))
+    reassign-root
+      (assign root (reg new))
+      (goto (label gc-loop))
+    gc-loop
+      (test (op =) (reg scan) (reg free))
+      (branch (label gc-flip))
+      (assign old (op vector-ref) (reg new-cars) (reg scan))
+      (assign relocate-continue (label update-car))
+      (goto (label relocate-old-result-in-new))
+    update-car
+      (perform (op vector-set!) (reg new-cars) (reg scan) (reg new))
+      (assign old (op vector-ref) (reg new-cdrs) (reg scan))
+      (assign relocate-continue (label update-cdr))
+      (goto (label relocate-old-result-in-new))
+    update-cdr
+      (perform (op vector-set!) (reg new-cdrs) (reg scan) (reg new))
+      (assign scan (op +) (reg scan) (const 1))
+      (goto (label gc-loop))
+    relocate-old-result-in-new
+      (test (op pointer-to-pair?) (reg old))
+      (branch (label pair))
+      (assign new (reg old))
+      (goto (reg relocate-continue))
+    pair
+      (assign oldcr (op vector-ref) (reg the-cars) (reg old))
+      (test (op broken-heart?) (reg oldcr))
+      (branch (label already-moved))
+      (assign new (reg free))
+      (assign free (op +) (reg free) (const 1))
+      (perform (op vector-set!) (reg new-cars) (reg new) (reg olcr))
+      (assign oldcr (op vector-ref) (reg the-cdrs) (reg old))
+      (perform (op vector-set!) (reg new-cdrs) (reg new) (reg olcr))
+      (perform (op vector-set!) (reg the-cars) (reg old) (const broken-heart))
+      (perform (op vector-set!) (reg the-cdrs) (reg old) (reg new))
+      (goto (reg relocate-continue))
+    already-moved
+      (assign new (op vector-ref) (reg the-cdrs) (reg old))
+      (goto (reg relocate-continue))
+    gc-flip
+      (assign temp (reg the-cdrs))
+      (assign the-cdrs (reg new-cdrs))
+      (assign new-cdrs (reg temp))
+      (assign temp (reg the-cars))
+      (assign the-cars (reg new-cars))
+      (assign new-cars (reg temp))))