From aba76688be6129a647ffca583fe865a2f2bffbd5 Mon Sep 17 00:00:00 2001 From: Hyeonung Baek Date: Tue, 18 Jan 2022 16:52:33 +0900 Subject: [PATCH] Refactor value --- ast.ml | 126 +++++++++++++++++++++++++++++++++++++++--------------- eval.ml | 47 ++++++++++---------- main.ml | 17 +++++--- parser.ml | 3 +- 4 files changed, 129 insertions(+), 64 deletions(-) diff --git a/ast.ml b/ast.ml index 2af8f17..10ed864 100644 --- a/ast.ml +++ b/ast.ml @@ -1,58 +1,116 @@ -type typ = - | Int of int - | Float of float - | Unit +module Type = struct + type t = + | Int + | Float -let typ_to_string = function - | Int n -> Printf.sprintf "%d" n - | Float n -> Printf.sprintf "%f" n - | Unit -> "()" + let to_string = function + | Int -> "int" + | Float -> "float" -type binop = - | Add | Sub | Mul | Div (* arithmetics *) - | Mod (* modular operation *) - | Exp (* exponentation *) + let merge a b = + match a, b with + | Int, Float -> Float + | Float, Int -> Float + | a, b when a = b -> a + | _ -> failwith "Type.merge" -let binop_to_string = function - | Add -> "+" - | Sub -> "-" - | Mul -> "*" - | Div -> "/" - | Mod -> "%" - | Exp -> "^" +end + +exception Invalid_type of Type.t + +module Value = struct + type t = + | Int of int + | Float of float + | Nop (* return of system operations *) + + let to_string = function + | Int n -> Printf.sprintf "%d" n + | Float n -> Printf.sprintf "%f" n + | Nop -> "nop" + + let typeof = function + | Int _ -> Type.Int + | Float _ -> Type.Float + | Nop -> failwith "Value.typeof" + + let promote = function + | Int n -> Float (float n) + | Float n -> Float n + | _ -> failwith "Value.promote" +end + +(* binary operator *) +module Binop = struct + type t = + | Add | Sub | Mul | Div (* arithmetics *) + | Mod (* modular operation *) + | Exp (* exponentation *) + + let to_string = function + | Add -> "+" + | Sub -> "-" + | Mul -> "*" + | Div -> "/" + | Mod -> "%" + | Exp -> "^" + + let vi f a b = + let open Value in + match a, b with + | Int a, Int b -> Int (f a b) + | _ -> raise @@ Invalid_type Int + + let vf f a b = + let open Value in + match a, b with + | Float a, Float b -> Float (f a b) + | _ -> raise @@ Invalid_type Float + + let operators = + let open Type 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]; + ] + |> List.to_seq + |> Hashtbl.of_seq + + let get op typ = + Hashtbl.find operators op + |> List.assoc_opt typ +end type t = - | Value of typ - | Binop of t * binop * t - | Set_binop_pre of binop * t - | Get_binop_pre of binop + | Value of Value.t + | Binop of t * Binop.t * t + | Set_binop_pre of Binop.t * t + | Get_binop_pre of Binop.t let value v = Value v let binop left op right = Binop (left, op, right) -let set_binop_pre op pre = - Set_binop_pre (op, pre) - (* print ast LISP style. *) let print ast = let pr = Printf.printf in - let pv v = pr "%s" @@ typ_to_string v in + let pv v = pr "%s" @@ Value.to_string v in let rec aux = function | Value n -> pv n | Binop (left, op, right) -> begin - pr "(%s " @@ binop_to_string op; - aux left; - pr " "; - aux right; - pr ")"; + let op = Binop.to_string op in + pr "(%s " op; aux left; pr " "; aux right; pr ")"; end | Set_binop_pre (op, pre) -> - pr "(set_pre %s " (binop_to_string op); + pr "(set_pre %s " (Binop.to_string op); aux pre; pr ")" | Get_binop_pre op -> - pr "(get_pre %s)" (binop_to_string op) + pr "(get_pre %s)" (Binop.to_string op) in aux ast; pr "\n" diff --git a/eval.ml b/eval.ml index baf2b2f..fdc7b75 100644 --- a/eval.ml +++ b/eval.ml @@ -1,34 +1,37 @@ open Ast +open Ast.Value -exception Invalid_type +exception No_operation -let arith intf floatf a b = - match a, b with - | Int a, Int b -> begin - try Int (intf a b) - with Exit -> Float (floatf (float a) (float b)) +let rec binop op l r = + let tl = typeof l and tr = typeof r in + let ty = Type.merge tl tr 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 + | None -> begin + try binop op (promote l) (promote r) + with _ -> raise No_operation end - | Float a, Int b -> Float (floatf a (float b)) - | Int a, Float b -> Float (floatf (float a) b) - | Float a, Float b -> Float (floatf a b) - | _ -> raise Invalid_type - -let binop_to_func = function - | Add -> arith Int.add Float.add - | Sub -> arith Int.sub Float.sub - | Mul -> arith Int.mul Float.mul - | Div -> arith Int.div Float.div - | Mod -> arith Int.rem Float.rem - | Exp -> arith (fun _ _ -> raise Exit) Float.pow + | Some f -> f l r let rec eval = function | Value v -> v | Binop (l, op, r) -> - let f = binop_to_func op in - f (eval l) (eval r) + let l = eval l and r = eval r in + binop op l r | Set_binop_pre (op, l) -> - let l = match eval l with Int n -> n | _ -> raise Invalid_type in + let l = + match eval l with + | Int n -> n + | v -> raise @@ Invalid_type (typeof v) + in Hashtbl.replace Parser.precedence op l; - Unit + Nop | Get_binop_pre op -> Int (Hashtbl.find Parser.precedence op) diff --git a/main.ml b/main.ml index 8c8c12a..fe87fe0 100644 --- a/main.ml +++ b/main.ml @@ -9,7 +9,7 @@ let error_to_string e = | Lex.Token_not_found -> sprintf "invalid token" | Parser.Expected t -> sprintf "expected %s" t | Parser.Unexpected_token t -> sprintf "unexpected token \"%s\"" t - | Eval.Invalid_type -> "invalid type" + | Ast.Invalid_type t -> sprintf "invalid type %s" (Ast.Type.to_string t) | Failure f -> sprintf "error on %s" f | Division_by_zero -> "cannot divide by zero" | _ -> raise e @@ -22,12 +22,15 @@ let rep () : unit = printf "> "; let line = read_line () in if line = "quit" then raise Exit; - line - |> Lex.tokenize - |> Parser.parse - |> Eval.eval - |> Ast.typ_to_string - |> printf "%s\n" + let ans = + line + |> Lex.tokenize + |> Parser.parse + |> Eval.eval + in + match ans with + | Nop -> () + | _ -> printf "%s\n" @@ Ast.Value.to_string ans let init_repl () = let sigintf _ = raise Reset_line in diff --git a/parser.ml b/parser.ml index c0a2552..ab3fb41 100644 --- a/parser.ml +++ b/parser.ml @@ -1,4 +1,5 @@ open Ast +open Ast.Binop module S = Set.Make(String) @@ -6,7 +7,7 @@ exception Expected of string exception Unexpected_token of string let expected t = - raise (Expected t) + raise @@ Expected t let unexpected_token t = raise @@ Unexpected_token (Token.to_string t)