diff --git a/ast.ml b/ast.ml index c0f492a..843cf65 100644 --- a/ast.ml +++ b/ast.ml @@ -9,13 +9,9 @@ module Type = struct | Float -> "float" | String -> "string" - let merge a b = - match a, b with - | Int, Float -> Float - | Float, Int -> Float - | a, b when a = b -> a - | _ -> failwith "Type.merge" - + let supertype = function + | Int -> Some Float + | _ -> None end exception Invalid_type of Type.t @@ -71,6 +67,8 @@ module Binop = struct | Mod (* modular operation *) | Exp (* exponentation *) + exception Unavailable of t + let to_string = function | Add -> "+" | Sub -> "-" @@ -93,17 +91,23 @@ module Binop = struct let operators = let open Type in + let ip = Int, Int and fp = Float, Float in [ - Add, [Int, vi Int.add; Float, vf Float.add]; - Sub, [Int, vi Int.sub; Float, vf Float.sub]; - Mul, [Int, vi Int.mul; Float, vf Float.mul]; - Div, [Int, vi Int.div; Float, vf Float.div]; - Mod, [Int, vi Int.rem; Float, vf Float.rem]; - Exp, [Float, vf Float.pow]; + 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]; ] |> List.to_seq |> Hashtbl.of_seq + let get_types op = + match Hashtbl.find_opt operators op with + | None -> raise @@ Unavailable op + | Some p -> List.map fst p + let get op typ = Hashtbl.find operators op |> List.assoc_opt typ diff --git a/eval.ml b/eval.ml index 2840b3a..f7cfc43 100644 --- a/eval.ml +++ b/eval.ml @@ -4,17 +4,33 @@ open Ast.Value exception No_operation exception No_such_variable of string +let resolve_type op tp = + let optypes = Binop.get_types op in + let q = Queue.create () in + let rec aux (t1, t2) = + if List.mem (t1, t2) optypes then + t1, t2 + else begin + [ Type.supertype t1 |> Option.map (fun t1 -> t1, t2); + Type.supertype t2 |> Option.map (fun t2 -> t1, t2); ] + |> List.filter_map Fun.id + |> List.iter (Fun.flip Queue.push q); + aux @@ Queue.pop q + end + in + aux tp + let rec binop op l r = - let tl = typeof l and tr = typeof r in - let ty = Type.merge tl tr in + let t1 = typeof l and t2 = typeof r in + let t1, t2 = resolve_type op (t1, t2) in let rec promote_until t x = if typeof x = t then x else promote_until t (promote x) in - let l = promote_until ty l - and r = promote_until ty r in - match Binop.get op ty with + let l = promote_until t1 l + and r = promote_until t2 r in + match Binop.get op (t1, t2) with | None -> begin try binop op (promote l) (promote r) with _ -> raise No_operation