Ocaml interpreter

Learning
1

AST
type expr =
| EInt of int
| EBool of bool
| Var of string
| Let of string * expr * expr | Prim of string * expr * expr | If of expr * expr * expr
| Fun of string * expr
| Call of expr * expr
| GetInput of expr

type value =
| Int of int
| Bool of bool
| Closure of string * expr * value env

Environment:

(* environment )
type 'v env = (string * 'v * bool) list
( binding )
let rec lookup env x =
match env with
| [] → failwith (x ^ “not found”)
| (y, v, _) :: r → if x = y then v else lookup r x
( taintness of a variable *) let rec t_lookup env x =
match env with
| → failwith (x ^ “not found”)
| (y, _, t) :: r → if x = y then t else t_lookup r x

Interpreter
let rec eval (e : expr) (env:value env) (t : bool) : value * bool = match e with
| EInt n → (Int n, t)
| EBool b → (Bool b, t)
| Var x → (lookup env x, t_lookup env x) | Prim (op, e1, e2) →
begin
let v1, t1 = eval e1 env t in let v2, t2 = eval e2 env t in
match (op, v1, v2) with
(* taintness of binary ops is given by the OR of the taintness of the args ) | "", Int i1, Int i2 → (Int (i1 * i2), t1 || t2)
| “+”, Int i1, Int i2 → (Int (i1 + i2), t1 || t2)
| “-”, Int i1, Int i2 → (Int (i1 - i2), t1 || t2)
| “=”, Int i1, Int i2 → (Bool (if i1 = i2 then true else false), t1 || t2)
| “<”, Int i1, Int i2 → (Bool (if i1 < i2 then true else false), t1 || t2)
| “>”, Int i1, Int i2 → (Bool (if i1 > i2 then true else false), t1 || t2)
| _, _, _ → failwith “Unexpected primitive.”
end

| If (e1, e2, e3) → begin
let v1, t1 = eval e1 env t in match v1 with
| Bool true → let v2, t2 = eval e2 env t in (v2, t1 || t2) | Bool false → let v3, t3 = eval e3 env t in (v3, t1 || t3) | _ → failwith “Unexpected condition.”
end

| Fun (f_param, f_body) → (Closure (f_param, f_body, env), t) | Call (f, param) →
let f_closure, f_t = eval f env t in begin
match f_closure with
| Closure (f_param, f_body, f_dec_env) →
let f_param_val, f_param_t = eval param env t in
let env’ = (f_param, f_param_val, f_param_t)::f_dec_env in
let f_res, t_res = eval f_body env’ t in (f_res, f_t || f_param_t || t_res)
| _ → failwith “Function expected error” end
| GetInput(e) → eval e env true

In the eval of the Call in the Interpreter there is a error, what is? Can you fix it?

1 Like
2

Could you describe the error more in details?
and give some test code, where the error appears?
(also please copy-past code inside a code block with three backticks ```, before and after the code)


type expr =
  | EInt of int
  | EBool of bool
  | Var of string
  | Let of string * expr * expr
  | Prim of string * expr * expr
  | If of expr * expr * expr
  | Fun of string * expr
  | Call of expr * expr
  | GetInput of expr

(* environment *)
type 'v env = (string * 'v * bool) list

type value =
  | Int of int
  | Bool of bool
  | Closure of string * expr * value env

(* binding *)
let rec lookup env x =
  match env with
  | [] -> failwith (x ^ "not found")
  | (y, v, _) :: r -> if x = y then v else lookup r x

(* taintness of a variable *)
let rec t_lookup env x =
  match env with
  | [] -> failwith (x ^ "not found")
  | (y, _, t) :: r -> if x = y then t else t_lookup r x

(* Interpreter *)
let rec eval (e : expr) (env:value env) (t : bool) : value * bool =
  match e with
  | EInt n -> (Int n, t)
  | EBool b -> (Bool b, t)
  | Var x -> (lookup env x, t_lookup env x)
  | Prim (op, e1, e2) ->
    begin
      let v1, t1 = eval e1 env t in
      let v2, t2 = eval e2 env t in
      match (op, v1, v2) with
      (* taintness of binary ops is given by the OR of the taintness of the args *)
      | "", Int i1, Int i2 -> (Int (i1 * i2), t1 || t2)
      | "+", Int i1, Int i2 -> (Int (i1 + i2), t1 || t2)
      | "-", Int i1, Int i2 -> (Int (i1 - i2), t1 || t2)
      | "=", Int i1, Int i2 -> (Bool (if i1 = i2 then true else false), t1 || t2)
      | "<", Int i1, Int i2 -> (Bool (if i1 < i2 then true else false), t1 || t2)
      | ">", Int i1, Int i2 -> (Bool (if i1 > i2 then true else false), t1 || t2)
      | _, _, _ -> failwith "Unexpected primitive."
    end
    | If (e1, e2, e3) -> begin
        let v1, t1 = eval e1 env t in
        match v1 with
        | Bool true -> let v2, t2 = eval e2 env t in (v2, t1 || t2)
        | Bool false -> let v3, t3 = eval e3 env t in (v3, t1 || t3)
        | _ -> failwith "Unexpected condition."
        end
    | Fun (f_param, f_body) -> (Closure (f_param, f_body, env), t)
    | Call (f, param) ->
        let f_closure, f_t = eval f env t in
        begin
          match f_closure with
          | Closure (f_param, f_body, f_dec_env) ->
              let f_param_val, f_param_t = eval param env t in
              let env' = (f_param, f_param_val, f_param_t) :: f_dec_env in
              let f_res, t_res = eval f_body env' t in
              (f_res, f_t || f_param_t || t_res)
          | _ -> failwith "Function expected error"
        end
    | GetInput(e) -> eval e env true
    | Let (_, _, _) -> assert false

The pattern matching was not exhaustive, I had to add the last line to avoid a warning.

2 Likes
3

OK, so presumably you need to diagnose this bug and fix it for an assignment.

Tips:

  • paste each chunk into utop one at a time with ;; on the end to evaluate them.
  • deal with any errors as they occur before moving on to the next chunk.
1 Like