Improve 3.rkt a bit

.gitignore

@@ -1,2 +1,2 @@
 # Ignore raket temp files
-*.rkt*
+*.rkt~

Assignments/02.rkt

@@ -0,0 +1,171 @@
+#lang plait
+(define-type TypeExp
+  [numTE]
+  [boolTE]
+  [arrowTE (arg : TypeExp)
+           (result : 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)])
+
+(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)))]))
+
+(define (parse s)
+  (local
+      [(define (sx n) (list-ref (s-exp->list s) n))
+       (define (px n) (parse (sx n)))
+       (define (? pat) (s-exp-match? pat s))
+       (define (parse-let)
+         (let* ([def (sx 1)]
+                [val (parse (sx-ref def 1))]
+                [var-type (sx-ref def 0)]
+                [var (s-exp->symbol (sx-ref var-type 0))]
+                [te  (parse-te (sx-ref var-type 2))]
+                [body (px 2)])
+           (values var te val body)))]
+    (cond
+      [(? `true) (boolE #t)]
+      [(? `false) (boolE #f)]
+      [(? `SYMBOL) (varE (s-exp->symbol s))]
+      [(? `NUMBER) (numE (s-exp->number s))]
+      [(? `(+ ANY ANY)) (plusE (px 1) (px 2))]
+      [(? `(- ANY ANY)) (minusE (px 1) (px 2))]
+      [(? `(* ANY ANY)) (timesE (px 1) (px 2))]
+      [(? `(<= ANY ANY)) (leqE (px 1) (px 2))]
+      [(? `(if ANY ANY ANY))
+       (ifE (px 1) (px 2) (px 3))]
+      [(? `(rec ([SYMBOL : ANY] ANY) ANY))
+       (local [(define-values (var te val body) (parse-let))]
+         (recE var te val body))]
+      [(? `(let1 ([SYMBOL : ANY] ANY) ANY))
+       (local [(define-values (var te val body) (parse-let))]
+         (let1E var te val body))]
+      [(? `(lam (SYMBOL : ANY) ANY))
+       (let* ([def (sx 1)]
+              [parts (s-exp->list def)]
+              [var (s-exp->symbol (list-ref parts 0))]
+              [te (parse-te (list-ref parts 2))]
+              [body (px 2)])
+         (lamE var te body))]
+      [(? `(ANY ANY)) (appE (px 0) (px 1))]
+      [else (error 'parse (to-string s))])))
+
+
+;; Coverage for parser
+(test/exn (parse `"strings are not in our language") "parse")
+(test (parse `false) (boolE #f))
+(test (parse-te `bool) (boolTE))
+
+(define-type Type
+  [numT]
+  [boolT]
+  [arrowT (arg : Type) (result : Type)])
+
+(define (interp-te te)
+  (type-case TypeExp te
+    [(numTE) (numT)]
+    [(boolTE) (boolT)]
+    [(arrowTE a b) (arrowT (interp-te a)
+                           (interp-te b))]))
+
+(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 (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)]
+      ; todo ensure correctness?
+      ; https://www.cs.unb.ca/~bremner/teaching/cs4613/docs/plai-3.2.2.pdf#page=127
+      [(lamE name te body) (arrowT (interp-te te) (typecheck body (type-extend env name (interp-te te))))]
+      ; todo use local to reduce duplicate calls
+      ; https://www.cs.unb.ca/~bremner/teaching/cs4613/docs/plai-3.2.2.pdf#page=124
+      [(appE fn arg) (type-case Type (typecheck fn env) 
+                         [(arrowT a b) (typecheck fn env)]
+                         [else (error 'app "Function application must be a function")])]
+      ; todo use type case/local to reduce duplicate calls
+      ; https://www.cs.unb.ca/~bremner/teaching/cs4613/docs/plai-3.2.2.pdf#page=119
+      [(ifE c t f) (if (equal? (typecheck c env) (boolT))
+                    (if (equal? (typecheck t env) (typecheck f env))
+                       (typecheck t env)
+                       (error 'if "Both if conditions must be of the same type"))
+                    (error 'if "Condition must be a boolean expression"))]
+      ; https://www.cs.unb.ca/~bremner/teaching/cs4613/docs/plai-3.2.2.pdf#page=129
+      [(let1E var te val body) (typecheck body (type-extend env var (interp-te te)))]
+      ; https://www.cs.unb.ca/~bremner/teaching/cs4613/docs/plai-3.2.2.pdf#page=132
+      [(recE var te val body) (type-case Type (typecheck body (type-extend env var (interp-te te)))
+                                [(arrowT a b) b]
+                                [else (error 'rec "rec body must be a function")])])))
+
+(tc : (S-Exp -> Type))
+(define (tc s)
+  (typecheck (parse s) mt-type-env))
+
+(test (tc `{rec {[fact : (num -> num)]
+                {lam {n : num} {if {<= n 0} 1 {* n {fact {- n 1}}}}}}
+                {fact 10}})
+      (numT))
+
+(test (tc `{lam {n : num} {if {<= n 0} 1 2}}) (arrowT (numT) (numT)))
+
+(test (tc `{let1 {[x : num] 3} {lam {y : num} {+ x y}}}) (arrowT (numT) (numT)))
+(test/exn (tc `{lam {n : bool} {if {<= n 0} 1 2}}) "typecheck")
+
+(test/exn (tc `{lam {n : num} {if n 1 2}}) "boolean")
+
+(test/exn (tc `{1 1}) "function")
+
+
+; Tests added for complete coverage
+(test (tc `false) (boolT))
+(test (tc `true) (boolT))
+
+(test (tc `{- 2 1}) (numT))
+(test (tc `{* 2 2}) (numT))
+
+(test/exn (tc `{rec {[fact : (num -> num)] {lam {n : num} {if {<= n 0} 1 {* n {fact {- n 1}}}}}} false}) "function")
+
+(test/exn (tc `{lam {n : num} {if {<= n 0} 1 false}}) "same type")

Assignments/03.rkt

@@ -0,0 +1,592 @@
+#lang plait
+(define-type Exp
+  [numE (n : Number)]
+  [boolE (b : Boolean)]
+  [notE (expr : Exp)]
+  [plusE (lhs : Exp) (rhs : Exp)]
+  [minusE (lhs : Exp) (rhs : Exp)]
+  [timesE (lhs : Exp) (rhs : Exp)]
+  [listE (elements : (Listof Exp))] ;; New
+  [if0E (test-expr : Exp) (then-expr : Exp) (else-expr : Exp)]
+  [recE (name : Symbol) (ty : TE) (rhs-expr : Exp) (body-expr : Exp)]
+  [idE (name : Symbol)]
+  [lamE (param : Symbol) (argty : TE) (body : Exp)]
+  [appE (lam-expr : Exp) (arg-expr : Exp)])
+
+(define-type Value
+  [numV (n : Number)]
+  [boolV (b : Boolean)]
+  [listV (elements : (Listof Value))]
+  [closureV (param : Symbol)
+            (body : Exp)
+            (env : ValueEnv)])
+
+(define-type TE
+  [numTE]
+  [boolTE]
+  [arrowTE (arg : TE) (result : TE)]
+  [listTE (element : TE)] ;; New
+  [guessTE])
+
+(define-type Type
+  [numT]
+  [boolT]
+  [arrowT (arg : Type) (result : Type)]
+  [listT (element : Type)] ;; New
+  [varT (id : Number) (val : (Boxof (Optionof Type)))])
+
+(define-type ValueEnv
+  [EmptyValueEnv]
+  [BindValue (name : Symbol)
+             (value : Value)
+             (rest : ValueEnv)]
+  [RecBindValue (name : Symbol)
+                (value-box : (Boxof Value))
+                (rest : ValueEnv)])
+
+(define-type TypeEnv
+  [EmptyTypeEnv]
+  [BindType (name : Symbol)
+            (type : Type)
+            (rest : TypeEnv)])
+
+;; num-op : (Number Number -> Number) -> (Value Value -> Value)
+(define (num-op op op-name x y)
+  (numV (op (numV-n x) (numV-n y))))
+(define (num+ x y) (num-op + '+ x y))
+(define (num- x y) (num-op - '- x y))
+(define (num* x y) (num-op * '* x y))
+(define (numzero? x) (= 0 (numV-n x)))
+
+;; interp : Exp Env -> Value
+(define (interp a-exp env)
+  (type-case Exp a-exp
+    [(numE n) (numV n)]
+    [(boolE b) (boolV b)]
+    [(notE e) (boolV (not (boolV-b (interp e env))))]
+    [(plusE l r) (num+ (interp l env) (interp r env))]
+    [(minusE l r) (num- (interp l env) (interp r env))]
+    [(timesE l r) (num* (interp l env) (interp r env))]
+    [(listE elements) (listV (map (lambda (x) (interp x env)) elements))]
+    [(idE name) (lookup name env)]
+    [(if0E test then-part else-part)
+     (if (numzero? (interp test env))
+         (interp then-part env)
+         (interp else-part env))]
+    [(recE bound-id type named-expr body-expr)
+     (let* ([value-holder (box (numV 42))]
+            [new-env (RecBindValue bound-id value-holder env)])
+       (begin
+         (set-box! value-holder (interp named-expr new-env))
+         (interp body-expr new-env)))]
+    [(lamE param arg-te body-expr)
+     (closureV param body-expr env)]
+    [(appE lam-expr arg-expr)
+     (local [(define lam-val
+               (interp lam-expr env))
+             (define arg-val
+               (interp arg-expr env))]
+       (interp (closureV-body lam-val)
+             (BindValue (closureV-param lam-val)
+                        arg-val
+                        (closureV-env lam-val))))]))
+
+(define (run s-expr)
+  (interp (parse s-expr) (EmptyValueEnv)))
+
+(define (check s-expr)
+  (typecheck (parse s-expr) (EmptyTypeEnv)))
+
+(define (lookup name env)
+  (type-case ValueEnv env
+    [(EmptyValueEnv) (error 'lookup "free variable")]
+    [(BindValue sub-name num rest-env)
+     (if (equal? sub-name name)
+         num
+         (lookup name rest-env))]
+    [(RecBindValue sub-name val-box rest-env)
+     (if (equal? sub-name name)
+         (unbox val-box)
+         (lookup name rest-env))]))
+
+(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)
+       (let ([sym (s-exp->symbol sx)])
+         (case sym
+           [(true) (boolE #t)]
+           [(false) (boolE #f)]
+           [else (idE sym)]))]
+      [(s-exp-match? `(list ANY ...) sx)
+       (listE (map (lambda (elt) (parse elt)) (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? `(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)
+       (cond
+         [(equal? (sx-ref sx 0) `not) (notE(px 1))]
+         [else (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 (parse-te sx)
+  (cond
+    [(s-exp-symbol? sx)
+     (case (s-exp->symbol sx)
+       [(num) (numTE)]
+       [(bool) (boolTE)]
+       [(?) (guessTE)])]
+    [(s-exp-match? `(ANY -> ANY) sx)
+     (arrowTE (parse-te (sx-ref sx 0)) (parse-te (sx-ref sx 2)))]
+    [(s-exp-match? `(listof ANY) sx)
+     (listTE (parse-te (sx-ref sx 1)))]))
+
+(module+ test
+  (define fact-rec
+    (recE 'fact (arrowTE (numTE) (numTE))
+         (lamE 'n (numTE)
+              (if0E (idE 'n)
+                   (numE 1)
+                   (timesE (idE 'n) (appE (idE 'fact) (minusE (idE 'n) (numE 1))))))
+         (appE (idE 'fact) (numE 5))))
+
+  (define fact-rec-concrete
+    `{rec {fact : {num -> num}}
+          {lam {n : num}
+               {if0 n 1
+                    {* n {fact {- n 1}}}}}
+          {fact 5}})
+
+  (define fib-rec
+    (recE 'fib (arrowTE (numTE) (numTE))
+         (lamE 'x (numTE)
+              (if0E (idE 'x)
+                   (numE 1)
+                   (if0E (minusE (idE 'x) (numE 1))
+                        (numE 1)
+                        (plusE (appE (idE 'fib) (minusE (idE 'x) (numE 1)))
+                             (appE (idE 'fib) (minusE (idE 'x) (numE 2)))))))
+         (appE (idE 'fib) (numE 4))))
+
+  (define fib-rec-concrete
+    `{rec {fib : {num -> num}}
+          {lam {x : num}
+               {if0 x 1
+                    {if0 {- x 1}
+                         1
+                         {+ {fib {- x 1}}
+                            {fib {- x 2}}}}}}
+          {fib 4}})
+  )
+
+(module+ test
+  (print-only-errors #t)
+  (test (parse `3) (numE 3))
+  (test (parse `x) (idE 'x))
+  (test (parse `{+ 1 2}) (plusE (numE 1) (numE 2)))
+  (test (parse `{- 1 2}) (minusE (numE 1) (numE 2)))
+  (test (parse `{lam {x : num} x}) (lamE 'x (numTE) (idE 'x)))
+  (test (parse `{f 2}) (appE (idE 'f) (numE 2)))
+  (test (parse `{if0 0 1 2}) (if0E (numE 0) (numE 1) (numE 2)))
+
+  (test/exn (parse `"foo") "parse error")
+  (test/exn (parse `{foo}) "parse error")
+  (test (parse
+         `{{lam {x : num}
+                {{lam {f : {num -> num}}
+                      {+ {f 1}
+                         {{lam {x : num}
+                               {f 2}}
+                          3}}}
+                 {lam {y : num} {+ x y}}}}
+           0})
+        (appE (lamE 'x (numTE)
+                   (appE (lamE 'f (arrowTE (numTE) (numTE))
+                              (plusE (appE (idE 'f) (numE 1))
+                                   (appE (lamE 'x (numTE)
+                                              (appE (idE 'f)
+                                                    (numE 2)))
+                                         (numE 3))))
+                         (lamE 'y (numTE)
+                              (plusE (idE 'x) (idE 'y)))))
+              (numE 0)))
+
+  (test (parse fib-rec-concrete) fib-rec))
+
+(define (parse-type te)
+  (type-case TE te
+    [(numTE) (numT)]
+    [(boolTE) (boolT)]
+    [(arrowTE a b) (arrowT (parse-type a)
+                           (parse-type b))]
+    [(guessTE)(varT (gen-tvar-id!) (box (none)))]
+    [(listTE element-te) (listT (parse-type element-te))]))
+(define (type-lookup name-to-find env)
+  (type-case TypeEnv env
+    [(EmptyTypeEnv ) (error 'type-lookup "free variable, so no type")]
+    [(BindType name ty rest)
+     (if (symbol=? name-to-find name)
+         ty
+         (type-lookup name-to-find rest))]))
+
+(define gen-tvar-id!
+(let ((counter 0))
+  (lambda ()
+    (begin
+      (set! counter (add1 counter))
+      counter))))
+
+(define (resolve t)
+  (type-case Type t
+    [(varT id val)
+     (type-case (Optionof Type) (unbox val)
+       [(none) t]
+       [(some t2) (resolve t2)])]
+    [else t]))
+
+(define (uses-type-var? id t)
+  (type-case Type (resolve t)
+    [(varT t-id val) (= id t-id)]
+    [(arrowT a b)
+     (or (uses-type-var? id a)
+         (uses-type-var? id b))]
+    [else #f]))
+
+(define (occurs? r t)
+  (type-case Type r
+    [(varT id val)
+     (type-case Type (resolve t)
+       [(arrowT a b) (uses-type-var? id t)]
+       [else #f])]
+    [else (expected-type-var 'occurs? r)]))
+
+(define (type-error exp t1 t2)
+  (error 'typecheck (string-append
+                     "no type: "
+                     (string-append
+                      (to-string exp)
+                      (string-append
+                       " type "
+                       (string-append
+                        (to-string t1)
+                        (string-append
+                         " vs. "
+                         (to-string t2))))))))
+
+(define (expected-type-var where type)
+  (error where (string-append "not a type variable " (to-string type))))
+
+(define (unify-type-var! T tau2 expr)
+  (type-case Type T
+    [(varT id val)
+     (type-case (Optionof Type) (unbox val)
+       [(some tau1) (unify! tau1 tau2 expr)]
+       [(none)
+        (let ([t3 (resolve tau2)])
+          (cond
+            [(equal? T t3) (void)] ;; nothing to unify, same type variables
+            [(occurs? T t3)  (type-error expr T t3)]
+            [else  (set-box! val (some t3))]))])]
+    [else (expected-type-var 'unify-type-var! T)]))
+
+(define (unify-assert! tau type-val expr)
+  (unless (equal? tau type-val)
+    (type-error expr tau type-val)))
+
+;; third argument is just for error reporting
+(define (unify! t1 t2 expr)
+  (type-case Type t1
+    [(varT id is1) (unify-type-var! t1 t2 expr)]
+    [else
+     (type-case Type t2
+       [(varT id2 is2) (unify-type-var! t2 t1 expr)]
+       [(numT) (unify-assert! t1 (numT) expr)]
+       [(boolT) (unify-assert! t1 (boolT) expr)]
+       [(listT element-type)
+        (type-case Type t1
+          [(listT other-element-type) (unify! element-type other-element-type expr)]
+          [else (type-error expr t1 t2)])]
+       [(arrowT a2 b2)
+        (type-case Type t1
+          [(arrowT a1 b1)
+           (begin
+             (unify! a1 a2 expr)
+             (unify! b1 b2 expr))]
+          [else (type-error expr t1 t2)])])]))
+
+(module+ test
+  (test (unify! (listT (boolT)) (listT (boolT)) 'test) (void))
+  (test/exn (unify! (listT (boolT)) (listT (numT)) 'test) "no type")
+  (test/exn (unify! (boolT) (listT (numT)) 'test) "no type")
+  (test/exn (unify! (listT (numT)) (boolT) 'test) "no type"))
+
+(define (typecheck [exp : Exp] [env : TypeEnv]) : Type
+  (type-case Exp exp
+    [(numE n) (numT)]
+    [(boolE b) (boolT)]
+    [(notE ex) (begin
+                 (unify! (typecheck ex env) (boolT) ex)
+                 (boolT))]
+    [(timesE l r) (begin
+                    (unify! (typecheck l env) (numT) l)
+                    (unify! (typecheck r env) (numT) r)
+                    (numT))]
+    [(plusE l r) (begin
+                   (unify! (typecheck l env) (numT) l)
+                   (unify! (typecheck r env) (numT) r)
+                   (numT))]
+    [(minusE l r) (begin
+                    (unify! (typecheck l env) (numT) l)
+                    (unify! (typecheck r env) (numT) r)
+                    (numT))]
+    [(if0E test-expr then-expr else-expr)
+     (let ([test-ty (typecheck test-expr env)]
+           [then-ty (typecheck then-expr env)]
+           [else-ty (typecheck else-expr env)])
+       (begin
+         (unify! test-ty (numT) test-expr)
+         (unify! then-ty else-ty else-expr)
+         then-ty))]
+    [(idE name) (type-lookup name env)]
+    [(recE name ty rhs-expr body-expr)
+     (let* ([type-ann (parse-type ty)]
+            [new-env (BindType name type-ann env)]
+            [rhs-ty (typecheck rhs-expr new-env)])
+       (begin
+         (unify! type-ann rhs-ty rhs-expr)
+         (typecheck body-expr new-env)))]
+    [(appE fn arg)
+     (let ([r-type (varT (gen-tvar-id!) (box (none)))]
+           [a-type (typecheck arg env)]
+           [fn-type (typecheck fn env)])
+       (begin
+         (unify! (arrowT a-type r-type) fn-type fn)
+         r-type))]
+    [(lamE name te body)
+     (let* ([arg-type (parse-type te)]
+            [res-type (typecheck body (BindType name arg-type env))])
+       (arrowT arg-type res-type))]
+    [(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))
+                            (listT (check-all type-list))))]))
+;; ----------------------------------------
+
+(define-syntax-rule (test/type expr type)
+  (test
+   (begin (unify! (check expr) type expr) type)
+   type))
+
+(define-syntax-rule (test/notype expr) (test/exn (check expr) "no type"))
+
+(module+ test
+  (print-only-errors #t)
+
+  (test (check `{+ 1 2}) (numT))
+  (test/exn (run `x) "free variable")
+  (test (run `{not false}) (boolV #t))
+  (test (run `10) (numV 10))
+  (test (run `{+ 10 17}) (numV 27))
+  (test (run `{- 10 7}) (numV 3))
+  (test (run `{{lam {x : num} {+ x 12}} {+ 1 17}}) (numV 30))
+
+  (test (interp (idE 'x)
+              (BindValue 'x (numV 10) (EmptyValueEnv)))
+        (numV 10))
+
+  (define lam-lam
+    `{{lam {x : num}
+           {{lam {f : (num -> num)}
+                 {+ {f 1}
+                    {{lam {x : num}
+                          {f 2}}
+                     3}}}
+            {lam {y : num}
+                 {+ x y}}}}
+      0})
+
+  (test (run lam-lam)
+        (numV 3))
+  )
+
+(module+ test
+  (test (run `{list 1 2}) (listV (list (numV 1) (numV 2))))
+  (test (run `{list false true false}) (listV (list (boolV #f) (boolV #t) (boolV #f)))))
+
+(module+ test
+  (print-only-errors #t)
+
+  (test/notype `x)
+
+  (test/notype `{not 1})
+
+  (test/type `{not false} (boolT))
+
+  (test/type lam-lam (numT))
+
+  (test/type  `10 (numT))
+
+  (test/type `{+ 10 17} (numT))
+  (test/type `{- 10 7} (numT))
+
+  (test/notype `{+ false 17})
+  (test/notype `{- false 17})
+  (test/notype `{+ 17 false})
+  (test/notype `{- 17 false})
+
+  (test/type `{lam {x : num} {+ x 12}}
+             (arrowT (numT) (numT)))
+
+  (test/notype `{{lam {x : num} x} true})
+
+  (test/type `{lam {x : num} {lam {y : bool} x}}
+             (arrowT (numT) (arrowT (boolT)  (numT))))
+
+  (test/type `{{lam {x : num} {+ x 12}} {+ 1 17}} (numT))
+
+  (test/notype `{1 2})
+
+  (test/notype `{+ {lam {x : num}  12} 2})
+
+  ;; Added coverage test for type-to-string
+  (test/notype `{{lam {f : {num -> num}}
+                      {f 1}}
+                 1})
+  )
+
+(module+ test
+  (print-only-errors #t)
+  ;; Tests for if0
+  (test (run `{if0 0 1 0}) (numV 1))
+  (test (run `{if0 1 1 0}) (numV 0))
+
+  (test/type `{if0 0 1 0} (numT))
+  (test/type `{if0 1 1 0} (numT))
+
+  (test/notype `{if0 0 {lam {x : num} x} 0})
+  (test/notype `{if0 {lam {x : num} x} 0 0})
+  )
+
+(module+ test
+  (print-only-errors #t)
+
+  ;; Tests for Rec
+  (test (parse fact-rec-concrete) fact-rec)
+
+  (test/type fib-rec-concrete (numT))
+  (test (interp fib-rec (EmptyValueEnv)) (numV 5))
+
+  (test/type fact-rec-concrete (numT))
+  (test (interp fact-rec (EmptyValueEnv)) (numV 120))
+
+  (test/notype `{rec {x : num} {lam {y : num} 3} 10})
+
+  ;; Contrived test to get full coverage of lookup
+  (test (interp (recE 'x (numTE)
+                   (numE 10)
+                   (recE 'y (numTE)
+                        (numE 10)
+                        (idE 'x)))
+              (EmptyValueEnv))
+        (numV 10)))
+
+(module+ test
+
+  (test/type `{{lam {x : ?} {+ x 12}} {+ 1 17}} (numT))
+
+  ;; illustrate that the return of our typecheck function can be a bit messy
+  (define wrapped-type (check `{{lam {x : ?} {+ x 12}} {+ 1 17}}))
+  (test (varT? wrapped-type) #t)
+  (test (varT-val wrapped-type) (box (some (numT))))
+
+  (test/type  `{lam {x : ?} {+ x 12}} (arrowT (numT) (numT)))
+
+  (test/type  `{lam {x : ?} {if0 0 x x}} (arrowT (numT) (numT)))
+
+  ;; coverage for occurs check
+  (test/notype `{lam {x : ?} {x x}})
+  (test
+   (let ([T (varT (gen-tvar-id!) (box (none)))])
+     (occurs? T (arrowT (boolT) T))) #t)
+  (test/exn (occurs? (boolT) (arrowT (boolT) (numT))) "not a type variable")
+
+  ;; coverage for unify-type-var
+  (test/exn (unify-type-var! (boolT) (boolT) 'x) "not a type variable")
+
+  (test/exn (unify! (typecheck (lamE 'x (guessTE) (plusE (idE 'x) (numE 12)))
+                               (EmptyTypeEnv))
+                    (arrowT (boolT) (numT))
+                    (numE -1))
+            "no type")
+
+  ;; soundness bug still exists
+  #;(test/exn (typecheck (recE 'f (arrowTE (numTE) (numTE)) (idE 'f) (appE (idE 'f) (numE 10)))
+                         (EmptyTypeEnv))
+              "no type"))
+(module+ test
+  ;; lists of numbers
+  (test/type `{list 1 2} (listT (numT)))
+
+  ;; report error for mixed types
+  (test/notype  `{list 1 true})
+
+  ;; infer type of list
+  (test/type `{lam {x : num} {list x}} (arrowT (numT) (listT (numT))))
+
+  ;; functions taking list parameters
+  (test/type `{lam {x : {listof num}} x}
+             (arrowT (listT (numT)) (listT (numT))))
+
+  ;; report error for mixed inferred types
+  (test/notype `{lam {x : num} {list true x}})
+
+  ;; infer type of function parameter from list element
+  (test/type `{lam {x : ?} {list x 1}} (arrowT (numT) (listT (numT))))
+
+  ;; complain about cyclic type (Y-combinator) inside list
+  (test/notype `{lam {x : ?} {list {x x}}})
+
+  ;; infer type of list from function application
+  (test/type `{{lam {x : ?} {list x}} 2} (listT (numT)))
+)
+
+(module+ test
+  (test (unify! (listT (boolT)) (listT (boolT)) 'test) (void))
+  (test/exn (unify! (listT (boolT)) (listT (numT)) 'test) "no type")
+  (test/exn (unify! (boolT) (listT (numT)) 'test) "no type")
+  (test/exn (unify! (listT (numT)) (boolT) 'test) "no type"))
+
+(module+ test
+  (test (run `{list 1 2}) (listV (list (numV 1) (numV 2))))
+  (test (run `{list false true false}) (listV (list (boolV #f) (boolV #t) (boolV #f)))))
+

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/07.rkt

@@ -0,0 +1,49 @@
+#lang typed/racket
+(require (rename-in typed/rackunit [check-equal? test])
+         (only-in typed/rackunit check-exn))
+(define-syntax-rule (test/exn expr msg)
+  (check-exn exn:fail? (lambda () expr) msg))
+
+(define (msg0 [obj : Node] [selector : Symbol]) (obj selector))
+
+(define (node [v : Number] [l : Node] [r : Node]) : Node
+  (lambda (m)
+    (case m
+      [(value) v]
+      [(left)  l]
+      [(right) r]
+      [(sum) (+ v (+ (msg-num l 'sum) (msg-num r 'sum)))]
+      [else (error 'node (symbol->string m))])))
+
+(define (mt)
+  (lambda ([m : Symbol])
+    (case m
+      [(sum) 0]
+      [else (error 'mt (symbol->string m))])))
+
+(define-type Node (Symbol -> (U (U Number Node) Zero)))
+
+(define (msg-num [obj : Node] [selector : Symbol]) : Number
+  (define result (msg0 obj selector))
+  (cond
+    [(number? result) result]
+    [else (error 'msg-num "Expected a number message")]))
+
+(define (msg-node [obj : Node] [selector : Symbol]) : Node
+  (define result (msg0 obj selector))
+  (cond
+    [(not (number? result)) result]
+    [else (error 'msg-node "Expected a node message")]))
+
+(module+ test
+  (define tree1 (node 1 (mt) (mt)))
+  (test (msg0 tree1 'sum) 1)
+  (test (msg0 tree1 'value) 1)
+  (define tree2 (node 1 (node 2 (mt) (mt)) (mt)))
+  (test (msg0 tree2 'value) 1)
+  (test (msg0 (msg-node tree2 'left) 'value) 2)
+  (test (msg0 (msg-node tree2 'right) 'sum) 0)
+  (test/exn (msg0 (mt) 'left) "left")
+  (test/exn (msg0 tree2 'wrong) "wrong")
+  (test/exn (msg-num tree2 'left) "number")
+  (test/exn (msg-node tree2 'value) "node"))

Labs/08.rkt

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

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"))
+  )
+

Tests/02.rkt

@@ -0,0 +1,93 @@
+#lang plait
+(define-type IFLANG
+  [Num  (val : Number)]
+  [Add  (l : IFLANG) (r : IFLANG)]
+  [Div  (l : IFLANG) (r : IFLANG)]
+  [Id   (name : Symbol)]
+  [Let1 (id : Symbol) (named-expr : IFLANG) (bound-body : IFLANG)]
+  [Lam  (param : Symbol) (body : IFLANG)]
+  [ILam  (param : Symbol) (zero-body : IFLANG) (non-zero-body : IFLANG)]
+  [Call (fun : IFLANG) (val : IFLANG)]) ; first type!
+(define-type ENV
+  [EmptyEnv]
+  [Extend (name : Symbol) (val : VAL) (rest : ENV)])
+
+(define-type VAL
+  [NumV (n : Number)]
+  [LamV (arg : Symbol) (body : IFLANG) (env : ENV)]
+  [ILamV (arg : Symbol) (zero-body : IFLANG)  (non-zero-body : IFLANG) (env : ENV)])
+
+(define (lookup name env)
+  (type-case ENV env
+    [(EmptyEnv) (error 'lookup "missing binding")]
+    [(Extend id val rest-env)
+     (if (eq? id name)
+         val
+         (lookup name rest-env))]))
+
+(define (arith-op op val1 val2) (NumV (op (NumV-n val1) (NumV-n val2))))
+;; evaluates IFLANG expressions by reducing them to values
+(define (interp expr env)
+  (type-case IFLANG expr
+    [(Num n) (NumV n)]
+    [(Add l r) (arith-op + (interp l env)
+                         (interp r env))]
+    [(Div l r) (arith-op / (interp l env) (interp r env))]
+    [(Let1 bound-id named-expr bound-body)
+     (interp bound-body
+           (Extend bound-id (interp named-expr env) env))]
+    [(Id name) (lookup name env)]
+    [(ILam bound-id zero-body non-zero-body)
+     ; I thought this might delay the lookup so it would be bound by this point
+     (LamV bound-id (type-case VAL (lookup bound-id env)
+                      [(NumV n) (if (equal? n 0) zero-body non-zero-body)]
+                      [else (error 'ILam "not a number in ILam expression")]) env)
+     ; I got confused by why the arguments in the environment for a function are not bound to the identifier in the
+     ; lambda
+     #;(type-case VAL (lookup bound-id env)
+       [(NumV n) (if (equal? n 0)
+                     (LamV bound-id zero-body env)
+                     (LamV bound-id non-zero-body env))]
+       [else (error 'ILam "not a number in ILam expression")])
+     ]
+    [(Lam bound-id bound-body)
+     (LamV bound-id bound-body env)]
+    [(Call lam-expr arg-expr)
+     (let ([fval (interp lam-expr env)])
+       (type-case VAL fval
+         [(LamV bound-id bound-body f-env)
+          (interp bound-body
+                (Extend bound-id (interp arg-expr env) f-env))]
+         [else (error 'eval "expects function")]))]))
+(define (run iflang)  (NumV-n (interp iflang (EmptyEnv))))
+
+(print-only-errors #t)
+
+(test (run
+       (Let1 'x (Num 3)
+        (Let1 'f (ILam 'y (Num -1) (Add (Id 'x) (Id 'y)))
+         (Let1 'x (Num 5) (Call (Id 'f) (Num 4))))))
+      7)
+
+(test (run
+       (Call (Let1 'x (Num 3) (ILam 'y (Num -1) (Add (Id 'x) (Id 'y)))) (Num 4)))
+      7)
+
+(test (run 
+       (Call
+        (Call
+         (Lam 'x (Call (Id 'x) (Num 1)))
+         (Lam 'x (ILam 'y (Num -1) (Add (Id 'x) (Id 'y)))))
+        (Num 123)))
+       124)
+
+(test (run
+       (Let1 'f (ILam 'x (Id 'x) (Div (Num 1) (Id 'x)))
+        (Add (Call (Id 'f) (Num 3)) (Call (Id 'f) (Num 0)))))
+      1/3)
+
+(test (run
+       (Let1 'x (Num 3)
+        (Let1 'f  (ILam 'y (Id 'x) (Div (Id 'x) (Id 'y)))
+         (Let1 'x (Num 5) (Add (Call (Id 'f) (Num 3)) (Call (Id 'f) (Num 0)))))))
+      4)