refactor externals (temp commit)
This commit is contained in:
parent
c2ee352f1c
commit
48ccec464e
4 changed files with 110 additions and 129 deletions
24
ast.ml
24
ast.ml
|
|
@ -16,27 +16,7 @@ type t =
|
|||
| If of t * t * t (* cond then else *)
|
||||
| Apply of t * t list (* function application *)
|
||||
|
||||
and operator =
|
||||
| Add | Sub | Mul | Div (* arithmetics *)
|
||||
| Mod (* modular operation *)
|
||||
| Exp (* exponentation *)
|
||||
| Eq | Neq | GE | LE | GT | LT
|
||||
| Negate
|
||||
|
||||
let op_to_string = function
|
||||
| Add -> "+"
|
||||
| Sub -> "-"
|
||||
| Mul -> "*"
|
||||
| Div -> "/"
|
||||
| Mod -> "%"
|
||||
| Exp -> "^"
|
||||
| Eq -> "="
|
||||
| Neq -> "<>"
|
||||
| GE -> ">="
|
||||
| LE -> "<="
|
||||
| GT -> ">"
|
||||
| LT -> "<"
|
||||
| Negate -> "-"
|
||||
and operator = string
|
||||
|
||||
let unary op t =
|
||||
Unary (op, t)
|
||||
|
|
@ -70,10 +50,8 @@ let print ast =
|
|||
| Letin (v, e, f) ->
|
||||
pr "(let ((%s " v; aux e; pr ")) "; aux f; pr ")"
|
||||
| Unary (op, t) ->
|
||||
let op = op_to_string op in
|
||||
pr "(%s " op; aux t; pr ")"
|
||||
| Binop (left, op, right) ->
|
||||
let op = op_to_string op in
|
||||
pr "(%s " op; aux left; pr " "; aux right; pr ")"
|
||||
| If (co, th, el) ->
|
||||
let f e = pr " "; aux e in
|
||||
|
|
|
|||
153
eval.ml
153
eval.ml
|
|
@ -17,9 +17,6 @@ and expr = Ast.t
|
|||
(* environment for eval *)
|
||||
and env = Env of (string * value) list
|
||||
|
||||
exception No_operation
|
||||
exception Too_many_arguments
|
||||
|
||||
(* TODO: add proper type system *)
|
||||
module Type = struct
|
||||
type t =
|
||||
|
|
@ -30,6 +27,7 @@ module Type = struct
|
|||
| Symbol
|
||||
| Function
|
||||
| External
|
||||
| Any
|
||||
|
||||
exception Invalid of t
|
||||
exception Expected of t
|
||||
|
|
@ -42,10 +40,15 @@ module Type = struct
|
|||
| Symbol -> "symbol"
|
||||
| Function -> "fun"
|
||||
| External -> "external"
|
||||
| Any -> "any"
|
||||
|
||||
let supertype = function
|
||||
| Int -> Some Float
|
||||
| _ -> None
|
||||
|
||||
let matches : t -> t -> bool = function
|
||||
| Any -> Fun.const true
|
||||
| t -> fun o -> o = t || o = Any
|
||||
end
|
||||
|
||||
module Value = struct
|
||||
|
|
@ -91,14 +94,8 @@ module Env = struct
|
|||
Env (List.of_seq seq @ e)
|
||||
end
|
||||
|
||||
(* operators *)
|
||||
module Operator = struct
|
||||
type t = Ast.operator
|
||||
|
||||
exception Unavailable of t
|
||||
|
||||
let to_string = Ast.op_to_string
|
||||
|
||||
(* primitive methods *)
|
||||
module Primitive = struct
|
||||
let negate = function
|
||||
| [Int n] -> Int ~-n
|
||||
| [Float n] -> Float ~-.n
|
||||
|
|
@ -127,45 +124,16 @@ module Operator = struct
|
|||
let gt vs = Bool (compare vs > 0)
|
||||
let lt vs = Bool (compare vs < 0)
|
||||
|
||||
(* operator table *)
|
||||
let operators =
|
||||
let open Type in
|
||||
let ip = [Int; Int] and fp = [Float; Float] in
|
||||
let any f = [ip, f; fp, f] in
|
||||
[
|
||||
Add, [ip, vi Int.add; fp, vf Float.add];
|
||||
Sub, [ip, vi Int.sub; fp, vf Float.sub];
|
||||
Mul, [ip, vi Int.mul; fp, vf Float.mul];
|
||||
Div, [ip, vi Int.div; fp, vf Float.div];
|
||||
Mod, [ip, vi Int.rem; fp, vf Float.rem];
|
||||
Exp, [fp, vf Float.pow];
|
||||
Eq, any eq;
|
||||
Neq, any neq;
|
||||
GE, any ge;
|
||||
LE, any le;
|
||||
GT, any gt;
|
||||
LT, any lt;
|
||||
Negate, [[Int], negate; [Float], negate];
|
||||
]
|
||||
|> List.to_seq
|
||||
|> Hashtbl.of_seq
|
||||
|
||||
let get op =
|
||||
Hashtbl.find operators op
|
||||
end
|
||||
|
||||
module External = struct
|
||||
exception Invalid of string
|
||||
|
||||
let rad r =
|
||||
r *. 180. /. Float.pi
|
||||
|
||||
let deg d =
|
||||
d /. 180. *. Float.pi
|
||||
|
||||
let floatfun f = function
|
||||
let floatfun f =
|
||||
[Type.Float],
|
||||
function
|
||||
| [Float n] -> Float (f n)
|
||||
| [v] -> raise @@ Type.Invalid (Value.typeof v)
|
||||
| _ -> invalid_arg "External.floatfun"
|
||||
|
||||
let symbol_to_op op =
|
||||
|
|
@ -222,68 +190,103 @@ module External = struct
|
|||
Printf.printf "\n";
|
||||
Nop
|
||||
|
||||
let apply f args =
|
||||
let f = match f with
|
||||
| "sin" -> floatfun Float.sin
|
||||
| "cos" -> floatfun Float.cos
|
||||
| "tan" -> floatfun Float.tan
|
||||
| "deg" -> floatfun deg
|
||||
| "rad" -> floatfun rad
|
||||
| "set_op_pre" -> set_op_pre
|
||||
| "get_op_pre" -> get_op_pre
|
||||
| "set_op_assoc" -> set_op_assoc
|
||||
| "get_op_assoc" -> get_op_assoc
|
||||
| "print" -> print
|
||||
| "println" -> println
|
||||
| _ -> raise @@ Invalid f
|
||||
in
|
||||
f args
|
||||
|
||||
let methods =
|
||||
let open Type in
|
||||
let ip = [Int; Int] and fp = [Float; Float] in
|
||||
let number f = [ip, f; fp, f] in
|
||||
[
|
||||
"+", [ip, vi Int.add; fp, vf Float.add];
|
||||
"-", [ip, vi Int.sub; fp, vf Float.sub;
|
||||
[Int], negate; [Float], negate];
|
||||
"*", [ip, vi Int.mul; fp, vf Float.mul];
|
||||
"/", [ip, vi Int.div; fp, vf Float.div];
|
||||
"%", [ip, vi Int.rem; fp, vf Float.rem];
|
||||
"^", [fp, vf Float.pow];
|
||||
"=", number eq;
|
||||
"<>", number neq;
|
||||
">=", number ge;
|
||||
"<=", number le;
|
||||
">", number gt;
|
||||
"<", number lt;
|
||||
|
||||
"sin", [floatfun Float.sin];
|
||||
"cos", [floatfun Float.cos];
|
||||
"tan", [floatfun Float.tan];
|
||||
"deg", [floatfun deg];
|
||||
"rad", [floatfun rad];
|
||||
"set_op_pre", [[Symbol; Int], set_op_pre];
|
||||
"get_op_pre", [[Symbol], get_op_pre];
|
||||
"set_op_assoc", [[Symbol; String], set_op_assoc];
|
||||
"get_op_assoc", [[Symbol], get_op_assoc];
|
||||
"print", [[Any], print];
|
||||
"println", [[Any], println];
|
||||
]
|
||||
|> List.to_seq
|
||||
|> Hashtbl.of_seq
|
||||
|
||||
let get op =
|
||||
Hashtbl.find methods op
|
||||
end
|
||||
|
||||
let find_operator op ts =
|
||||
(* find_method returns a method and (corresponding) type list that
|
||||
* satisfies ts. *)
|
||||
let find_method m ts =
|
||||
let open List in
|
||||
let filter_type t i =
|
||||
filter (fun (ts, _) ->
|
||||
nth_opt ts i
|
||||
|> Option.map ((=) t)
|
||||
|> Option.map (Type.matches t)
|
||||
|> Option.value ~default: false)
|
||||
in
|
||||
let rec aux ops i = function
|
||||
| [] ->
|
||||
ops
|
||||
|> filter (fun (ts, _) -> length ts = i)
|
||||
|> Fun.flip nth_opt 0
|
||||
let rec aux ms i = function
|
||||
| [] -> nth_opt ms 0
|
||||
| t::ts ->
|
||||
(match aux (filter_type t i ops) (i+1) ts with
|
||||
(match aux (filter_type t i ms) (i+1) ts with
|
||||
| None -> Option.bind (Type.supertype t)
|
||||
(fun t -> aux ops i (t::ts))
|
||||
(fun t -> aux ms i (t::ts))
|
||||
| Some _ as x -> x)
|
||||
in
|
||||
aux (Operator.get op) 0 ts
|
||||
let ms =
|
||||
let len = length ts in
|
||||
Primitive.get m
|
||||
|> filter (fun (ts, _) -> length ts = len)
|
||||
in
|
||||
aux ms 0 ts
|
||||
|
||||
let promote_values =
|
||||
let rec promote_until t v =
|
||||
if Value.typeof v = t
|
||||
if Type.matches t @@ Value.typeof v
|
||||
then v
|
||||
else promote_until t @@ Value.promote v
|
||||
in
|
||||
List.map2 promote_until
|
||||
|
||||
exception No_such_method of string * Type.t
|
||||
let no_such m v = raise @@ No_such_method (m, Value.typeof v)
|
||||
|
||||
let unary op v =
|
||||
match find_operator op [Value.typeof v] with
|
||||
| None -> raise No_operation
|
||||
match find_method op [Value.typeof v] with
|
||||
| None -> no_such op v
|
||||
| Some (ts, f) ->
|
||||
let vs = promote_values ts [v] in
|
||||
f vs
|
||||
|
||||
let binop op l r =
|
||||
let open Value in
|
||||
match find_operator op [typeof l; typeof r] with
|
||||
| None -> raise No_operation
|
||||
match find_method op [typeof l; typeof r] with
|
||||
| None -> no_such op l
|
||||
| Some (ts, f) ->
|
||||
let vs = promote_values ts [l; r] in
|
||||
f vs
|
||||
|
||||
let extern f args =
|
||||
match find_method f (List.map Value.typeof args) with
|
||||
| None -> no_such f (List.hd args)
|
||||
| Some (ts, f) ->
|
||||
let vs = promote_values ts args in
|
||||
f vs
|
||||
|
||||
exception Unbound of string
|
||||
|
||||
let rec eval global env ast =
|
||||
|
|
@ -351,7 +354,7 @@ and apply global env expr args =
|
|||
else (* eval (vars = [], args = []) *)
|
||||
eval global env body
|
||||
end
|
||||
| External f -> External.apply f args
|
||||
| External f -> extern f args
|
||||
| v ->
|
||||
if args = [] then v
|
||||
else raise @@ Type.Invalid (Value.typeof v)
|
||||
|
|
|
|||
3
main.ml
3
main.ml
|
|
@ -16,7 +16,8 @@ let error_to_string e =
|
|||
sprintf "unexpected token \"%s\" at col %d" t col
|
||||
| Type.Invalid t -> sprintf "invalid type %s" (Type.to_string t)
|
||||
| Eval.Unbound v -> sprintf "unbound value %s" v
|
||||
| Eval.Too_many_arguments -> "applied too many arguments"
|
||||
| Eval.No_such_method (m, t) ->
|
||||
sprintf "no such method %s matching type %s" m (Type.to_string t)
|
||||
| Failure f -> sprintf "error on %s" f
|
||||
| Division_by_zero -> "cannot divide by zero"
|
||||
| _ -> raise e
|
||||
|
|
|
|||
59
parser.ml
59
parser.ml
|
|
@ -19,18 +19,18 @@ let unexpected_token col t =
|
|||
* precedency, but infering precedence relation from the graph is hard
|
||||
* and the graph can be made to have loops, I just used plain table. *)
|
||||
let precedence = [
|
||||
Eq, 1;
|
||||
Neq, 1;
|
||||
GE, 1;
|
||||
LE, 1;
|
||||
GT, 1;
|
||||
LT, 1;
|
||||
Add, 10;
|
||||
Sub, 10;
|
||||
Mul, 20;
|
||||
Div, 20;
|
||||
Mod, 30;
|
||||
Exp, 30;
|
||||
"=", 1;
|
||||
"<>", 1;
|
||||
">=", 1;
|
||||
"<=", 1;
|
||||
">", 1;
|
||||
"<", 1;
|
||||
"+", 10;
|
||||
"-", 10;
|
||||
"*", 20;
|
||||
"/", 20;
|
||||
"%", 30;
|
||||
"^", 30;
|
||||
] |> List.to_seq |> Hashtbl.of_seq
|
||||
|
||||
let precedence_of op =
|
||||
|
|
@ -50,7 +50,7 @@ let assoc_to_string = function
|
|||
| Right_to_left -> "right"
|
||||
|
||||
let oper_assoc = [
|
||||
Exp, Right_to_left;
|
||||
"^", Right_to_left;
|
||||
] |> List.to_seq |> Hashtbl.of_seq
|
||||
|
||||
let op_is_right_to_left op =
|
||||
|
|
@ -61,26 +61,25 @@ let op_is_right_to_left op =
|
|||
a = Right_to_left
|
||||
|
||||
let operators = [
|
||||
Token.Plus, Add;
|
||||
Minus, Sub;
|
||||
Asterisk, Mul;
|
||||
Slash, Div;
|
||||
Carret, Exp;
|
||||
Percent, Mod;
|
||||
Equal, Eq;
|
||||
Not_equal, Neq;
|
||||
Greater_equal, GE;
|
||||
Less_equal, LE;
|
||||
Greater, GT;
|
||||
Less, LT;
|
||||
] |> List.to_seq |> Hashtbl.of_seq
|
||||
Token.Plus;
|
||||
Minus;
|
||||
Asterisk;
|
||||
Slash;
|
||||
Carret;
|
||||
Percent;
|
||||
Equal;
|
||||
Not_equal;
|
||||
Greater_equal;
|
||||
Less_equal;
|
||||
Greater;
|
||||
Less;
|
||||
]
|
||||
|
||||
let token_to_op tok =
|
||||
try Hashtbl.find operators tok
|
||||
with _ -> failwith "Parser.token_to_op"
|
||||
Token.to_string tok
|
||||
|
||||
let token_is_operator tok =
|
||||
Hashtbl.mem operators tok
|
||||
List.mem tok operators
|
||||
|
||||
let is_keyword = function
|
||||
| "if" | "then" | "else" | "let" | "in" -> true
|
||||
|
|
@ -250,7 +249,7 @@ and unary seq =
|
|||
let op, seq =
|
||||
let col, x, seq = any seq in
|
||||
if x = Minus
|
||||
then Negate, seq
|
||||
then "-", seq
|
||||
else expected col "minus (-)"
|
||||
in
|
||||
let v, seq = mustbe value seq in
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue