An interpreter for the consieuten language of milestone 2

interp.rkt

#lang typed/racket

(require "ir.rkt")

(define-type Value (U Integer Boolean Closure))
(define-type Env (HashTable Symbol (Boxof Value)))
(struct Closure ([params : (Listof Symbol)]
                 [body : Prog]
                 [env : Env])
  #:transparent)

;; parse then interp with empty env
(define (top-interp [s : Sexp]) : Value
  (interp (type-check (sexp-parse s)) (hash)))

;; interpret a program
(define (interp [p : Prog] [env : Env]) : Value
  (define (recur [p : Prog])
    (interp p env))
  (match p
    [(NumC _ _ n) n]
    [(BoolC _ _ b) b]
    [(LamC _ _ params body) (Closure params body env)]
    [(VarC _ _ x) (unbox
                   (hash-ref env x
                             (λ ()
                               (error 'interp
                                      "unbound variable: ~e"
                                      x))))]
    [(IfC _ _ test then els)
     (if (recur test)
         (recur then)
         (recur els))]
    [(BinopC _ _ op l r)
     ;; cast should succeed, by type checker...
     ((op-lookup op) (cast (recur l) Integer)
                     (cast (recur r) Integer))]
    [(LetC _ _ bindings body)
     (define new-env
       (foldl (λ ([pr : (List Symbol Prog)]
                  [env2 : Env])
                (hash-set env2 (first pr)
                          (box (recur (second pr)))))
              env
              bindings))
     (interp body new-env)]
    [(LetrecC _ _ bindings body)
     (define params (map (inst first Symbol) bindings))
     (define boxes : (Listof (Boxof Value))
       (map (λ (_) : (Boxof Value) (box -1234)) bindings))
     (define new-env
       (foldl (λ ([param : Symbol]
                  [box : (Boxof Value)]
                  [env2 : Env])
                (hash-set env2 param box))
              env
              params
              boxes))
     (define vals (map (λ ([p : Prog])
                         (interp p new-env))
                       (map (inst second Any Prog) bindings)))
     (for ([b : (Boxof Value) (in-list boxes)]
           [v : Value (in-list vals)])
       (set-box! b v))
     (interp body new-env)]
    [(CallC _ _ fun args)
     (match (recur fun)
       [(Closure params body clo-env)
        (define argvals (map recur args))
        (define new-env
          (foldl (λ ([param : Symbol]
                     [argval : Value]
                     [env : Env])
                   (hash-set env param (box argval)))
                 clo-env params argvals))
        (interp body new-env)])]))

;; given the name of a binop, return a function
;; that takes two values and applies the given operator
(define (op-lookup op) : (Value Value -> Value)
  (match op
    ['+ (int-args +)]
    ['- (int-args -)]
    ['* (int-args *)]
    ['/ (int-args (λ ([a : Integer] [b : Integer]) (truncate (/ a b))))]
    ['= (int-args =)]
    ['!= (int-args (λ ([a : Integer] [b : Integer]) (not (= a b))))]
    ['> (int-args >)]
    ['>= (int-args >=)]
    ['< (int-args <)]
    ['<= (int-args <=)]
    ['and (λ (a b) (and a b))]
    ['or (λ (a b) (or a b))]))

;; wrap a function that accepts two ints to allow it to accept two Values
(define (int-args [op : (Integer Integer -> Value)])
  : (Value Value -> Value)
  ;; type checking should ensure that these are ints...
  (λ ([a : Value] [b : Value])
    (op (cast a Integer) (cast b Integer))))

(module+ test
  (require typed/rackunit
           typed/rackunit/text-ui
           "ir-examples.rkt")
  (run-tests
   (test-suite "interp tests"
    (for ([pr (in-list test-pairs)])
      (check-equal? (top-interp (first pr))
                    (second pr))))))