Improve 3.rkt a bit

Assignments/04.rkt

@@ -20,8 +20,7 @@
   [let1E (var : Symbol) (te : TypeExp) (value : Exp) (body : Exp)]
   [recE (var : Symbol) (te : TypeExp) (value : Exp) (body : Exp)]
   [objE (fields : (Listof (Symbol * Exp)))]
-  [msgE (obj : Exp) (selector : Symbol)]
+  [msgE (obj : Exp) (selector : Symbol)])
-  )
 
 (define-type Type
   [numT]
@@ -62,7 +61,35 @@
         (objT (hash (list (pair 'add1 (arrowT (numT) (numT)))
                           (pair 'compare (arrowT (numT) (boolT))))))))
 
-(define (subtype? X Y) ....)
+(define (subtype? X Y)
+  (type-case Type X
+    [(numT) (type-case Type Y
+              [(numT) #t]
+              [else #f])]
+    [(boolT) (type-case Type Y
+               [(boolT) #t]
+               [else #f])]
+    [(arrowT X-arg X-result)
+     (type-case Type Y
+       [(arrowT Y-arg Y-result)
+        (and (subtype? Y-arg X-arg)  ;; Contravariance of arguments
+             (subtype? X-result Y-result))]  ;; Covariance of results
+       [else #f])]
+    [(objT X-fields)
+     (type-case Type Y
+       [(objT Y-fields)
+        (local [(define (loop keys)
+                  (if (empty? keys)
+                      #t
+                      (let ([key (first keys)])
+                        (let ([Y-type (some-v (hash-ref Y-fields key))])
+                          (type-case (Optionof Type) (hash-ref X-fields key)
+                            [(none) #f]  ;; Key not found in X-fields
+                            [(some X-type)
+                             (and (subtype? X-type Y-type)  ;; Check subtyping of field types
+                                  (loop (rest keys)))])))))]  ;; Recurse on remaining keys
+          (loop (hash-keys Y-fields)))]
+       [else #f])]))
 
 (module+ test
   (define hello-t (objT (hash (list (pair 'hello (numT))))))
@@ -85,7 +112,6 @@
              type
              (error 'typecheck "expected 2 num"))))]
     (type-case Exp exp
-
       [(numE n) (numT)]
       [(boolE b) (boolT)]
       [(plusE l r) (num2 l r (numT))]
@@ -101,7 +127,7 @@
        (type-case Type (typecheck fn env)
          [(arrowT arg-type result-type)
           (let ([actual-type (typecheck arg env)])
-            (if (equal? arg-type actual-type)
+            (if (subtype? actual-type arg-type)  ;; Use subtype? to check compatibility
                 result-type
                 (error 'typecheck "argument type")))]
          [else (error 'typecheck "not function")])]
@@ -127,31 +153,29 @@
          (if (equal? var-t val-t)
              body-t
              (error 'typecheck "type does not match annotation")))]
-      [(objE fields) (let* ([extract-exp (lambda (obj) (pair (fst obj) (typecheck (snd obj) env)))]
+      [(objE fields)
+       (let*
+           ([extract-exp (lambda (obj) (pair (fst obj) (typecheck (snd obj) env)))]
             [field-list (map extract-exp fields)])
-                       (objT (make-hash field-list)))]
+         (objT (hash field-list)))]
-      [(msgE obj selector) (type-case Exp obj
+      [(msgE obj selector)
-                             [(objE fields) (type-case (Optionof Exp) (hash-ref (make-hash fields) selector)
+       (type-case Exp obj
+         [(objE fields)
+          (type-case (Optionof Exp) (hash-ref (make-hash fields) selector)
             [(none) (error 'typecheck "unknown field")]
             [(some v) (typecheck v env)])]
-                             [(varE name) (type-case Type (type-lookup name env)
+         [(varE name) 
-                                            [(objT fields) (type-case (Optionof Type) (hash-ref fields selector)
+          (type-case Type (type-lookup name env)
-                                                             [(none) (error 'typecheck "dasdas")]
+            [(objT fields) (type-lookup selector fields)]
-                                                             [(some v) (type-case Type v
-                                                                         [(arrowT a b) b]
-                                                                         [else (error 'dasdas "dasdas")])])]
             [else (error 'typecheck "bound variable is not an object")])]
-
+         [else (error 'typecheck "passing message to non-object")])])))
-                             [else (error 'typecheck "passing message to non-object")])]
-      )))
 
 (define (parse-error sx)
   (error 'parse (string-append "parse error: " (to-string sx))))
 
 (module+ test
   (test/exn (parse `"strings are not in our language") "parse")
-  (test/exn (parse `{& 1 2}) "parse")
+  (test/exn (parse `{& 1 2}) "parse"))
-)
 
 (define (sx-ref sx n) (list-ref (s-exp->list sx) n))
 
@@ -228,9 +252,7 @@
                     (pair 'goodbye (numE 42)))))
   (test (parse `{lam {x : (obj (n-func (num -> num)))} x})
         (lamE 'x (objTE (list (pair 'n-func (arrowTE (numTE) (numTE)))))
-              (varE 'x)))
+              (varE 'x))))
-
-  )
 
 
 (tc : (S-Exp -> Type))
@@ -274,9 +296,7 @@
                {obj {run {lam {n : num}
                               {if {<= n 0} 1 {* n {{msg fact run} {- n 1}}}}}}}
                {{msg fact run} 10}})
-        (numT))
+        (numT)))
-
-  )
 
 (module+ test
   (test (tc `{,obj-fun {obj {n-func {lam {x : num} x}}
@@ -286,3 +306,24 @@
                    ,obj-fun
                    {f ,sampler}})
         (numT)))
+
+(module+ test
+  (test (subtype? (arrowT hello-t hello-t)
+                  (arrowT hello-t hello-t)) #t)
+  (test (subtype? (arrowT hello-t hello-t)
+                  (arrowT hello-t hello-goodbye-t)) #f)
+  (test (subtype? (arrowT hello-t hello-goodbye-t)
+                  (arrowT hello-t hello-t)) #t)
+  (test (subtype? (arrowT hello-t hello-goodbye-t)
+                  (arrowT hello-goodbye-t hello-t)) #t)
+  (test (subtype? (arrowT hello-goodbye-t hello-goodbye-t)
+                  (arrowT hello-t hello-t)) #f)
+  ;; for coverage
+  (define non-object-fun `{lam {x : num} {msg x hello}})
+  ;; `x` is bound to `numT`, which is not an object type
+  (test/exn (tc non-object-fun) "bound variable is not an object")
+  (test (subtype? hello-t (boolT)) #f)
+  (test (subtype? (boolT) (boolT)) #t)
+  (test (subtype? (boolT) (numT)) #f)
+  (test (subtype? (arrowT (numT) (numT)) (numT)) #f)
+  (test (subtype? (numT) (arrowT (numT) (numT))) #f))

Final/1.rkt

@@ -0,0 +1,119 @@
+#lang plait
+(define-type Exp
+  [numE (val : Number)]
+  [plusE (l : Exp) (r : Exp)]
+  [varE (name : Symbol)]
+  [let1E (id : Symbol) (named-expr : Exp) (bound-body : Exp)]
+  [lamE (param : Symbol) (body : Exp)]
+  [callWith (id : Symbol) (bound-expr : Exp) (fun : Exp) (val : Exp)]
+  [appE (fun : Exp) (val : Exp)])
+
+(define-type Value
+  [numV (n : Number)]
+  [lamV (arg : Symbol) (body : Exp) (env : Env)])
+
+(define-type-alias Env (Hashof Symbol Value))
+(define mt-env (hash empty)) ;; "empty environment"
+
+(define (lookup (s : Symbol) (n : Env))
+  (type-case (Optionof Value) (hash-ref n s)
+    [(none) (error s "not bound")]
+    [(some v) v]))
+
+(define (extend old-env new-name value)
+  (hash-set old-env new-name value))
+
+(define (interp expr env)
+  (type-case Exp expr
+    [(numE n) (numV n)]
+    [(plusE l r)
+     (numV (+ (numV-n (interp l env)) (numV-n (interp r env))))]
+    [(let1E bound-id named-expr bound-body)
+     (interp bound-body (extend env bound-id (interp named-expr env)))]
+    [(varE name) (lookup name env)]
+    [(lamE bound-id bound-body) (lamV bound-id bound-body env)]
+    ; Wordy double extend, as first setting up the f-env with the value it is dynamically scoped with.
+    ; Then, extending that environment with the function that is being used on the value.
+    [(callWith with-id with-expr fun-expr arg-expr)
+     (let ([fval (interp fun-expr env)])
+       (type-case Value fval
+         [(lamV bound-id bound-body f-env)
+          (interp bound-body (extend (extend f-env with-id (interp with-expr env)) bound-id (interp arg-expr env)))]
+         [else (error 'interp "non-function")]))]
+    [(appE fun-expr arg-expr)
+     (let ([fval (interp fun-expr env)])
+       (type-case Value fval
+         [(lamV bound-id bound-body f-env)
+          (interp bound-body
+                  (extend f-env bound-id (interp arg-expr env)))]
+         [else (error 'interp
+                      (string-append "`call' expects a function, got: "
+                                     (to-string fval)))]))]))
+
+(module+ test
+  (print-only-errors #t)
+  (define (example body)
+    (let1E 'x (numE 3)
+           (let1E 'f (lamE 'y (plusE (varE 'x) (varE 'y)))
+                  body)))
+
+
+  (test (interp (example (appE (varE 'f) (numE 4))) mt-env)
+        (numV 7))
+
+  (test (interp
+         (example (callWith 'x (numE 5) (varE 'f) (numE 4))) mt-env)
+        (numV 9))
+
+  (test (interp
+         (example
+          (let1E 'f (lamE 'x (varE 'x))
+                 (callWith 'x (numE 5) (varE 'f) (numE 4))))
+         mt-env)
+        (numV 4))
+
+  (test (interp
+         (example
+          (let1E 'f (lamE 'y (varE 'x))
+                 (callWith 'x (numE 5) (varE 'f) (numE 4))))
+         mt-env)
+        (numV 5))
+
+  (test
+   (interp (callWith 'y (numE 7) (lamE 'x  (plusE (varE 'x) (varE 'y))) (numE 3))
+           mt-env)
+   (numV 10))
+  
+  (test/exn
+   (interp (callWith 'x (numE 7) (lamE 'x  (plusE (varE 'x) (varE 'y))) (numE 3))
+           mt-env)
+   "not bound")
+
+  (test
+   (interp 
+    (callWith 'x (numE 7) (lamE 'x  (plusE (varE 'x) (varE 'x))) (numE 3))
+    mt-env)
+   (numV 6))
+
+  (test
+   (interp
+    (let1E 'z (numE 7)
+           (callWith 'y (varE 'z) (lamE 'x  (plusE (varE 'x) (varE 'y))) (numE 3)))
+    mt-env)
+   (numV 10))
+  (test
+   (interp
+    (let1E 'f (lamE 'x  (plusE (varE 'x) (varE 'y)))
+           (callWith 'y (numE 7) (varE 'f) (numE 3)))
+    mt-env)
+   (numV 10))
+  (test
+   (interp
+    (let1E 'f  (lamE 'x  (plusE (varE 'x) (varE 'y)))
+           (let1E 'z (numE 7) (callWith 'y (varE 'z) (varE 'f) (numE 3))))
+    mt-env)
+   (numV 10))
+
+  (test/exn (interp (appE (varE 'g) (numE 4)) mt-env) "not bound")
+  (test/exn (interp (example (appE (numE 4) (varE 'f))) mt-env) "function")
+  (test/exn (interp (example (callWith 'x (numE 5) (numE 4) (varE 'f))) mt-env) "function"))

Final/2.rkt

@@ -0,0 +1,301 @@
+#lang plait
+(define-type Exp
+  [numE (n : Number)]
+  [plusE (lhs : Exp) (rhs : Exp)]
+  [minusE (lhs : Exp) (rhs : Exp)] [varE (name : Symbol)]
+  [lamE (param : Symbol) (body : Exp)]
+  [appE (fun-expr : Exp) (arg-expr : Exp)]
+  [errorE (msg : String)] ;; New
+  [if0E (test : Exp) (then : Exp) (else : Exp)]
+  [minus1E (n : Exp)]
+  [timesE (lhs : Exp) (rhs : Exp)]
+  )
+
+(define-type Value
+  [numV (n : Number)]
+  [errorV (msg : String)]
+  [funV (param : Symbol)
+        (body : Exp)
+        (env : Env)])
+
+(define-type Env
+  [emptyEnv]
+  [Extend (name : Symbol)
+          (value : Value)
+          (rest : Env)])
+
+(define (lookup name env)
+  (type-case Env env
+    [(emptyEnv) (error 'lookup (string-append "no binding for" (to-string name)))]
+    [(Extend id val rest-env)
+     (if (eq? id name)
+         val
+         (lookup name rest-env))]))
+
+
+(define-type Continuation
+  [emptyCont]
+  [plusSecondK (r : Exp)
+               (env : Env)
+               (k : Continuation)]
+  [doPlusK (v1 : Value)
+           (k : Continuation)]
+  [minusSecondK (r : Exp)
+                (env : Env)
+                (k : Continuation)]
+  [doMinusK (v1 : Value)
+            (k : Continuation)]
+  [doMinus1K (k : Continuation)]
+  [timesSecondK (r : Exp)
+                (env : Env)
+                (k : Continuation)]
+  [doTimesK (v1 : Value)
+            (k : Continuation)]
+  [appArgK (arg-expr : Exp)
+           (env : Env)
+           (k : Continuation)]
+  [doAppK (fun-val : Value)
+          (k : Continuation)]
+  [doIfK (then-expr : Exp)
+         (else-expr : Exp)
+         (env : Env)
+         (k : Continuation)]
+  )
+
+(define (parse-error sx)
+  (error 'parse (string-append "parse error: " (to-string sx))))
+
+(define (sx-ref sx n) (list-ref (s-exp->list sx) n))
+
+(define (parse sx)
+  (local
+      [(define (px i) (parse (sx-ref sx i)))]
+    (cond
+      [(s-exp-number? sx) (numE (s-exp->number sx))]
+      [(s-exp-symbol? sx) (varE (s-exp->symbol sx))]
+      [(s-exp-match? `(let1 SYMBOL ANY ANY) sx)
+       (let* ([id (s-exp->symbol (sx-ref sx 1))]
+              [named (px 2)]
+              [body (px 3)])
+         (appE (lamE id body) named))]
+      [(s-exp-match? `(lam (SYMBOL) ANY) sx)
+       (let* ([args (sx-ref sx 1)]
+              [varE (s-exp->symbol (sx-ref args 0))]
+              [body (px 2)])
+         (lamE varE body))]
+      [(s-exp-match? `(error STRING) sx) (errorE (s-exp->string (sx-ref sx 1)))]
+      [(s-exp-match? `(error ANY) sx) (parse-error sx)]
+      [(s-exp-match? `(-- ANY) sx) (minus1E (px 1))]
+      [(s-exp-match? `(ANY ANY) sx) (appE (px 0) (px 1))]
+      [(s-exp-list? sx)
+       (case (s-exp->symbol (sx-ref sx 0))
+         [(+) (plusE (px 1) (px 2))]
+         [(-) (minusE (px 1) (px 2))]
+         [(*) (timesE (px 1) (px 2))]
+         [(if0) (if0E (px 1) (px 2) (px 3))]
+         [else (parse-error sx)])]
+      [else (parse-error sx)])))
+
+(define (arith-op op val1 val2)
+  (local
+      [(define (numV->number v)
+         (type-case Value v
+           [(numV n) n]
+           [else (error 'arith-op
+                        (string-append "expects a number, got: " (to-string v)))]))]
+    (numV (op (numV->number val1)
+              (numV->number val2)))))
+
+(define (numzero? x)
+  (zero? (numV-n x)))
+
+(define (interp expr env k)
+  (type-case Exp expr
+    [(numE n) (continue k (numV n))]
+    [(plusE l r) (interp l env (plusSecondK r env k))]
+    [(minusE l r) (interp l env (minusSecondK r env k))]
+    [(varE name) (continue k (lookup name env))]
+    [(errorE msg) (errorV msg)]
+    [(lamE param body-expr)
+     (continue k (funV param body-expr env))]
+    [(appE fun-expr arg-expr)
+     (interp fun-expr env (appArgK arg-expr env k))]
+    [(if0E test-expr then-expr else-expr)
+     (interp test-expr env (doIfK then-expr else-expr env k))]
+    [(minus1E n) (interp n env (doMinus1K k))]
+    [(timesE l r) (interp l env (timesSecondK r env k))]
+    ))
+
+(define (continue [k : Continuation] [v : Value]) : Value
+  (type-case Continuation k
+    [(emptyCont) v]
+    [(plusSecondK r env next-k)
+     (interp r env (doPlusK v next-k))]
+    [(doPlusK v1 next-k)
+     (continue next-k (arith-op + v1 v))]
+    [(minusSecondK r env next-k)
+     (interp r env (doMinusK v next-k))]
+    [(doMinusK v1 next-k)
+     (continue next-k (arith-op - v1 v))]
+    [(doMinus1K next-k)
+     (continue next-k (arith-op - v (numV 1)))]
+    [(timesSecondK r env next-k)
+     (interp r env (doTimesK v next-k))]
+    [(doTimesK v1 next-k)
+     (continue next-k (arith-op * v1 v))]
+    [(appArgK arg-expr env next-k)
+     (interp arg-expr env (doAppK v next-k))]
+    [(doAppK fun-val next-k)
+     (interp (funV-body fun-val)
+             (Extend (funV-param fun-val) v (funV-env fun-val))
+             next-k)]
+    [(doIfK then-expr else-expr env next-k)
+     (if (numzero? v)
+         (interp then-expr env next-k)
+         (interp else-expr env next-k))]
+    ))
+
+(module+ test
+  (define init-k (emptyCont))
+
+  (define (run s-exp)
+    (interp (parse s-exp) (emptyEnv) (emptyCont)))
+
+
+  (test (interp (numE 10)
+                (emptyEnv)
+                init-k)
+        (numV 10))
+  (test (interp (plusE (numE 10) (numE 7))
+                (emptyEnv)
+                init-k)
+        (numV 17))
+  (test (interp (minusE (numE 10) (numE 7))
+                (emptyEnv)
+                init-k)
+        (numV 3))
+  (test (interp (appE (lamE 'x (plusE (varE 'x) (numE 12)))
+                      (plusE (numE 1) (numE 17)))
+                (emptyEnv)
+                init-k)
+        (numV 30))
+  (test (interp (varE 'x)
+                (Extend 'x (numV 10) (emptyEnv))
+                init-k)
+        (numV 10))
+
+  (test (interp (appE (lamE 'x (plusE (varE 'x) (numE 12)))
+                      (plusE (numE 1) (numE 17)))
+                (emptyEnv)
+                init-k)
+        (numV 30))
+
+
+  (test/exn (interp (varE 'x) (emptyEnv) init-k)
+            "no binding")
+
+  (test/exn
+   (run `{ {lam {x} {+ x y}} 0})
+   "no binding")
+
+  (test
+   (run
+    `{{lam {x}
+           {{lam {f} {f 2}}
+            {lam {y} {+ x y}}}}
+      0})
+   (numV 2))
+
+
+  (test (run `{let1 f {lam {x} {+ x 1}}
+                    {+ {f 2} {error "abort!"}}})
+        (errorV "abort!"))
+
+  (test (run `{{lam {x}
+                    {{lam {f}
+                          {+ {f 1}
+                             {{lam {x} {f 2}} 3}}}
+                     {lam {y} {+ x y}}}}
+               0})
+        (numV 3))
+
+  (test (interp (if0E (numE 0)
+                      (numE 1)
+                      (numE 2))
+                (emptyEnv)
+                init-k)
+        (numV 1))
+  (test (interp (if0E (numE 1)
+                      (numE 0)
+                      (numE 2))
+                (emptyEnv)
+                init-k)
+        (numV 2))
+
+  (test (run
+         `{{lam {mkrec}
+                {{lam {fib}
+                      ;; Call fib on 10:
+                      {fib 10}}
+                 ;; Create recursive fib:
+                 {mkrec
+                  {lam {fib}
+                       ;; Fib:
+                       {lam {n}
+                            {if0 n
+                                 1
+                                 {if0 {- n 1}
+                                      {error "reached zero"}
+                                      {+ {fib {- n 1}}
+                                         {fib {- n 2}}}}}}}}}}
+           ;; mkrec:
+           {lam {body-proc}
+                {{lam {fX}
+                      {fX fX}}
+                 {lam {fX}
+                      {body-proc {lam {x} {{fX fX} x}}}}}}})
+        (errorV "reached zero"))
+  )
+
+; unary decrement
+(module+ test
+  (test (parse `{-- 2}) (minus1E (numE 2))))
+
+(module+ test
+  (test (run `{-- 2}) (numV 1))
+  (test (run `{{lam {x} {-- x}} 3}) (numV 2))
+  (test (run `{{lam {y} {+ {-- y} {-- y}}} 10}) (numV 18))
+  (test (run `{{lam {f} {f 4}} {lam {x} {-- x}}}) (numV 3)))
+
+; multiplication
+(module+ test
+  (define fact-prog
+    `{{lam {mkrec}
+           {{lam {fact}
+                 ;; Call fact on 5:
+                 {fact 5}}
+            ;; Create recursive fact
+            {mkrec
+             {lam {fact}
+                  {lam {n}
+                       {if0 n
+                            1
+                            {* n {fact {-- n}}}}}}}}}
+      ;; mkrec:
+      {lam {body-proc}
+           {{lam {fX}
+                 {fX fX}}
+            {lam {fX}
+                 {body-proc {lam {x} {{fX fX} x}}}}}}})
+
+  (test (run fact-prog) (numV 120)))
+
+; stupid tests for coverage
+(module+ test
+  (test/exn (parse-error 'invalid-syntax) "invalid-syntax")
+  (test (parse `(error "test error")) (errorE "test error"))
+  (test/exn (parse `(error 123)) "parse error")
+  (test/exn (parse `(unknown 1 2 3)) "parse error")
+  (test/exn (arith-op + (numV 1) (errorV "not a number")) "expects a number")
+  (test/exn (parse `#f) "parse error"))
+  

Final/3.rkt

@@ -0,0 +1,416 @@
+#lang plai/gc2/collector
+;; metadata size
+(define METADATA-SIZE 2)
+
+;; where the start of the current "to space" is stored in the heap.
+(define LOC:OFFSET 0)
+
+;; where the allocation pointer is stored in the heap
+(define LOC:PTR 1)
+
+;; Start of the current "to space"
+(define (off) (heap-ref LOC:OFFSET))
+
+;; Offset into the current "to space" where free space starts.
+(define (ptr) (heap-ref LOC:PTR))
+
+;; How big are the semi-spaces?
+(define (space-size)
+  (quotient (- (heap-size) METADATA-SIZE) 2))
+
+;; All functions named gc:*, along with init-allocator, must be
+;; implemented by any plai/gc2 collector. For their functionality and
+;; interface see [1].
+
+(define (init-allocator)
+  (heap-set! LOC:OFFSET METADATA-SIZE)
+  (heap-set! LOC:PTR 0))
+
+(module+ test
+  (test (with-heap (make-vector 1000)  (+ METADATA-SIZE (space-size) (space-size))) 1000)
+  (test (with-heap (make-vector 999)  (+ METADATA-SIZE (space-size) (space-size))) 998))
+
+
+;; Define some syntax rules to make it easier to write tests
+
+;; Test if the last two expressions are equal.
+;; Takes a vector for a heap
+
+(define-syntax (test/heap stx)
+  (syntax-case stx ()
+    [(test/heap heap oper ...  expected)
+     (syntax-protect
+      #`(with-heap heap
+          (init-allocator)
+          #,(syntax/loc stx
+              (test (begin oper ...) expected))))]))
+
+;; Test if one of the expressions before the last throws an exception
+;; matching the last expression (a string).
+;; Takes a vector for a heap
+(define-syntax (test/heap/exn stx)
+  (syntax-case stx ()
+    [(test/heap heap oper ...  expected)
+     (syntax-protect
+      #`(with-heap heap
+          (init-allocator)
+          #,(syntax/loc stx
+              (test/exn (begin oper ...) expected))))]))
+
+(define (swap-spaces!)
+  (let ([current-offset (off)])
+    (if (= current-offset METADATA-SIZE)
+        ;; If left semi-space, switch to the right
+        (begin
+          (heap-set! LOC:OFFSET (+ METADATA-SIZE (space-size)))
+          (heap-set! LOC:PTR 0))
+        ;; Else switch back to the left semi-space
+        (begin
+          (heap-set! LOC:OFFSET METADATA-SIZE)
+          (heap-set! LOC:PTR 0)))))
+
+(module+ test
+
+  ;; Initially, allocations are in the left half.
+  (test/heap
+      (make-vector (+ 4 METADATA-SIZE) '?)
+    (gc:alloc-flat #f)
+    (current-heap)
+    #(2 2 flat #f ? ?))
+
+  ;; After calling swap-spaces!, allocations are in the right half
+  (test/heap
+      (make-vector (+ 4 METADATA-SIZE) '?)
+    (swap-spaces!)
+    (gc:alloc-flat #f)
+    (current-heap)
+    #(4 2 ? ? flat #f))
+
+  ;; Swapping twice is back to allocating in left
+  (test/heap
+      (make-vector (+ 4 METADATA-SIZE) '?)
+    (swap-spaces!)
+    (swap-spaces!)
+    (gc:alloc-flat #f)
+    (current-heap)
+    #(2 2 flat #f ? ?))
+  )
+
+;; malloc : size -> address
+(define (malloc n . other-roots)
+  (when (> (+ (ptr) n) (space-size))
+    (gc!))
+  (when (> (+ (ptr) n) (space-size))
+    (error 'malloc "out of memory!"))
+  (heap-set! LOC:PTR (+ (ptr) n))
+  (+ (heap-ref LOC:OFFSET) (- (ptr) n)))
+
+(define (forward/root thing)
+  (define addr (read-root thing))
+  (define fwrd (+ 1 addr))
+  (cond
+    [(gc:flat? addr) (heap-set! fwrd (gc:alloc-flat (gc:deref addr)))]
+    ; maybe forward root on each cons cell? could fix what seems to be memory corruption
+    [(gc:cons? addr) (heap-set! fwrd (gc:cons (simple-root (gc:first addr)) (simple-root (gc:rest addr))))]
+    [(gc:closure? addr)
+     (let ([code-ptr (gc:closure-code-ptr addr)]
+           [n-vars (heap-ref (+ addr 2))])
+       (heap-set! fwrd
+                  (gc:closure code-ptr
+                              (for/list ([i (in-range n-vars)])
+                                (forward/root (simple-root (gc:closure-env-ref addr i)))))))])
+  (heap-set! addr 'forwarded))
+
+(define (gc! . other-roots)
+  (swap-spaces!)
+  (heap-set! LOC:PTR 0)  ; Reset the allocation pointer in the new semi-space
+
+  ;; Forward all roots to the new semi-space
+  (for-each forward/root (get-root-set))
+  (for-each forward/root other-roots))
+
+;; gc:alloc-flat : flat-value -> address
+(define (gc:alloc-flat value)
+  (define addr (malloc 2))
+  (heap-set! addr 'flat)
+  (heap-set! (+ addr 1) value)
+  addr)
+
+;; gc:flat? : address -> boolean
+(define (gc:flat? address)
+  (equal? (heap-ref address) 'flat))
+
+;; gc:deref : address -> flat-value
+(define (gc:deref address)
+  (unless (gc:flat? address)
+    (error 'gc:deref "not a flat: ~a" address))
+  (heap-ref (+ address 1)))
+
+;; gc:cons : root root -> address
+(define (gc:cons root1 root2)
+  (define addr (malloc 3 root1 root2))
+  (heap-set! addr 'cons)
+  (heap-set! (+ addr 1) (read-root root1))
+  (heap-set! (+ addr 2) (read-root root2))
+  addr)
+
+;; gc:cons? : address -> boolean
+(define (gc:cons? address)
+  (equal? (heap-ref address) 'cons))
+
+;; gc:first : address -> address
+(define (gc:first address)
+  (unless (gc:cons? address)
+    (error 'gc:first "not a pair: ~a" address))
+  (heap-ref (+ address 1)))
+
+;; gc:rest : address -> address
+(define (gc:rest address)
+  (unless (gc:cons? address)
+    (error 'gc:rest "not a pair: ~a" address))
+  (heap-ref (+ address 2)))
+
+;; gc:set-first! : address address -> void
+(define (gc:set-first! address new-value-address)
+  (unless (gc:cons? address)
+    (error 'gc:set-first! "not a pair: ~a" address))
+  (heap-set! (+ address 1) new-value-address))
+
+;; gc:set-rest! : address address -> void
+(define (gc:set-rest! address new-value-address)
+  (unless (gc:cons? address)
+    (error 'gc:set-rest! "not a pair: ~a" address))
+  (heap-set! (+ address 2) new-value-address))
+
+;; gc:closure : opaque-value (listof root) -> address
+(define (gc:closure code-ptr free-vars)
+  (define n-vars (length free-vars))
+  (define addr (malloc (+ 3 n-vars)))
+  (heap-set! addr 'clos)
+  (heap-set! (+ addr 1) code-ptr)
+  (heap-set! (+ addr 2) n-vars)
+  (for ([i  (in-range n-vars)]
+        [fv (in-list free-vars)])
+    (heap-set! (+ addr 3 i) (read-root fv)))
+  addr)
+
+;; gc:closure? : address -> boolean
+(define (gc:closure? address)
+  (equal? (heap-ref address) 'clos))
+
+;; gc:closure-code-ptr : address -> opaque-value
+(define (gc:closure-code-ptr address)
+  (unless (gc:closure? address)
+    (error 'gc:closure-code-ptr "not a closure: ~a" address))
+  (heap-ref (+ address 1)))
+
+;; gc:closure-env-ref : address integer -> address
+(define (gc:closure-env-ref address i)
+  (unless (gc:closure? address)
+    (error 'gc:closure-env-ref "not a closure: ~a" address))
+  (heap-ref (+ address 3 i)))
+
+(module+ test
+  ;; OOM
+  (test/heap/exn (make-vector METADATA-SIZE)
+    (gc:alloc-flat #f)
+    "out of memory")
+
+  ;; OOM due to using only half of the heap
+  (test/heap/exn
+      (make-vector (+ 2 METADATA-SIZE))
+    (gc:alloc-flat #f)
+    "out of memory")
+
+  ;; dereferencing cons as flat
+  (test/heap/exn (make-vector 1000)
+    (let ([cons-addr
+           (gc:cons
+            (simple-root (gc:alloc-flat #f))
+            (simple-root (gc:alloc-flat #t)))])
+      (gc:deref cons-addr))
+    "not a flat")
+
+  ;; dereferencing flat as cons
+  (test/heap/exn (make-vector 1000)
+    (let ([flat-addr (gc:alloc-flat #f)])
+      (gc:first flat-addr))
+    "not a pair")
+
+  ;; dereferencing flat as cons
+  (test/heap/exn (make-vector 1000)
+    (let ([flat-addr (gc:alloc-flat #f)])
+      (gc:rest flat-addr))
+    "not a pair")
+
+  ;; setting flat as cons
+  (test/heap/exn (make-vector 1000)
+    (let ([flat-addr (gc:alloc-flat #f)])
+      (gc:set-first! flat-addr #t))
+    "not a pair")
+
+  ;; setting flat as cons
+  (test/heap/exn (make-vector 1000)
+    (let ([flat-addr (gc:alloc-flat #f)])
+      (gc:set-rest! flat-addr #t))
+    "not a pair")
+
+  ;; getting code ptr from non closure
+  (test/heap/exn (make-vector 1000)
+    (let ([flat-addr (gc:alloc-flat #f)])
+      (gc:closure-code-ptr flat-addr))
+    "not a closure")
+
+  ;; getting code ptr from non closure
+  (test/heap/exn (make-vector 1000)
+    (let ([flat-addr (gc:alloc-flat #f)])
+      (gc:closure-env-ref flat-addr 1))
+    "not a closure")
+
+  ;; Successful dereference: flat
+  (test/heap (make-vector 1000)
+    (gc:deref (gc:alloc-flat #t))
+    #t)
+
+  ;; successful dereference: cons
+  (test/heap (make-vector 1000)
+    (gc:deref
+     (gc:rest
+      (gc:cons
+       (simple-root (gc:alloc-flat 'first))
+       (simple-root (gc:alloc-flat 'rest)))))
+    'rest)
+
+  (test/heap (make-vector 1000)
+    (gc:deref
+     (gc:first
+      (gc:cons
+       (simple-root (gc:alloc-flat 'first))
+       (simple-root (gc:alloc-flat 'rest)))))
+    'first)
+
+  ;; successful alloc / deref closure
+  (test/heap (make-vector 1000)
+    (gc:closure-code-ptr
+     (gc:closure 'dummy '()))
+    'dummy)
+
+  (test/heap (make-vector 1000)
+    (gc:deref
+     (gc:closure-env-ref
+      (gc:closure
+       'dummy
+       (list (simple-root (gc:alloc-flat #f))))
+      0))
+    #f)
+
+  ;; setting cons parts
+  (test/heap (make-vector 1000)
+    (let ([cons-loc
+           (gc:cons
+            (simple-root (gc:alloc-flat 'first))
+            (simple-root (gc:alloc-flat 'rest)))])
+      (gc:set-first! cons-loc (gc:alloc-flat 'mutated))
+      (gc:deref (gc:first cons-loc)))
+    'mutated)
+
+  (test/heap (make-vector 1000)
+    (let ([cons-loc
+           (gc:cons
+            (simple-root (gc:alloc-flat 'first))
+            (simple-root (gc:alloc-flat 'rest)))])
+      (gc:set-rest! cons-loc (gc:alloc-flat 'mutated))
+      (gc:deref (gc:rest cons-loc)))
+    'mutated)
+  )
+
+(module+ test
+  ;; heap state after initial allocation
+  (test/heap
+      (make-vector 12 '?)
+    (gc:alloc-flat #f)
+    (current-heap)
+    #(2 2 flat #f ? ?  ? ? ? ? ? ?))
+
+  (test/heap
+      (make-vector 18  '?)
+    (gc:cons
+     (simple-root (gc:alloc-flat #f))
+     (simple-root (gc:alloc-flat #t)))
+    (current-heap)
+    #(2 7 flat #f flat #t cons 2 4 ? ? ? ? ? ? ? ? ?))
+
+  (test/heap
+      (make-vector 18  '?)
+    (gc:closure
+     'dummy
+     (list (simple-root (gc:alloc-flat #f))))
+    (current-heap)
+    #(2 6 flat #f clos dummy 1 2 ? ? ? ? ? ? ? ? ? ?))
+  )
+
+(module+ test
+  ;; heap state and roots after gc
+
+  (test/heap
+      (make-vector 12 '?)
+    (define f1 (gc:alloc-flat #f))
+    (with-roots (f1)
+      (gc!)
+      (cons (current-heap) (map read-root (get-root-set))))
+    (cons
+     #(7 2 forwarded 7 ? ? ? flat #f ? ? ?)
+     '(7)))
+
+  (test/heap
+      (make-vector 18  '?)
+    (define c1
+      (gc:cons
+       (simple-root (gc:alloc-flat #f))
+       (simple-root (gc:alloc-flat #t))))
+    (with-roots (c1)
+      (gc!)
+      (cons (current-heap) (map read-root (get-root-set))))
+    (cons
+     #(10 7 forwarded 13 forwarded 15 forwarded 10 4 ? cons 13 15 flat #f flat #t ?)
+     '(10)))
+
+  (test/heap
+      (make-vector 18  '?)
+    (define cl1
+      (gc:closure 'dummy (list (simple-root (gc:alloc-flat #f)))))
+    (with-roots (cl1)
+      (gc!)
+      (cons (current-heap) (map read-root (get-root-set))))
+    (cons
+     #(10 6 forwarded 14 forwarded 10 1 2 ? ? clos dummy 1 14 flat #f ? ?)
+     '(10)))
+
+  ;; Test for coverage of forwarded tags.
+  (test/heap
+      (make-vector 26 '?)
+    (define c1
+      (gc:cons
+       (simple-root (gc:alloc-flat 2))
+       (simple-root (gc:alloc-flat empty))))
+    (define c2
+      (gc:cons
+       (simple-root (gc:alloc-flat 1))
+       (simple-root c1)))
+    ;; force both cons cells to be moved before starting update pass
+    (with-roots (c1 c2)
+      (gc!)
+      (current-heap))
+    #(14 12
+         forwarded 20 forwarded 22 forwarded 14 4 forwarded 24 forwarded 17 6
+         cons 20 22 cons 24 14 flat 2 flat () flat 1)
+    )
+  )
+
+(module+ test
+  (test/heap
+      (make-vector 12 '?)
+    (define f1 (gc:alloc-flat #f))
+    (gc! (simple-root f1))
+    (current-heap)
+    #(7 2 forwarded 7 ? ? ? flat #f ? ? ?)))