statelang.rkt

#lang plait

; State-passing language

; Language has: let bindings, variables, numbers, box and set!
(define-type Exp
  (let1E (id : Symbol) (assignment : Exp) (body : Exp))
  (varE (id : Symbol))
  (numE (n : Number))
  (unboxE (e : Exp))
  (boxE (e : Exp))
  (setE (b : Exp) (v : Exp)))

(define-type-alias Heap (Number * (Hashof Number Value)))
(define-type-alias Store (Hashof Symbol Value))
(define mt-env (hash '()))

(define-type Value
  [numV (n : Number)]
  [locV (l : Number)])

(define (lookup-store (s : Symbol) (n : Store))
  (type-case (Optionof Value) (hash-ref n s)
             [(none) (error s "not bound")]
             [(some v) v]))

(test (lookup-store 's (hash (list (pair 's (numV 10))))) (numV 10))
(test (lookup-store 's (hash (list (pair 's (locV 10))))) (locV 10))
(test/exn (lookup-store 'n (hash (list (pair 's (numV 10))))) "not bound")

; it is important to note that extend-store will overwrite if there are
; overlapping symbols.
(extend-store : (Store Symbol Value -> Store))
(define (extend-store old-store new-name value)
  (hash-set old-store new-name value))

(test (extend-store mt-env 's (numV 10)) (hash (list (pair 's (numV 10)))))
(test (extend-store (hash (list (pair 's (numV 20)))) 's (numV 10)) 
      (hash (list (pair 's (numV 10)))))

(define mt-heap (pair 0 (hash '())))

(define (lookup-heap (l : Number) (h : Heap))
  (type-case (Optionof Value) (hash-ref (snd h) l)
             [(none) (error 'runtime "invalid location")]
             [(some v) v]))

(test (lookup-heap 0 (pair 1 (hash (list (pair 0 (numV 10)))))) (numV 10))
(test (lookup-heap 0 (pair 1 (hash (list (pair 0 (locV 10)))))) (locV 10))
(test/exn (lookup-heap 23 (pair 1 (hash (list (pair 0 (locV 10))))))
  "invalid location")

(extend-heap : (Heap Value -> (Number * Heap)))
(define (extend-heap h value)
  (letrec [(cur-loc (fst h))
        (cur-heap (snd h))
        (new-heap (hash-set cur-heap cur-loc value))]
    (pair cur-loc (pair (+ 1 cur-loc) new-heap))))

(test (extend-heap (pair 1 (hash (list (pair 0 (numV 10))))) (locV 20))
  (pair 1 (pair 2 (hash (list (pair 0 (numV 10)) (pair 1 (locV 20)))))))

(set-heap : (Heap Number Value -> Heap))
(define (set-heap h loc value)
  (pair (fst h) (hash-set (snd h) loc value)))

(test (set-heap (pair 1 (hash (list (pair 0 (numV 10)))))  5 (locV 20))
  (pair 1 (hash (list (pair 0 (numV 10)) (pair 5 (locV 20))))))

; the store will store local variables (e.g. ones in let-binds)
; the heap will store boxed variables
(interp : (Exp Store Heap -> (Value * Heap)))
(define (interp e store heap)
  (type-case Exp e
            #|
            ---------------
            numE n, S, H ↦ numV n, H
            |#
             [(numE n) (pair (numV n) heap)]
            #|
            e, S, H ↦ v, H'
            ---------------
            let x = e in e2, S, H ↦ e2, S[x -> v], H'
            |#
             [(let1E id assignment body)
              (letrec [(eval-assgn (interp assignment store heap))
                       (assgn-value (fst eval-assgn))
                       (assgn-heap (snd eval-assgn))
                       (new-store (extend-store store id assgn-value))]
                (interp body new-store assgn-heap))]
            #|
            x in dom(S)
            ---------------
            x , S, H ↦ S(x), H
            |#
             [(varE id) (pair (lookup-store id store) heap)]
            #|
            e, S, H ↦ v, H'    (loc, H'') = extend-heap H' v
            ---------------
            box e, S, H ↦ loc, H''
            |#
             [(boxE e)
              (letrec [(eval-e (interp e store heap))
                       (value (fst eval-e))
                       (e-heap (snd eval-e))
                       (heap-insertion (extend-heap e-heap value))]
                (pair (locV (fst heap-insertion)) (snd heap-insertion)))]
            #|
            e, S, H ↦ loc, H'
            ---------------
            unbox e, S, H ↦ H'(loc), H'
            |#
             [(unboxE body)
              (letrec [(eval-body (interp body store heap))
                       (body-v (fst eval-body))
                       (body-heap (snd eval-body))]
                (type-case Value body-v
                           [(numV n) (error 'runtime "invalid value for unbox")]
                           [(locV l) (pair (lookup-heap l body-heap) body-heap)]))]
            #|
            e, S, H ↦ loc , H'       e2, S, H' ↦ v'', H''
            ---------------
            set! e e2, S, H ↦ ???, H''[loc -> v'']
            |#
             [(setE body arg)
              (letrec [(eval-body (interp body store heap))
                       (body-v (fst eval-body))
                       (body-heap (snd eval-body))
                       (eval-arg (interp arg store body-heap))
                       (eval-v (fst eval-arg))
                       (eval-heap (snd eval-arg))]
                (type-case Value body-v
                           [(numV n) (error 'runtime "invalid value for set!")]
                           [(locV l) (pair (numV 0) (set-heap eval-heap l eval-v))]))]))


; let x = box 0 in unbox x
(test (interp (let1E 'x (boxE (numE 0)) (unboxE (varE 'x))) mt-env mt-heap)
  (values (numV 0) (values 1 (hash (list (pair 0 (numV 0)))))))

; let x = box 0 in let y = set! x 10 in unbox x
(test 
 (interp (let1E 'x (boxE (numE 0))
 (let1E 'y (setE (varE 'x) (numE 10))
        (unboxE (varE 'x)))) mt-env mt-heap)
  (values (numV 10) (values 1 (hash (list (pair 0 (numV 10)))))) )

; let x = box 0 in let y = box 1 in unbox x
(test (interp 
  (let1E 'x (boxE (numE 0))
  (let1E 'y (boxE (numE 1))
  (unboxE (varE 'x)))) mt-env mt-heap)
  (values (numV 0) (values 2 (hash (list (pair 0 (numV 0)) (pair 1 (numV 1)))))))

; let x = box 0 in let y = box 1 in let z = set! y 10 in unbox x
(test (interp 
  (let1E 'x (boxE (numE 0))
  (let1E 'y (boxE (numE 1))
  (let1E 'z (setE (varE 'y) (numE 10))
  (unboxE (varE 'x))))) mt-env mt-heap)
  (values (numV 0) (values 2 (hash (list (pair 0 (numV 0)) (pair 1 (numV 10)))))))

; let x = box 0 in let x = box 10 in unbox x
(test (interp 
  (let1E 'x (boxE (numE 0))
  (let1E 'x (boxE (numE 10))
  (unboxE (varE 'x)))) mt-env mt-heap)
  (values (numV 10) (values 2 (hash (list (pair 0 (numV 0)) (pair 1 (numV 10)))))))