From 48ccec464e0931e34dce9001b943fab4dd445104 Mon Sep 17 00:00:00 2001 From: Hyeonung Baek Date: Thu, 24 Feb 2022 02:31:29 +0900 Subject: [PATCH] refactor externals (temp commit) --- ast.ml | 24 +-------- eval.ml | 153 ++++++++++++++++++++++++++++-------------------------- main.ml | 3 +- parser.ml | 59 +++++++++++---------- 4 files changed, 110 insertions(+), 129 deletions(-) diff --git a/ast.ml b/ast.ml index 4b49ed0..823cc13 100644 --- a/ast.ml +++ b/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 diff --git a/eval.ml b/eval.ml index 0a5e022..ffda33a 100644 --- a/eval.ml +++ b/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) diff --git a/main.ml b/main.ml index 61744b8..c402069 100644 --- a/main.ml +++ b/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 diff --git a/parser.ml b/parser.ml index c420626..2ef6aba 100644 --- a/parser.ml +++ b/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