Instructions
Objective
Write a Ocaml assignment program to create a very simple interpreter.
Requirements and Specifications
interpreter.ml which contains a function, interpreter, with the following type signature:
interp : string -> string list
The function will take a program as an input string, and will return a list of strings "logged" by the program. A stack is used internally to keep track of intermediate evaluation results. Only the string log will be tested during grading, the stack will not be tested.
3.3 Commands
Your interpreter should be able to handle the following commands:
Push
All kinds of const are pushed to the stack in the same way. Resolve the constant to the appropriate value and add it to the stack.
Pop
The command Pop n removes the top n values from the stack. If n is negative or the stack contains less than n values, terminate evaluation with error.
Trace
The Trace n command consumes the top n values on the stack and adds their string representations to the output list. New entries to the log should be added to the head position. If n is negative or the stack contains less than n values, terminate with error. For a Trace n command where n > 1, the produced log should be equivalent to n executions of Trace 1 command.
Sub
Sub n consumes the top n values on the stack, and pushes the difference between the top value and the sum of next n − 1 values to the stack. If n is negative or there are fewer than n values on the stack, terminate with error. If the top n values on the stack are not integers, terminate with error. If n is zero, push 0 onto the stack without consuming anything on the stack.
Mul
Mul n consumes the top n values in the stack, and pushes their product to the stack. If n is negative or there are fewer than n values on the stack, terminate with error. If the top n values on the stack are not integers, terminate with error. If n is zero, push 1 onto the stack without consuming anything on the stack.
Div
Div n consumes the top n values on the stack, and pushes the quotient between the top value and the product of the next n − 1 values to the stack. If n is negative or there are fewer than n values on the stack, terminate with error. If the product of the next n − 1 values are 0, terminate with error. If the top n values on the stack are not integers, terminate with error. If n is zero, push 1 onto the stack without consuming anything on the stack.
Screenshots of output
Source Code
(* parsing util functions *)
let is_lower_case c = 'a' <= c && c <= 'z'
let is_upper_case c = 'A' <= c && c <= 'Z'
let is_alpha c = is_lower_case c || is_upper_case c
let is_digit c = '0' <= c && c <= '9'
let is_alphanum c = is_lower_case c || is_upper_case c || is_digit c
let is_blank c = String.contains " \012\n\r\t" c
let explode s = List.of_seq (String.to_seq s)
let implode ls = String.of_seq (List.to_seq ls)
let readlines (file : string) : string =
let fp = open_in file in
let rec loop () =
match input_line fp with
| s -> s ^ "\n" ^ loop ()
| exception End_of_file -> ""
in
let res = loop () in
let () = close_in fp in
res
(* end of util functions *)
(* parser combinators *)
type 'a parser = char list -> ('a * char list) option
let parse (p : 'a parser) (s : string) : ('a * char list) option = p (explode s)
let pure (x : 'a) : 'a parser = fun ls -> Some (x, ls)
let fail : 'a parser = fun ls -> None
let bind (p : 'a parser) (q : 'a -> 'b parser) : 'b parser =
fun ls ->
match p ls with
| Some (a, ls) -> q a ls
| None -> None
let ( >>= ) = bind
let ( let* ) = bind
let read : char parser =
fun ls ->
match ls with
| x :: ls -> Some (x, ls)
| _ -> None
let satisfy (f : char -> bool) : char parser =
fun ls ->
match ls with
| x :: ls ->
if f x then
Some (x, ls)
else
None
| _ -> None
let char (c : char) : char parser = satisfy (fun x -> x = c)
let seq (p1 : 'a parser) (p2 : 'b parser) : 'b parser =
fun ls ->
match p1 ls with
| Some (_, ls) -> p2 ls
| None -> None
let ( >> ) = seq
let seq' (p1 : 'a parser) (p2 : 'b parser) : 'a parser =
fun ls ->
match p1 ls with
| Some (x, ls) -> (
match p2 ls with
| Some (_, ls) -> Some (x, ls)
| None -> None)
| None -> None
let ( << ) = seq'
let alt (p1 : 'a parser) (p2 : 'a parser) : 'a parser =
fun ls ->
match p1 ls with
| Some (x, ls) -> Some (x, ls)
| None -> p2 lslet ( <|> ) = altlet map (p : 'a parser) (f : 'a -> 'b) : 'b parser =
fun ls ->
match p ls with
| Some (a, ls) -> Some (f a, ls)
| None -> Nonelet ( >|= ) = map
let ( >| ) p c = map p (fun _ -> c)
let rec many (p : 'a parser) : 'a list parser =
fun ls ->
match p ls with
| Some (x, ls) -> (
match many p ls with
| Some (xs, ls) -> Some (x :: xs, ls)
| None -> Some ([ x ], ls))
| None -> Some ([], ls)
let rec many1 (p : 'a parser) : 'a list parser =
fun ls ->
match p ls with
| Some (x, ls) -> (
match many p ls with
| Some (xs, ls) -> Some (x :: xs, ls)
| None -> Some ([ x ], ls))
| None -> None
let rec many' (p : unit -> 'a parser) : 'a list parser =
fun ls ->
match p () ls with
| Some (x, ls) -> (
match many' p ls with
| Some (xs, ls) -> Some (x :: xs, ls)
| None -> Some ([ x ], ls))
| None -> Some ([], ls)
let rec many1' (p : unit -> 'a parser) : 'a list parser =
fun ls ->
match p () ls with
| Some (x, ls) -> (
match many' p ls with
| Some (xs, ls) -> Some (x :: xs, ls)
| None -> Some ([ x ], ls))
| None -> None
let whitespace : unit parser =
fun ls ->
match ls with
| c :: ls ->
if String.contains " \012\n\r\t" c then
Some ((), ls)
else
None
| _ -> None
let ws : unit parser = many whitespace >| ()let ws1 : unit parser = many1 whitespace >| ()
let digit : char parser = satisfy is_digit
let natural : int parser =
fun ls ->
match many1 digit ls with
| Some (xs, ls) -> Some (int_of_string (implode xs), ls)
| _ -> None
let literal (s : string) : unit parser =
fun ls ->
let cs = explode s in
let rec loop cs ls =
match (cs, ls) with
| [], _ -> Some ((), ls)
| c :: cs, x :: xs ->
if x = c then
loop cs xs
else
None
| _ -> None
in
loop cs ls
let keyword (s : string) : unit parser = literal s >> ws >| ()
let letter : char parser = satisfy is_alpha
(* end of parser combinators *)
(***************** Interpreter implementation *****************)
(* Define a dictionary to handle environments *)
module Dict = Map.Make(String)
(* Type for the supported values int, bool, () and name *)
type value = Int of int | Bool of bool | Unit | Name of string
(* Type for the supported commands and their arguments *)
type command =
Push of value
| Pop of int
| Trace of int
| Add of int
| Sub of int
| Mul of int
| Div of int
| And
| Or
| Not
| Equal
| Lte
| Local
| Global
| Lookup
| BeginEnd of command list
| IfElseEnd of command list * command list
(* Type for the output *)
type output = string list
(* Type for the environment *)
type environment = value Dict.t
(* Type for the current state *)
type state = {
stack : value list;
out : output;
local : environment;
global : environment}
let empty_state : state =
{ stack = []; out = []; local = Dict.empty; global = Dict.empty }
(* Parse an integer *)
let parse_int : value parser =
((char '-' >> natural ) >|= (fun i -> Int (-i))
<|> (natural >|= fun i -> Int i)) << ws
(* Parse a name *)
let parse_name : value parser =
letter >>= fun c ->
many ((satisfy is_alphanum) <|> (char '_') <|> (char '\'')) >>= fun cs -> ws >> pure (Name (implode (c :: cs)))
(* Parse a const: int | bool | () *)
let parse_const : value parser =
parse_int
<|> (keyword "True" >> pure (Bool true))
<|> (keyword "False">> pure (Bool false))
<|> (keyword "()" >> pure (Unit))
<|> parse_name
(* Returns the integer value of an Int value *)
let int_of_value (v : value) : int =
match v with
| Int i -> i
| _ -> 0
(* Parse command list until a given ending keyword is found *)
let rec parse_coms (ending: string) (coms : command list) (cs : char list): (command list * char list) option =
(match parse (ws >> keyword ending) (implode cs) with
| Some (_, ts) -> Some (coms, ts)
| None ->
(match parse_com cs with
| Some (com, ts) -> parse_coms ending (coms @ [com]) ts
| None -> None))
and
(* Parse a command: Push const | Pop int | Trace int | Add int | Sub int | Mul int | Div int *)
parse_com (cs : char list) : (command * char list) option =
match parse
(ws >> ((keyword "Push" >> parse_const >|= (fun c -> Push c))
<|> (keyword "Pop" >> parse_int >|= (fun i -> Pop (int_of_value i)))
<|> (keyword "Trace" >> parse_int >|= (fun i -> Trace (int_of_value i)))
<|> (keyword "Add" >> parse_int >|= (fun i -> Add (int_of_value i)))
<|> (keyword "Sub" >> parse_int >|= (fun i -> Sub (int_of_value i)))
<|> (keyword "Mul" >> parse_int >|= (fun i -> Mul (int_of_value i)))
<|> (keyword "Div" >> parse_int >|= (fun i -> Div (int_of_value i)))
<|> (keyword "And" >> pure And)
<|> (keyword "Or" >> pure Or)
<|> (keyword "Not" >> pure Not)
<|> (keyword "Equal" >> pure Equal)
<|> (keyword "Lte" >> pure Lte)
<|> (keyword "Local" >> pure Local)
<|> (keyword "Global" >> pure Global)
<|> (keyword "Lookup" >> pure Lookup)))
(implode cs)
with
| Some (c, ts) -> Some (c, ts)
| None ->
(match parse
(ws >> ((keyword "Begin") >> pure (BeginEnd []))
<|> ((keyword "If") >> pure (IfElseEnd ([],[]))))
(implode cs)
with
| Some (BeginEnd _, ts) ->
(match parse_coms "End" [] ts with
| Some ([], _) -> None
| Some (coms, rs) -> Some (BeginEnd coms, rs)
| None -> None)
| Some (IfElseEnd (_, _), ts) ->
(match parse_coms "Else" [] ts with
| Some ([], _) -> None
| Some (coms1, rs) ->
(match parse_coms "End" [] rs with
| Some ([], _) -> None
| Some (coms2, ss) -> Some (IfElseEnd (coms1, coms2), ss)
| None -> None)
| None -> None)
| _ -> None)
(* Parse a list of commands separated by whitespaces *)
let rec parse_comlst (src : char list) (ls : command list): command list option =
match parse_com src with
| Some (c, []) -> Some (ls @ [c])
| Some (c, tl) -> parse_comlst tl (ls @ [c])
| None -> None(* Returns the string representation of a value *)
let val_to_string (v: value) : string =
match v with
| Int i -> string_of_int i
| Bool true -> "True"
| Bool false -> "False"
| Unit -> "()"
| Name s -> s
(* Evaluates a Pop n command using the given stack *)
let rec pop_n n (st : state) : state option =
if n < 0 then None
else if n == 0 then Some st
else
match st.stack with
| [] -> None
| hd::tl -> pop_n (n - 1) {st with stack = tl}
(* Evaluates a Trace n command using the given stack and output list *)
let rec trace_n n (st: state): state option =
if n < 0 then None
else if n == 0 then Some st
else
match st.stack with
| [] -> None
| hd::tl -> trace_n (n - 1) {st with stack = tl; out = val_to_string hd :: st.out}
(* Evaluates an arithmetic command of n values using the given stack, the top value is operated by ftop,
the remaining values in stack are operated using facc *)
let rec eval_op_n (n : int) (top : int) (acc : int) (ftop : int -> int -> int) (facc : int -> int -> int option) (st: state): state option =
if n < 0 then None
else if n == 0 then Some {st with stack = (Int acc) :: st.stack}
else
match st.stack with
| [] -> None
| (Int i)::tl ->
if n == top then
eval_op_n (n - 1) top (ftop acc i) ftop facc {st with stack = tl}
else
(match facc acc i with
| Some x -> eval_op_n (n - 1) top x ftop facc {st with stack = tl}
| None -> None)
| _ -> None
let eval2bool (f : bool -> bool -> bool) (st : state) : state option =
match st.stack with
| (Bool a)::(Bool b)::tl -> Some {st with stack = (Bool (f a b))::tl}
| _ -> None
let eval2int (f : int -> int -> bool) (st : state) : state option =
match st.stack with
| (Int a)::(Int b)::tl -> Some {st with stack = (Bool (f a b))::tl}
| _ -> None
(* Evaluates a list of commands using the given stack, output list and environment *)
let rec eval_comlst (cs : command list) (st : state): state option =
match cs with
| [] -> Some st
| c::tl -> (match eval_com c st with
| Some st' -> eval_comlst tl st'
| None -> None)
and
(* Evaluates a command using the given stack and output list *)
eval_com (c : command) (st : state): state option =
match c with
| Push v -> Some { st with stack = v :: st.stack}
| Pop n -> pop_n n st
| Trace n -> trace_n n st
| Add n -> eval_op_n n n 0 (+) (fun a b -> Some (a + b)) st
| Sub n -> eval_op_n n n 0 (+) (fun a b -> Some (a - b)) st
| Mul n -> eval_op_n n n 1 ( * ) (fun a b -> Some (a * b)) st
| Div n -> eval_op_n n n 1 ( * ) (fun a b -> if b != 0 then Some (a / b) else None) st
| And -> eval2bool (&&) st
| Or -> eval2bool (||) st
| Not -> (match st.stack with
| (Bool a)::tl -> Some {st with stack = (Bool (not a))::tl}
| _ -> None)
| Equal -> eval2int (==) st
| Lte -> eval2int (<=) st
| Local -> (match st.stack with
| (Name a):: b::tl ->
Some {st with stack = Unit::tl; local = Dict.add a b st.local}
| _ -> None)
| Global -> (match st.stack with
| (Name a):: b::tl ->
Some {st with stack = Unit::tl; global = Dict.add a b st.global}
| _ -> None)
| Lookup -> (match st.stack with
| (Name a)::tl ->
if Dict.mem a st.local then
Some {st with stack = (Dict.find a st.local)::tl}
else if Dict.mem a st.global then
Some {st with stack = (Dict.find a st.global)::tl}
else
None
| _ -> None)
| BeginEnd coms ->
(match eval_comlst coms {st with stack = []} with
| Some st' ->
(match st'.stack with
| hd::tl -> Some {st with stack = hd::st.stack; global = st'.global}
| _ -> None)
| None -> None)
| IfElseEnd (comst, comsf) ->
(match st.stack with
| (Bool b)::tl -> eval_comlst (if b then comst else comsf) {st with stack = tl}
| _ -> None)
(* Interprets a string of commands and returns the output list *)
let interp (src : string) : string list =
match parse_comlst (explode src) [] with
| Some cs ->
(match eval_comlst cs empty_state with
| Some st -> st.out
| None -> ["Error"])
| None -> ["Error"](* Calling (main "test.txt") will read the file test.txt and run interp on it.
This is only used for debugging and will not be used by the gradescope autograder. *)
let main fname =
let src = readlines fname in
interp src