Improve 3.rkt a bit

Assignments/03.rkt

@@ -390,16 +390,16 @@
      (let* ([arg-type (parse-type te)]
             [res-type (typecheck body (BindType name arg-type env))])
        (arrowT arg-type res-type))]
-    [(listE elements) (local [(define type-list (map (lambda (x) (typecheck x env)) elements))
-                              (define filtered (filter (lambda (x) (equal? (first type-list) x)) type-list))]
+    [(listE elements) (local ;; this sucks. do not think it's right but it passes tests
+                        [(define type-list (map (lambda (x) (typecheck x env)) elements))
+                         (define filtered (filter (lambda (x) (equal? (first type-list) x)) type-list))
+                         (define (check-all lst)
+                           (type-case Type (first type-list)
+                             [(varT v t) (second type-list)]
+                             [else (error 'typecheck "no type")]))]
                         (if (equal? filtered type-list)
                             (listT (first type-list))
-                            (type-case Type (first type-list)
-                              [(varT v t) (if (none? (unbox t))
-                                            (listT (second type-list))
-                                            (error 'typecheck "no type"))]
-                              [else (error 'typecheck "no type")])))]
-    ))
+                            (listT (check-all type-list))))]))
 ;; ----------------------------------------
 
 (define-syntax-rule (test/type expr type)

Assignments/04.rkt

@@ -0,0 +1,329 @@
+#lang plait
+(define-type TypeExp
+  [numTE]
+  [boolTE]
+  [arrowTE (arg : TypeExp)
+           (result : TypeExp)]
+  [objTE (fields : (Listof (Symbol * TypeExp)))])
+
+(define-type Exp
+  [numE (n : Number)]
+  [boolE (b : Boolean)]
+  [plusE (left : Exp) (right : Exp)]
+  [timesE (left : Exp) (right : Exp)]
+  [minusE (left : Exp) (right : Exp)]
+  [leqE (left : Exp) (right : Exp)]
+  [lamE (var : Symbol) (te : TypeExp) (body : Exp)]
+  [appE (fun : Exp) (arg : Exp)]
+  [varE (name : Symbol)]
+  [ifE (check : Exp) (zero : Exp) (non-zero : Exp)]
+  [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)])
+
+(define-type Type
+  [numT]
+  [boolT]
+  [arrowT (arg : Type)
+          (result : Type)]
+  [objT (fields : (Hashof Symbol Type))])
+
+(define-type-alias TypeEnv (Hashof Symbol Type))
+
+(define mt-type-env (hash empty)) ;; "empty type environment"
+(define (type-lookup (s : Symbol) (n : TypeEnv))
+  (type-case (Optionof Type) (hash-ref n s)
+    [(none) (error s "not bound")]
+    [(some b) b]))
+
+(module+ test
+  (test/exn (type-lookup 'x mt-type-env) "not bound"))
+
+(define (type-extend (env : TypeEnv) (s : Symbol) (t : Type))
+  (hash-set env s t))
+
+(define (interp-te te)
+  (type-case TypeExp te
+    [(numTE) (numT)]
+    [(boolTE) (boolT)]
+    [(arrowTE a b) (arrowT (interp-te a)
+                           (interp-te b))]
+    [(objTE fields) (objT (hash
+                           (map (lambda (key-val)
+                                  (values (fst key-val)
+                                          (interp-te (snd key-val))))
+                                fields)))]))
+(module+ test
+  (test (interp-te (objTE
+                    (list (pair 'add1 (arrowTE (numTE) (numTE)))
+                          (pair 'compare (arrowTE (numTE) (boolTE))))))
+        (objT (hash (list (pair 'add1 (arrowT (numT) (numT)))
+                          (pair 'compare (arrowT (numT) (boolT))))))))
+
+(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))))))
+  (define hello-goodbye-t (objT (hash (list
+                                       (pair 'hello (numT))
+                                       (pair 'goodbye (boolT))))))
+  (test (subtype? (numT) (boolT)) #f)
+  (test (subtype? (numT) (numT)) #t)
+  (test (subtype? (numT) hello-t) #f)
+  (test (subtype? hello-t (objT (hash (list (pair 'hello (boolT)))))) #f)
+  (test (subtype? hello-goodbye-t hello-t) #t)
+  (test (subtype? hello-t hello-goodbye-t) #f))
+
+(define (typecheck [exp : Exp] [env : TypeEnv]) : Type
+  (local
+    [(define (num2 l r type)
+       (let ([left-t (typecheck l env)]
+             [right-t (typecheck r env)])
+         (if (and (equal? (numT) left-t) (equal? (numT) right-t))
+             type
+             (error 'typecheck "expected 2 num"))))]
+    (type-case Exp exp
+      [(numE n) (numT)]
+      [(boolE b) (boolT)]
+      [(plusE l r) (num2 l r (numT))]
+      [(minusE l r) (num2 l r (numT))]
+      [(timesE l r) (num2 l r (numT))]
+      [(leqE l r) (num2 l r (boolT))]
+      [(varE s) (type-lookup s env)]
+      [(lamE name te body)
+       (let* ([arg-type (interp-te te)]
+              [body-type (typecheck body (type-extend env name arg-type))])
+         (arrowT arg-type body-type))]
+      [(appE fn arg)
+       (type-case Type (typecheck fn env)
+         [(arrowT arg-type result-type)
+          (let ([actual-type (typecheck arg env)])
+            (if (subtype? actual-type arg-type)  ;; Use subtype? to check compatibility
+                result-type
+                (error 'typecheck "argument type")))]
+         [else (error 'typecheck "not function")])]
+      [(ifE c t f)
+       (if (equal? (typecheck c env) (boolT))
+           (let ([t-type (typecheck t env)]
+                 [f-type (typecheck f env)])
+             (if (equal? f-type t-type)
+                 f-type
+                 (error 'typecheck "branches must have same type")))
+           (error 'typecheck "expected boolean"))]
+      [(let1E var te val body)
+       (let* ([var-t (interp-te te)]
+              [val-t (typecheck val env)]
+              [body-t (typecheck body (type-extend env var var-t))])
+         (if (equal? var-t val-t)
+             body-t
+             (error 'typecheck "type does not match annotation")))]
+      [(recE var te val body)
+       (let* ([var-t (interp-te te)]
+              [val-t (typecheck val (type-extend env var var-t))]
+              [body-t (typecheck body (type-extend env var var-t))])
+         (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)))]
+            [field-list (map extract-exp fields)])
+         (objT (hash field-list)))]
+      [(msgE obj 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)
+            [(objT fields) (type-lookup selector fields)]
+            [else (error 'typecheck "bound variable is not an 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"))
+
+(define (sx-ref sx n) (list-ref (s-exp->list sx) n))
+
+(define (parse-te sx)
+  (cond
+    [(s-exp-symbol? sx)
+     (case (s-exp->symbol sx)
+       [(num) (numTE)]
+       [(bool) (boolTE)])]
+    [(s-exp-match? `(ANY -> ANY) sx)
+     (arrowTE (parse-te (sx-ref sx 0)) (parse-te (sx-ref sx 2)))]
+    [(s-exp-match? `(obj (SYMBOL ANY) ...) sx)
+     (objTE
+      (map (lambda (element)
+             (pair (s-exp->symbol (sx-ref element 0))
+                   (parse-te (sx-ref element 1))))
+           (rest (s-exp->list sx))))]))
+
+(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)
+       (let ([sym (s-exp->symbol sx)])
+         (case sym
+           [(true) (boolE #t)]
+           [(false) (boolE #f)]
+           [else (varE sym)]))]
+      [(s-exp-match? `(msg ANY SYMBOL) sx)
+       (msgE (px 1) (s-exp->symbol (sx-ref sx 2)))]
+      [(s-exp-match? `(obj (SYMBOL ANY) ...) sx)
+       (objE
+        (map
+         (lambda (element)
+           (pair (s-exp->symbol (sx-ref element 0))
+                 (parse (sx-ref element 1))))
+         (rest (s-exp->list sx))))]
+      [(s-exp-match? `(lam (SYMBOL : ANY) ANY) sx)
+       (let* ([args (sx-ref sx 1)]
+              [id (s-exp->symbol (sx-ref args 0))]
+              [te (parse-te (sx-ref args 2))]
+              [body (px 2)])
+         (lamE id te body))]
+      [(s-exp-match? `(let1 (SYMBOL : ANY) ANY ANY) sx)
+       (let* ([args (sx-ref sx 1)]
+              [id (s-exp->symbol (sx-ref args 0))]
+              [te (parse-te (sx-ref args 2))]
+              [rhs (px 2)]
+              [body (px 3)])
+         (let1E id te rhs body))]
+      [(s-exp-match? `(rec (SYMBOL : ANY) ANY ANY) sx)
+       (let* ([args (sx-ref sx 1)]
+              [id (s-exp->symbol (sx-ref args 0))]
+              [te (parse-te (sx-ref args 2))]
+              [rhs (px 2)]
+              [body (px 3)])
+         (recE id te rhs body))]
+      [(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))]
+         [(<=) (leqE (px 1) (px 2))]
+         [(if) (ifE (px 1) (px 2) (px 3))]
+         [else (parse-error sx)])]
+      [else (parse-error sx)])))
+
+(module+ test
+  (test (parse `{obj {hello true} {goodbye 42}})
+        (objE (list (pair 'hello (boolE #t))
+                    (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))))
+
+
+(tc : (S-Exp -> Type))
+(define (tc s)
+  (typecheck (parse s) mt-type-env))
+
+(module+ test
+  (test (tc `{+ 1 2}) (numT))
+  (test/exn (tc `{+ true 2}) "expected 2 num")
+  (test/exn (tc `{1 1}) "function")
+  (test/exn (tc `{{lam {b : bool} false} 1}) "argument type")
+  (test/exn (tc `{if false 1 true}) "branches")
+  (test/exn (tc `{if 1 false true}) "boolean")
+  (test/exn (tc `{let1 [x : num] true x}) "annotation")
+  (test/exn (tc `{rec [x : num] true x}) "annotation"))
+
+(module+ test
+  (define sampler `{obj {hello true}
+                        {goodbye false}
+                        {a-num 42}
+                        {n-func {lam {x : num} x}}
+                        {b-func {lam {x : bool} x}}
+                        })
+  (test (tc sampler)
+        (objT (hash (list (pair 'hello (boolT))
+                          (pair 'goodbye (boolT))
+                          (pair 'a-num (numT))
+                          (pair 'n-func (arrowT (numT) (numT)))
+                          (pair 'b-func (arrowT (boolT) (boolT)))))))
+  (test (tc `{msg ,sampler hello}) (boolT))
+  (test/exn (tc `{msg 1 hello}) "object")
+  (test/exn (tc `{msg ,sampler blah}) "unknown field")
+  (define obj-fun `{lam {x : (obj (n-func (num -> num)))} {{msg x n-func} 3}})
+  (test (tc obj-fun) (arrowT
+                      (objT (hash (list (pair 'n-func (arrowT (numT) (numT))))))
+                      (numT)))
+  (test (tc `{,obj-fun {obj {n-func {lam {x : num} x}}}}) (numT))
+  (test/exn (tc `{,obj-fun 2}) "argument type")
+  (test/exn (tc `{if true ,obj-fun 2}) "branches")
+  (test (tc `{rec {fact : (obj (run (num -> num)))}
+               {obj {run {lam {n : num}
+                              {if {<= n 0} 1 {* n {{msg fact run} {- n 1}}}}}}}
+               {{msg fact run} 10}})
+        (numT)))
+
+(module+ test
+  (test (tc `{,obj-fun {obj {n-func {lam {x : num} x}}
+                            {b-func {lam {x : bool} x}}}}) (numT))
+
+  (test (tc `{let1 {f : {(obj (n-func (num -> num))) -> num}}
+                   ,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 ? ? ?)))

Labs/09.rkt

@@ -0,0 +1,204 @@
+#lang racket
+(require [only-in plait test test/exn error print-only-errors])
+
+(module call-dyn plait
+  (define-type DynExp
+    [numE (val : Number)]
+    [plusE (l : DynExp) (r : DynExp)]
+    [varE (name : Symbol)]
+    [let1E (id : Symbol) (named-expr : DynExp) (bound-body : DynExp)]
+    [lamE (param : Symbol) (body : DynExp)]
+    [appDynE (fun : DynExp) (val : DynExp)]
+    [appE (fun : DynExp) (val : DynExp)])
+  (define-type Value
+    [numV (n : Number)]
+    [lamV (arg : Symbol) (body : DynExp) (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 DynExp 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)]
+      [(appDynE 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 env bound-id (interp arg-expr f-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 "non-function")]))]))
+  )
+
+(require 'call-dyn)
+(module+ test
+  (define (example body)
+    (let1E 'x (numE 3)
+           (let1E 'f (lamE 'y (plusE (varE 'x) (varE 'y)))
+                  (let1E 'x (numE 5)
+                         body))))
+
+  (test (interp (example (appE (varE 'f) (numE 4))) mt-env)
+        (numV 7))
+
+  (test (interp
+         (example (appDynE (varE 'f) (numE 4))) mt-env)
+        (numV 9))
+
+  (test (interp
+         (example
+          (let1E 'f (lamE 'x (varE 'x))
+                 (appDynE (varE 'f) (numE 4))))
+         mt-env)
+        (numV 4))
+
+  (test (interp
+         (example
+          (let1E 'f (lamE 'y (varE 'x))
+                 (appDynE (varE 'f) (numE 4))))
+         mt-env)
+        (numV 5))
+
+  (test (interp
+         (example
+          (let1E 'f (lamE 'y (varE 'x))
+                 (let1E 'x (numE 3)
+                        (appDynE (varE 'f) (numE 4)))))
+         mt-env)
+        (numV 3))
+
+  (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 (appDynE (numE 4) (varE 'f))) mt-env) "function")
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This part provides 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-syntax-rule (with-heap vec expr ...)
+  (parameterize
+      ([current-heap vec])
+    (begin
+      expr ...)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This part is the partial implementation of a collector API For
+;; simplicity, use our very first allocator without any data
+;; structure.
+
+(define (init-allocator)
+  (vector-fill! (current-heap) 'free))
+
+(define (alloc/header tag . vals)
+  (define loc (malloc (+ 1 (length vals))))
+  (heap-set! loc tag)
+  (for ([i (in-range (length vals))]
+        [v (in-list vals)])
+    (heap-set! (+ loc i 1) v))
+  loc)
+
+(define (gc:alloc-flat val) (alloc/header 'flat val))
+
+(define (gc:cons val1 val2) (alloc/header 'cons val1 val2))
+
+
+;; Linear time allocator, based on Lecture 20
+
+(define (malloc size)
+  (define ptr (find-free-space size))
+  (unless ptr  (error 'alloc "out of memory"))
+  ptr)
+
+(module+ test
+  (with-heap (make-vector 10 #f)
+    (init-allocator)
+    (test/exn (malloc 100) "out of memory")))
+
+(define (find-free-space n)
+  (define (n-free-blocks? start n)
+    (for/fold ([ok #t])
+              ([i (in-range start (+ start n))])
+      (and ok (< i (heap-size)) (equal? (heap-ref i) 'free))))
+
+  (define (loop start)
+    (and
+     (< start (heap-size))
+     (case (heap-ref start)
+       [(flat) (loop (+ start 2))]
+       [(cons) (loop (+ start 3))]
+       [(free) (if (n-free-blocks? start n)
+                   start
+                   (loop (+ start 1)))]
+       [else (error 'find-free-space
+                    "unexpected tag ~a" start)])))
+  (loop 0))
+
+;; Here is the function you need to write for Q2
+(define (free/mark-white!)
+  (for ([current-cell (current-heap)]
+        [i (in-range 0 (heap-size))])
+    (case current-cell
+      [(flat) (heap-set! i 'white-flat)]
+      [(cons) (heap-set! i 'white-cons)]
+      [(white-flat) (heap-set! i 'free) (heap-set! (+ i 1) 'free)]
+      [(white-cons) (heap-set! i 'free) (heap-set! (+ i 1) 'free) (heap-set! (+ i 2) 'free)]
+      [else (void)])))
+
+(module+ test
+  (with-heap (make-vector 7 '?)
+    (init-allocator)
+    (test (current-heap) (make-vector 7 'free))
+    (gc:alloc-flat 'first)
+    (test (current-heap) #(flat first free free free free free))
+    (gc:alloc-flat 'rest)
+    (test (current-heap) #(flat first flat rest free free free))
+    (gc:cons 0 2)
+    (test (current-heap) #(flat first flat rest cons 0 2))
+    (free/mark-white!)
+    (test (current-heap) #(white-flat first white-flat rest white-cons 0 2))
+    (free/mark-white!)
+    (test (current-heap)  (make-vector 7 'free))
+    (gc:alloc-flat 'first)
+    (gc:alloc-flat 'rest)
+    (gc:cons 0 2)
+    (free/mark-white!)
+    (test (current-heap) #(white-flat first white-flat rest white-cons 0 2))
+    )
+
+  (with-heap  (vector 'flat 'first 'flat 'rest 'white-cons 0 2)
+    (free/mark-white!)
+    (test (current-heap) #(white-flat first white-flat rest free free free))
+    (heap-set! 0 'flat)
+    (free/mark-white!)
+    (test (current-heap) #(white-flat first free free free free free)))
+
+  (with-heap (make-vector 5 #f)
+    (init-allocator)
+    (gc:cons 0 0)
+    (test (current-heap) #(cons 0 0 free free))
+    (malloc 2)
+    (test/exn (malloc 100) "out of memory")
+    (heap-set! 0 'fail)
+    (test/exn (malloc 2) "unexpected tag"))
+  )
+