From 1432f7fb4bd42610457fc5047d3f270cc9e507b6 Mon Sep 17 00:00:00 2001
From: Isaac Shoebottom <ir.shoebottom@gmail.com>
Date: Wed, 2 Apr 2025 11:58:30 -0300
Subject: [PATCH] Add lab 8 (10) code, completed

---
 Labs/08.rkt | 117 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 117 insertions(+)
 create mode 100644 Labs/08.rkt

diff --git a/Labs/08.rkt b/Labs/08.rkt
new file mode 100644
index 0000000..b9a54e0
--- /dev/null
+++ b/Labs/08.rkt
@@ -0,0 +1,117 @@
+#lang racket
+(require (only-in plai error test test/exn print-only-errors))
+
+;; define .... placeholder syntax like plait
+(define-syntax ....
+  (lambda (stx)
+    (syntax-case stx ()
+      [_ (syntax/loc stx
+           (error "reached a `....` placeholder"))])))
+
+;; Emulate a small part of the plai/gc2/collector language
+(define current-heap (make-parameter (make-vector 0 #f)))
+(define (heap-set! index val) (vector-set!  (current-heap) index val))
+(define (heap-ref index) (vector-ref (current-heap) index))
+(define (heap-size) (vector-length (current-heap)))
+(define (simple-root loc) (box loc))
+(define (read-root root) (unbox root))
+;; allocation pointer in word 0
+(define (set-ptr! v) (heap-set! 0 v))
+
+(define (malloc n)
+  (define addr (heap-ref 0))
+  (unless (<= (+ addr n) (heap-size))
+    (error 'allocator "out of memory"))
+  (heap-set! 0 (+ addr n))
+  addr)
+
+(define-syntax-rule (with-heap vec expr ...)
+  (parameterize  ([current-heap vec]) (begin expr ...)))
+
+;; Convenience functions for tagged heap access
+(define (expect addr tag)
+  (unless (equal? (heap-ref addr) tag)
+    (error 'expect "expecting ~a at ~a" tag addr)))
+(define (heap-put! tag addr offset val)
+  (expect addr tag) (heap-set! (+ addr offset) val))
+
+;; Partial implementation of a collector API
+(define (gc:alloc-flat x)
+  (define loc (malloc 2))
+  (heap-set! loc 'flat)
+  (heap-put! 'flat loc 1 x)
+  loc)
+
+(define (gc:cons f r)
+  (define loc (malloc 3))
+  (heap-set! loc 'cons)
+  (heap-put! 'cons loc 1 (read-root f))
+  (heap-put! 'cons loc 2 (read-root r))
+  loc)
+
+(define (init-allocator) (set-ptr! 1))
+
+;; coverage tests
+(module+ test
+  (with-heap (make-vector 4 'free)
+    (init-allocator)
+    (test/exn (malloc 10) "out of memory")
+    (test/exn (expect 1 'flat) "expecting")))
+
+(define (flat-2 a b)
+  (with-heap (make-vector 5 'free)
+    (init-allocator)
+    (gc:alloc-flat a)
+    (gc:alloc-flat b)
+    (current-heap)))
+(define (cons-2 a b)
+  (with-heap (make-vector 8 'free)
+    (init-allocator)
+    (gc:cons (simple-root (gc:alloc-flat a)) (simple-root (gc:alloc-flat b)))
+    (current-heap)))
+(define (self-cons)
+   (with-heap (make-vector 4 'free)
+    (init-allocator)
+    (define loc (malloc 0)) ; Hack to get current heap pointer
+    (gc:cons (simple-root loc) (simple-root loc))
+    (current-heap)))
+(define (list-3 a b c)
+  (with-heap (make-vector 20 'free)
+    (init-allocator)
+    (define one (gc:cons
+               (simple-root (gc:alloc-flat c))
+               (simple-root (gc:alloc-flat (list)))))
+    (define two (gc:cons
+               (simple-root (gc:alloc-flat b))
+               (simple-root one)))
+    (gc:cons
+     (simple-root (gc:alloc-flat a))
+     (simple-root two))
+    (current-heap)))
+; Why is this, which is the exact same as this, except the defines inlined producing a different structure?
+#;(define (list-3 a b c)
+  (with-heap (make-vector 20 'free)
+    (init-allocator)
+    (gc:cons
+     (simple-root (gc:alloc-flat a))
+     (simple-root (gc:cons
+                   (simple-root (gc:alloc-flat b))
+                   (simple-root (gc:cons
+                                 (simple-root (gc:alloc-flat c))
+                                 (simple-root (gc:alloc-flat (list))))))))
+    (current-heap)))
+
+(module+ test
+  (test (flat-2 1 2) #(5 flat 1 flat 2))
+  (test (flat-2 'flat 'cons) #(5 flat flat flat cons))
+  (test (flat-2 'cons 'flat) #(5 flat cons flat flat))
+
+  (test (cons-2 'first 'rest) #(8 flat first flat rest cons 1 3))
+  (test (cons-2 1 2) #(8 flat 1 flat 2 cons 1 3))
+  (test (cons-2 'cons 'cons) #(8 flat cons flat cons cons 1 3))
+
+  (test (self-cons) #(4 cons 1 1))
+
+  (test (list-3 'cons 'cons 'cons) '#(18 flat cons flat () cons 1 3 flat cons cons 8 5 flat cons cons 13 10 free free))
+  (test (list-3 'flat 'flat 'flat) '#(18 flat flat flat () cons 1 3 flat flat cons 8 5 flat flat cons 13 10 free free))
+  (test (list-3 1 2 3)             '#(18 flat 3 flat () cons 1 3 flat 2 cons 8 5 flat 1 cons 13 10 free free)))
\ No newline at end of file