OCaml Interpreter

interpreter.ml

type exp = 
    IntExp of int
  | Builtin of (exp -> env -> exp)
  | VarExp of string
  | FunExp of string * exp
  | LetExp of string * exp * exp
  | IfExp of exp * exp * exp
  | AppExp of exp * exp
and
  env = (string * exp) list

type token = 
    LParen 
  | RParen 
  | Id of string 
  | Int of int

let rec getId cacc tacc =
  let next = input_char stdin in
  match next with
    'a'..'z' | 'A'..'Z' | '0'..'9' -> getId (cacc ^ (Char.escaped next)) tacc
  | _ -> dispatch next ((Id cacc) :: tacc)
and getInt iacc tacc =
  let next = input_char stdin in
  match next with
    '0'..'9' -> getInt (iacc * 10 + (Char.code next) - 48) tacc
  | _ -> dispatch next ((Int iacc) :: tacc)
and dispatch next tacc =
  match next with
    'a'..'z' | 'A'..'Z' | '+' -> getId (Char.escaped next) tacc
  | '0'..'9' -> getInt ((Char.code next) - 48) tacc
  | '(' -> dispatch (input_char stdin) (LParen :: tacc)
  | ')' -> dispatch (input_char stdin) (RParen :: tacc)
  | ' ' | '\t' -> dispatch (input_char stdin) tacc
  | '\n' -> List.rev tacc
  | _ -> dispatch (input_char stdin) tacc
and tokenize () =
  dispatch (input_char stdin) [];;


 (* Part 1: Printer *)

let rec print exp = match exp with
    IntExp i -> string_of_int i
  | VarExp id -> id
  | FunExp(id,e1) -> "(lambda " ^ id ^ " " ^ print e1 ^ ")"
  | LetExp(id,e1,e2) -> "(let " ^ id ^ " " ^ print e1 ^ " " ^ print e2 ^ ")"
  | IfExp(e1,e2,e3) -> "(if " ^ print e1 ^ " " ^ print e2 ^ " " ^ print e3 ^ ")"
  | AppExp(e1,e2) -> "(" ^ print e1 ^ " " ^ print e2 ^ ")"
  | Builtin(f) -> "(builtin)"

let rec print_token tt = match tt with
    Int i -> string_of_int i
  | Id s -> s | LParen -> "(" | RParen -> ")"

 (* Part 2: Parser *)

let rec parse tokens = fst (parse_stream tokens)
and parse_stream tokens =
  match tokens with
      [] -> failwith "Parse: unexpected end-of-tokens"
    | token::ts -> parse_exp token ts
and parse_exp token tokens =
  match token with
      Int i -> IntExp i, tokens
    | Id id -> VarExp id, tokens
    | LParen -> parse_complex tokens
    | t -> failwith ("Parse: unexpected token '" ^ print_token t ^ "'")
and parse_complex tokens =
  match tokens with
      Id id::ts when id = "lambda" -> parse_fun ts
    | Id id::ts when id = "let" -> parse_let ts
    | Id id::ts when id = "if" -> parse_if ts
    | _ -> parse_app tokens
and parse_fun tokens =
  match tokens with
      Id id::ts -> let (e1, rest) = parse_stream ts in
      (match rest with
          RParen::rest -> FunExp(id, e1),rest
        | _ -> failwith "Parsing function: expected closing parenthesis")
    | _ -> failwith "Parsing function: unexpected input"
and parse_let tokens =
  match tokens with
      Id id::ts -> let (e1, rest) = parse_stream ts in
      let (e2, rest) = parse_stream rest in
        (match rest with
            RParen::rest -> LetExp(id, e1, e2),rest
          | _ -> failwith "Parsing let: expected closing parenthesis")
    | _ -> failwith "Parsing let: unexpected input"
and parse_if tokens =
  let (e1, rest) = parse_stream tokens in
    let (e2, rest) = parse_stream rest in
      let (e3, rest) = parse_stream rest in
        (match rest with
            RParen::rest -> IfExp(e1, e2, e3),rest
          | _ -> failwith "Parsing if: expected closing parenthesis")
and parse_app tokens =
  let (e1, rest) = parse_stream tokens in
    let (e2, rest) = parse_stream rest in
      (match rest with
          RParen::ts -> AppExp(e1, e2), ts
        | _ -> failwith "Parsing app: expected closing parenthesis")

 (* Part 4: Evaluation *)

let rec find_exp_in_env id env = match env with
    [] -> VarExp(id)
  | (s,e)::ee when s = id -> e
  | (s,e)::ee -> find_exp_in_env id ee

let rec evalCBV exp env =
  match exp with
    VarExp(id) -> find_exp_in_env id env
  | AppExp(e1,e2) -> (let e = (evalCBV e1 env) in match e with
      FunExp(id,sube) -> evalCBV sube ((id,(evalCBV e2 env))::env)
    | Builtin(f) -> evalCBV (f e2 env) env
    | _ -> e)
  | IfExp(e1, e2, e3) -> (match (evalCBV e1 env) with
      IntExp 0 -> evalCBV e3 env
    | _ -> evalCBV e2 env)
  | LetExp(id,e1,e2) -> evalCBV e2 ((id,(evalCBV e1 env))::env)
  | _ -> exp

let rec evalCBN exp env =
  match exp with
    VarExp(id) -> find_exp_in_env id env
  | AppExp(e1,e2) -> (let e = (evalCBN e1 env) in match e with
      FunExp(id,sube) -> evalCBN sube ((id,e2)::env)
    | Builtin(f) -> evalCBN (f e2 env) env
    | _ -> e)
  | IfExp(e1, e2, e3) -> (match (evalCBN e1 env) with
      IntExp 0 -> evalCBN e3 env
    | _ -> evalCBN e2 env)
  | LetExp(id,e1,e2) -> evalCBN e2 ((id,e1)::env)
  | _ -> exp

 (* Some builtin functions *)

let binaryArith opname op =
  Builtin (fun e1 env ->
    let v1 = evalCBV e1 env in
    Builtin (fun e2 env ->
      let _ = print_string ("Called " ^ opname ^ "\n") in
      let v2 = evalCBV e2 env in
      match v1,v2 with
      | IntExp i1, IntExp i2 -> IntExp (op i1 i2)
      | _ -> IntExp 0))

let global = [ "+", (binaryArith "+" (+)) ]

 (* The R-E-P loop *)

let rec repCBV () =
  let _ = print_string "> " in
  let _ = flush stdout in
  let tokens = tokenize() in
  let exp = parse tokens in
  begin
    print_string (print (evalCBV exp global)) ;
    print_newline () ;
    repCBV ()
  end

let rec repCBN () =
  let _ = print_string "> " in
  let _ = flush stdout in
  let tokens = tokenize() in
  let exp = parse tokens in
  begin
    print_string (print (evalCBN exp global)) ;
    print_newline () ;
    repCBN ()
  end