tiny_ocaml.ml

module Map = Map.Make(String)

type ref_pointer = int
(* The type of values, that is the output of a terminating computation *)
type value = Int of int | Clos of env * term | Ref of ref_pointer
(* The type of programs *)
and term = Var of string
         | Let of string * term * term
         | Print of term
         | Lit of int
         | Thunk of term
         | Force of term
         | NewRef of term
         | Incr of term
         | Get of term
(* This is the stack: immutable variables introduced by Lets*)
and env = value Map.t
(* This is the heap: mutable references containing arrays, and a pointer to the end. *)
and heap = int ref * value array

let fresh_env = Map.empty
let fresh_heap () = (ref 0, Array.make 256 (Int 0))

let print e =
  match e with
  | Int n -> print_int n; print_endline ""; Int 0
  | Clos _ -> print_string "<closure>\n"; Int 0
  | Ref p -> print_string "<ref "; print_int p; print_string ">\n"; Int 0

let new_ref h init =
  let (top, a) = h in
  let top_val = !top in
  if top_val = Array.length a then
    failwith "Out of memory";
  a.(top_val) <- init;
  print_endline "allocating...";
  incr top;
  Ref top_val

let incr_ref h p =
  let (_, a) = h in
  begin match a.(p) with
    | Int i ->
        a.(p) <- Int (i + 1);
        Int 0
    | _ -> failwith "Type error: Tried to increment a non-int ref!"
  end

let get_ref h p =
  (snd h).(p)

let rec eval heap env term =
  match term with
  | Var v -> Map.find v env
  | Lit i -> Int i
  | Let (v, t, u) ->
      let vt = eval heap env t in
      let env = Map.add v vt env in
      eval heap env u
  | Print t -> let vt = eval heap env t in print vt
  | Thunk t -> Clos (env, t)
  | Force t ->
      begin match eval heap env t with
        | Clos (env', t') -> eval heap env' t'
        | _ -> failwith "Type error: tried to Eval a non-closure"
      end
  | NewRef t ->
      let vt = eval heap env t in
      new_ref heap vt
  | Incr t ->
      begin match eval heap env t with
        | Ref p -> incr_ref heap p
        | _ -> failwith "Type error; tried to incr a non-ref"
      end
  | Get t ->
      begin match eval heap env t with
        | Ref p -> get_ref heap p
        | _ -> failwith "Type error; tried to get a non-ref"
      end

let toplevel t =
  eval (fresh_heap ()) fresh_env t

let test_lit = toplevel (Lit 3)

let test_print = toplevel (Print (Lit 4))

let test_let = toplevel (Let ("x", Lit 7, Print (Var "x")))

let thunk = Let ("x", Lit 7, Thunk (Print (Var "x")))

let test_thunk = toplevel thunk

let test_force = toplevel (Let ("f", thunk, Force (Var "f")))

let test_scope = toplevel (Let ("f", thunk, Let ("x", Lit 1, Force (Var "f"))))

(*
let f =
  fun () ->
    let x = 7 in
    fun () ->  print x
in
let x = 1 in
f () ()
*)

let test_dan = toplevel (Let ("f", Thunk thunk, Let ("x", Lit 1, Force (Force (Var "f")))))

let test_ref = toplevel (Let ("r", NewRef (Lit 3), Let ("x", Get (Var "r"), Print (Var "x"))))

let test_inc = toplevel (Let ("r", NewRef (Lit 3), Let ("_", Incr (Var "r"), Let ("x", Get (Var "r"), Print (Var "x")))))
(*
let r = new ref 42 in
let my_incr = 
  let r = new ref 0 in
  fun () ->
    let _ = incr r in
    let _ = print r in
    let x = get r in
    print x
in
let _ = my_incr () in
my_incr ()
*)
let test_mutable =
  let incr_r_thunk = Let ("r", NewRef (Lit 0),
                          Thunk (Let ("_", Incr (Var "r"),
                                      (Let ("_", Print (Var "r"),
                                            (Let ("x", Get (Var "r"),
                                                  Print (Var "x")))))))) in
  let incr_twice = 
    Let ("r", NewRef (Lit 42),
         (Let ("my_incr", incr_r_thunk, 
               Let ("_", Force (Var "my_incr"), 
                    Force (Var "my_incr"))))) in
  toplevel incr_twice

(*
let incr = 
  fun () ->
    let r = new ref 0 in
    let _ = incr r in
    let _ = print r in
    let x = get r in
    print x
in
let _ = incr () in
incr ()
*)
let test_mutable_error =
  let incr_r_thunk = Thunk
      (Let ("r", NewRef (Lit 0),
            Let ("_", Incr (Var "r"),
                 (Let ("_", Print (Var "r"),
                       Let ("x", Get (Var "r"), Print (Var "x"))))))) in
  let incr_twice =
    Let ("incr", incr_r_thunk,
         Let ("_", Force (Var "incr"),
              Force (Var "incr"))) in
  toplevel incr_twice


let _ = fst (fresh_heap ())