Commit e4cd7b26 authored by James R. Wilcox's avatar James R. Wilcox
Browse files

add a copy of the hw5 starter code to lec23

parent 163ab763
(lang dune 2.9)
\ No newline at end of file
open Errors
(* IGNORE the first 50ish lines (up to "type expr = ...") until working on part 2! *)
type pattern =
| WildcardPattern
| ConsPattern of pattern * pattern
(* TODO: add more patterns here *)
[@@deriving show]
let string_of_pattern = show_pattern
(* TODO: delete this exception, which we just use because Failure is taken by int_of_string in one place *)
exception StarterCodeFailure
let rec pattern_of_pst p =
match p with
| Pst.Symbol sym -> begin
try
let n = int_of_string sym in
(* TODO: delete the next line and instead build an integer literal pattern here using n *)
raise StarterCodeFailure
with
Failure _ ->
match sym with
| "_" -> WildcardPattern
| "true" -> failwith "TODO: convert this to the right constructor of your pattern AST type"
(* TODO: add other cases here for "false" and "nil" *)
| _ ->
if String.get sym 0 = '\'' (* if the string starts with an apostrophe *)
then let sym_without_apostrophe = String.sub sym 1 (String.length sym - 1)
in failwith "TODO: build a symbol pattern using sym_without_apostrophe"
else failwith "TODO: build a variable pattern using sym"
end
| Pst.Node [] -> raise (AbstractSyntaxError "Expected pattern but got '()'")
| Pst.Node (head :: args) ->
match head, args with
| Pst.Symbol "cons", [p1; p2] -> ConsPattern (pattern_of_pst p1, pattern_of_pst p2)
| Pst.Symbol s, ps -> failwith "TODO: build a struct pattern using patterns ps"
| _ -> raise (AbstractSyntaxError ("Expected pattern, but got " ^ Pst.string_of_pst p))
let pattern_of_string s =
s
|> Pstparser.pst_of_string
|> pattern_of_pst
type expr =
| IntLit of int
| BoolLit of bool
| Variable of string
| Plus of expr * expr
| Minus of expr * expr
| Times of expr * expr
| Equals of expr * expr
| If of expr * expr * expr
(* TODO: add constructor for let expressions here *)
| Nil
| Cons of expr * expr
| IsNil of expr
| IsCons of expr
| Car of expr
| Cdr of expr
| Call of string * expr list
(* More constructors for Trefoil v3 below. Ignore during Part 1. *)
| Symbol of string
| Cond of (expr * expr) list
| StructConstructor of string * expr list (* internal AST node; not written by Trefoil programmer *)
(* TODO: add other "internal" expression ASTs here *)
(* TODO: add match expression constructor to the expr type here *)
[@@deriving show]
let string_of_expr = show_expr
let has_duplicates (l: string list) =
let sorted = List.sort compare l in
let rec loop xs =
match xs with
| [] -> false
| [_] -> false
| x :: y :: zs -> x = y || loop (y :: zs)
in
loop sorted
let rec expr_of_pst p =
match p with
| Pst.Symbol sym -> begin
try
IntLit (int_of_string sym)
with
Failure _ ->
match sym with
| "true" -> BoolLit true
| "false" -> BoolLit false
| "nil" -> Nil
| _ ->
if String.get sym 0 = '\''
then Symbol (String.sub sym 1 (String.length sym - 1))
else Variable sym
end
| Pst.Node [] -> raise (AbstractSyntaxError "Expected expression but got '()'")
| Pst.Node (head :: args) ->
match head, args with
| Pst.Node _, _ -> raise (AbstractSyntaxError ("Expression forms must start with a symbol, but got " ^ Pst.string_of_pst head))
| Pst.Symbol "+", [left; right] -> Plus (expr_of_pst left, expr_of_pst right)
| Pst.Symbol "+", _ -> raise (AbstractSyntaxError ("operator + expects 2 args but got " ^ Pst.string_of_pst p))
| Pst.Symbol "-", [left; right] -> Minus (expr_of_pst left, expr_of_pst right)
| Pst.Symbol "-", _ -> raise (AbstractSyntaxError ("operator - expects 2 args but got " ^ Pst.string_of_pst p))
| Pst.Symbol "*", [left; right] -> Times (expr_of_pst left, expr_of_pst right)
| Pst.Symbol "*", _ -> raise (AbstractSyntaxError ("operator * expects 2 args but got " ^ Pst.string_of_pst p))
| Pst.Symbol "=", [left; right] -> Equals (expr_of_pst left, expr_of_pst right)
| Pst.Symbol "=", _ -> raise (AbstractSyntaxError ("operator = expects 2 args but got " ^ Pst.string_of_pst p))
| Pst.Symbol "if", [branch; thn; els] -> If (expr_of_pst branch, expr_of_pst thn, expr_of_pst els)
| Pst.Symbol "if", _ -> raise (AbstractSyntaxError ("'if' special form expects 3 args but got " ^ Pst.string_of_pst p))
(* TODO: add cases for let expressions here *)
| Pst.Symbol "cons", [left; right] -> Cons (expr_of_pst left, expr_of_pst right)
| Pst.Symbol "cons", _ -> raise (AbstractSyntaxError ("cons expects 2 args but got " ^ Pst.string_of_pst p))
| Pst.Symbol "nil?", [arg] -> IsNil (expr_of_pst arg)
| Pst.Symbol "nil?", _ -> raise (AbstractSyntaxError ("nil? expects 1 arg but got " ^ Pst.string_of_pst p))
| Pst.Symbol "cons?", [arg] -> IsCons (expr_of_pst arg)
| Pst.Symbol "cons?", _ -> raise (AbstractSyntaxError ("cons? expects 1 arg but got " ^ Pst.string_of_pst p))
| Pst.Symbol "car", [arg] -> Car (expr_of_pst arg)
| Pst.Symbol "car", _ -> raise (AbstractSyntaxError ("car expects 1 arg but got " ^ Pst.string_of_pst p))
| Pst.Symbol "cdr", [arg] -> Cdr (expr_of_pst arg)
| Pst.Symbol "cdr", _ -> raise (AbstractSyntaxError ("cdr expects 1 arg but got " ^ Pst.string_of_pst p))
| Pst.Symbol "cond", clauses ->
(* converts a list of cond clauses in PST syntax into their abstract
syntax as a list of pairs of expressions. *)
let rec clause_loop (clauses: Pst.pst list): (expr * expr) list =
match clauses with
| [] -> []
| Pst.Node [e1; e2] :: xs ->
(* TODO: replace "[]" below with code to parse a cond clause.
- Hint: convert e1 and e2 to expressions, pair them up, and cons
them onto the recursive call on xs *)
[]
| x :: _ -> raise (AbstractSyntaxError("Malformed 'cond' clause: " ^ Pst.string_of_pst x))
in
Cond (clause_loop clauses)
(* TODO: add parsing for match expressions here *)
(* Otherwise, if it doesn't match any of the above, it's a function call. *)
| Pst.Symbol f, args ->
let rec args_loop args =
match args with
| [] -> []
| arg :: args -> expr_of_pst arg :: args_loop args
in
Call (f, args_loop args)
let expr_of_string s =
s
|> Pstparser.pst_of_string
|> expr_of_pst
(* checks that all the psts are symbols, and if so, convert to a list of
strings. if not, throw AbstractSyntaxError. *)
let rec check_symbols (msg, pst_list) =
match pst_list with
| [] -> []
| Pst.Symbol name :: xs -> name :: check_symbols (msg, xs)
| p :: _ -> raise (AbstractSyntaxError(msg ^ " must be symbol but got " ^ Pst.string_of_pst p))
type function_binding = { name: string; param_names: string list; body: expr }
[@@deriving show]
type struct_binding = { name: string; field_names: string list }
[@@deriving show]
type binding =
| VarBinding of string * expr
| TopLevelExpr of expr
| FunctionBinding of function_binding
(* TODO: add a constructor for test bindings here *)
| StructBinding of struct_binding
[@@deriving show]
let string_of_binding = show_binding
let binding_of_pst p =
match p with
| Pst.Symbol _ -> TopLevelExpr (expr_of_pst p)
| Pst.Node [] -> raise (AbstractSyntaxError "Expected binding but got '()'")
| Pst.Node (head :: args) ->
match head, args with
| Pst.Symbol "define", [Pst.Symbol lhs_var; rhs] -> VarBinding (lhs_var, expr_of_pst rhs)
| Pst.Symbol "define", [Pst.Node (Pst.Symbol name :: param_names); rhs] ->
let param_names = check_symbols ("Function parameter", param_names) in
if has_duplicates (name :: param_names)
then raise (AbstractSyntaxError("Function binding reuses a symbol multiple times as a function name or parameter name"));
FunctionBinding {name; param_names; body = expr_of_pst rhs}
| Pst.Symbol "define", _ -> raise (AbstractSyntaxError("This definition is malformed " ^ Pst.string_of_pst p))
(* TODO: parse test bindings here *)
| Pst.Symbol "struct", Pst.Symbol name :: field_names ->
(* note: a struct with a field of the same name as the struct itself is allowed *)
failwith "TODO: parse struct bindings here."
| Pst.Symbol "struct", _ -> raise (AbstractSyntaxError("'struct' bindings must at least one argument, but got none"))
| Pst.Node _, _ -> raise (AbstractSyntaxError("Expected binding to start with a symbol but got " ^ Pst.string_of_pst p))
| _ -> TopLevelExpr (expr_of_pst p)
let binding_of_string s =
s
|> Pstparser.pst_of_string
|> binding_of_pst
let bindings_of_string s =
let p = Pstparser.pstparser_of_string s in
let rec parse_binding_list () =
match Pstparser.parse_pst p with
| None -> []
| Some pst ->
binding_of_pst pst :: parse_binding_list ()
in
parse_binding_list ()
(executable
(name trefoil3)
(libraries trefoil3lib)
(modules trefoil3))
(library
(name trefoil3lib)
(modules errors ast pst pstparser interpreter)
(preprocess (pps ppx_deriving.show)))
(library
(name trefoil3test)
(modules trefoil3test)
(libraries trefoil3lib)
(inline_tests)
(preprocess (pps ppx_inline_test)))
(env
(dev
(flags (:standard -warn-error -A))))
\ No newline at end of file
exception ParenthesizedSymbolError of string
exception AbstractSyntaxError of string
exception RuntimeError of string
exception InternalError of string
open Ast
open Errors
type entry =
| VariableEntry of expr
| FunctionEntry of function_binding * dynamic_env
| StructEntry of struct_binding
[@@deriving show]
and dynamic_env = (string * entry) list
let entry_of_string = show_entry
let rec lookup (dynenv, name) =
match dynenv with
| [] -> None
| (x, entry) :: dynenv ->
if x = name
then Some entry
else lookup (dynenv, name)
(* ignore this until working on part 2 *)
let rec interpret_pattern (pattern, value): dynamic_env option =
match pattern, value with
| WildcardPattern, _ -> Some []
| ConsPattern (p1, p2), Cons (v1, v2) -> begin
match interpret_pattern (p1, v1), interpret_pattern (p2, v2) with
| Some l1, Some l2 -> Some (l1 @ l2)
| _ -> None
end
(* TODO: add cases for other kinds of patterns here *)
| _ -> None
let rec interpret_expression (dynenv, e) =
(* helper function to interpret a list of expressions into a list of values *)
let rec interpret_list (dynenv, es) =
match es with
| [] -> []
| e :: es -> interpret_expression (dynenv, e) :: interpret_list (dynenv, es)
in
match e with
| IntLit _ | BoolLit _ | Nil | StructConstructor _ -> e
| Variable x -> begin
match lookup (dynenv, x) with
| None -> raise (RuntimeError ("Unbound variable " ^ x))
| Some (VariableEntry value) -> value
| Some e -> raise (RuntimeError ("Expected name " ^ x ^ " to refer to a variable, but got something else: " ^ entry_of_string e))
end
| Plus (e1, e2) -> begin
match interpret_expression (dynenv, e1), interpret_expression (dynenv, e2) with
| IntLit n1, IntLit n2 -> IntLit (n1 + n2)
| IntLit _, v2 -> raise (RuntimeError ("Plus applied to non-integer " ^ string_of_expr v2))
| v1, _ -> raise (RuntimeError ("Plus applied to non-integer " ^ string_of_expr v1))
end
| Minus (e1, e2) -> begin
match interpret_expression (dynenv, e1), interpret_expression (dynenv, e2) with
| IntLit n1, IntLit n2 -> IntLit (n1 - n2)
| IntLit _, v2 -> raise (RuntimeError ("Minus applied to non-integer " ^ string_of_expr v2))
| v1, _ -> raise (RuntimeError ("Minus applied to non-integer " ^ string_of_expr v1))
end
| Times (e1, e2) -> begin
match interpret_expression (dynenv, e1), interpret_expression (dynenv, e2) with
| IntLit n1, IntLit n2 -> IntLit (n1 * n2)
| IntLit _, v2 -> raise (RuntimeError ("Times applied to non-integer " ^ string_of_expr v2))
| v1, _ -> raise (RuntimeError ("Times applied to non-integer " ^ string_of_expr v1))
end
| Equals (e1, e2) -> begin
match interpret_expression (dynenv, e1), interpret_expression (dynenv, e2) with
| IntLit n1, IntLit n2 -> BoolLit (n1 = n2)
| IntLit _, v2 -> raise (RuntimeError ("Equals applied to non-integer " ^ string_of_expr v2))
| v1, _ -> raise (RuntimeError ("Equals applied to non-integer " ^ string_of_expr v1))
end
| If (e1, e2, e3) -> begin
match interpret_expression (dynenv, e1) with
| BoolLit false -> interpret_expression (dynenv, e3)
| _ -> interpret_expression (dynenv, e2)
end
(* TODO: add case for let expressions here *)
| Cons (e1, e2) ->
let v1 = interpret_expression (dynenv, e1) in
let v2 = interpret_expression (dynenv, e2) in
Cons (v1, v2)
| IsNil e -> begin
match interpret_expression (dynenv, e) with
| Nil -> BoolLit true
| _ -> BoolLit false
end
| IsCons e -> begin
match interpret_expression (dynenv, e) with
| Cons _ -> BoolLit true
| _ -> BoolLit false
end
| Car e -> begin
match interpret_expression (dynenv, e) with
| Cons (v1, _) -> v1
| v -> raise (RuntimeError("car applied to non-cons " ^ string_of_expr v))
end
| Cdr e -> begin
match interpret_expression (dynenv, e) with
| Cons (_, v2) -> v2
| v -> raise (RuntimeError("car applied to non-cons " ^ string_of_expr v))
end
| Call (fun_name, arg_exprs) -> begin
let callenv = dynenv in
match lookup (callenv, fun_name) with
| None -> raise (RuntimeError ("Unbound function " ^ fun_name))
| Some ((FunctionEntry (fb, defenv)) as entry) ->
(* This provided line handles recursion differently than (but
equivalent to) HW3! When you build the environment to evaluate the
function body, start from this defenv. *)
let defenv = (fun_name, entry) :: defenv in
failwith "TODO: implement function calls here"
| Some (StructEntry sb) ->
(* ignore this until part 2 *)
failwith "TODO: implement 'calling' a struct as calling its constructor"
| Some e -> raise (RuntimeError ("Expected name " ^ fun_name ^ " to refer to a function or struct, but got something else: " ^ entry_of_string e))
end
| Cond clauses ->
let rec loop clauses =
match clauses with
| [] -> raise (RuntimeError("cond failure: no clauses left"))
| (predicate, body) :: clauses ->
failwith "TODO: implement the semantics of cond here"
in
loop clauses
| Symbol _ -> failwith "TODO: handle Symbols in the interpreter"
(* TODO: add cases for the other "internal" expressions here *)
(* TODO: add case for match expressions here *)
let interpret_binding (dynenv, b) =
match b with
| VarBinding (x, e) ->
let v = interpret_expression (dynenv, e) in
Printf.printf "%s = %s\n%!" x (string_of_expr v);
(x, VariableEntry v) :: dynenv
| TopLevelExpr e ->
let v = interpret_expression (dynenv, e) in
print_endline (string_of_expr v);
dynenv
| FunctionBinding fb ->
Printf.printf "%s is defined\n%!" fb.name;
(fb.name, FunctionEntry (fb, dynenv)) :: dynenv
(* TODO: implement test bindings here *)
| StructBinding sb ->
(* TODO: uncomment the comment on the next line and replace the "..." with
a mapping for the structs name to a StructEntry containing sb. *)
let dynenv = (* ... :: *) dynenv in
(* TODO: create struct predicate function here *)
let dynenv = (* ... :: *) dynenv in
(* TODO: uncomment this when ready to do accessor functions *)
(*
let fun_entry_for_accessor (idx, field_name): string * entry =
failwith "TODO: generate a function entry mapping that defines a struct accessor function"
in
let rec fun_entry_accessor_loop (idx, field_names) =
match field_names with
| [] -> []
| f :: field_names -> fun_entry_for_accessor (idx, f) :: fun_entry_accessor_loop (idx+1, field_names)
in
let dynenv = fun_entry_accessor_loop (0, sb.field_names) @ dynenv in
*)
dynenv
(* the semantics of a whole program (sequence of bindings) *)
let rec interpret_bindings (dynenv, bs) =
match bs with
| [] -> dynenv
| b :: bs ->
interpret_bindings (interpret_binding (dynenv, b), bs)
(* starting from dynenv, first interpret the list of bindings in order. then, in
the resulting dynamic environment, interpret the expression and return its
value *)
let interpret_expression_after_bindings (dynenv, bindings, expr) =
interpret_expression (interpret_bindings (dynenv, bindings), expr)
type pst =
| Symbol of string
| Node of pst list
[@@deriving show]
(* write our own string function with nicer output *)
let string_of_pst pst =
let rec loop buf pst =
match pst with
| Symbol sym -> Buffer.add_string buf sym
| Node [] -> Buffer.add_string buf "()"
| Node (x :: xs) ->
Buffer.add_char buf '(';
loop buf x;
let rec list_loop xs =
match xs with
| [] -> ()
| x :: xs -> Buffer.add_char buf ' '; loop buf x; list_loop xs
in
list_loop xs;
Buffer.add_char buf ')'
in
let buf = Buffer.create 16 in
loop buf pst;
Buffer.contents buf
open Errors
(** A "source" of characters. Since the built-in in_channel is
inherently mutable, it makes sense for all sources to be treated
mutably. *)
type source = File of in_channel | String of {string: string; mutable index: int}
(** Read the next character from the given source and return it. None indicates end of file. *)
let source_advance s =
match s with
| File ic -> begin
try
Some (input_char ic)
with
End_of_file -> None
end
| String ({string; index} as r) ->
if index >= String.length string
then None
else begin
r.index <- index+1;
Some (String.get string index)
end
type peek_reader = {
source: source;
mutable next: char option;
mutable line_num: int; (* line_num/column_num *of* next char *)
mutable column_num: int
}
let peek_reader_of_source s =
let c = source_advance s in
{source = s; next = c; line_num = 1; column_num = 0}
let peek_reader_advance pr =
if pr.next = None then failwith "peek_reader_advance: advancing past EOF";
let next = source_advance pr.source in
let (line, col) =
if pr.next = Some '\n'
then (pr.line_num+1, 0)
else (pr.line_num, pr.column_num+1)
in
(* Printf.printf "char debug('%s')\n%!" (match next with None -> "" | Some c -> String.make 1 c); *)
pr.next <- next;
pr.line_num <- line;
pr.column_num <- col;
next
type raw_token = SymbolToken of string | OpenParen | CloseParen | EOFToken
[@@deriving show]
let string_of_raw_token = show_raw_token
type token = {
raw: raw_token;
line_num: int;
column_num: int;
}
let string_of_token t =
Printf.sprintf "%s:%d:%d" (string_of_raw_token t.raw) t.line_num t.column_num
type tokenizer = {
reader: peek_reader;
}
let tokenizer_of_peek_reader reader = {reader}
let tokenizer_of_source s =
s
|> peek_reader_of_source
|> tokenizer_of_peek_reader
let rec tokenizer_advance t =
let rec skip_to_line t =
match peek_reader_advance t.reader with
| None | Some '\n' -> ()
| _ -> skip_to_line t
in
let rec consume_symbol_into t buf =
match t.reader.next with
| None | Some (';' | ')' | '(' | ' ' | '\n' | '\t' | '\r')-> Buffer.contents buf
| Some c ->
ignore (peek_reader_advance t.reader);
Buffer.add_char buf c;
consume_symbol_into t buf
in
let consume_symbol t = consume_symbol_into t (Buffer.create 16) in
let c = t.reader.next in
let line_num = t.reader.line_num in
let column_num = t.reader.column_num in
match c with
| None ->
{ raw = EOFToken;
line_num;
column_num;
}
| Some (' ' | '\n' | '\t' | '\r') -> ignore (peek_reader_advance t.reader); tokenizer_advance t
| Some (('(' | ')') as c) ->
ignore (peek_reader_advance t.reader);
{ raw = if c = '(' then OpenParen else CloseParen;
line_num;
column_num;
}
| Some ';' -> skip_to_line t; tokenizer_advance t
| Some _ ->
let sym = consume_symbol t in
{ raw = SymbolToken sym;
line_num;
column_num;
}
let parse_pst t =
let rec parse_pst_on_stack t stack =
let tkn = tokenizer_advance t in
(* Printf.printf "tokenizer_advance debug %s\n%!" (string_of_token tkn); *)
match tkn.raw with
| OpenParen -> parse_pst_on_stack t ([] :: stack)
| CloseParen -> begin
match stack with
| xs1 :: xs2 :: xss -> parse_pst_on_stack t ((Pst.Node (List.rev xs1) :: xs2) :: xss)
| [xs1] -> Some (Pst.Node (List.rev xs1))
| [] -> raise (ParenthesizedSymbolError (Printf.sprintf "%d:%d: Unexpected close parenthesis" tkn.line_num tkn.column_num))
end
| EOFToken -> begin
match stack with
| [] -> None
| _ -> raise (ParenthesizedSymbolError (Printf.sprintf "%d:%d: Unexpected EOF (missing close paren?)" tkn.line_num tkn.column_num))