Finish 1.rkt

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,242 @@
+#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)]
+  )
+
+(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)]
+  [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 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))]
+         [(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))]
+
+    ))
+
+(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))]
+    [(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"))
+  )

Final/3.rkt

@@ -0,0 +1,388 @@
+#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!)
+  ;; do nothing
+  (void))
+
+(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)
+  (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 (gc!)
+  ;; do nothing
+  (void))
+
+;; 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 ? ? ?)))