diff --git a/ast.ml b/ast.ml index 961a9c1..4655a58 100644 --- a/ast.ml +++ b/ast.ml @@ -30,6 +30,7 @@ type t = | Unary of operator * t | Binop of t * operator * t | Apply of t * t list (* function application *) + (* these will be seperated into (toplevel) directives. *) | Set_binop_pre of operator * t | Get_binop_pre of operator | Set_binop_aso of operator * string @@ -41,101 +42,14 @@ and operator = | Exp (* exponentation *) | Negate -exception Invalid_type of Type.t - -module Value = struct - type expr = t - - type t = - | Int of int - | Float of float - | String of string - | Function of string list * expr - | External of string - | Nop (* return of system operations (will be deprecated) *) - - let to_string = function - | Int n -> string_of_int n - | Float n -> string_of_float n - | String s -> "\"" ^ s ^ "\"" - | Function (vars, _) -> - Printf.sprintf "function with %d arguments" @@ List.length vars - | External f -> "external " ^ f - | Nop -> "nop" - - let typeof = function - | Int _ -> Type.Int - | Float _ -> Type.Float - | String _ -> Type.String - | Function _ -> Type.Function - | External _ -> Type.External - | Nop -> failwith "Value.typeof" - - let promote = function - | Int n -> Float (float n) - | Float n -> Float n - | _ -> failwith "Value.promote" -end - -(* operators *) -module Operator = struct - type t = operator - - exception Unavailable of t - - let to_string = function - | Add -> "+" - | Sub -> "-" - | Mul -> "*" - | Div -> "/" - | Mod -> "%" - | Exp -> "^" - | Negate -> "-" - - open Value - - let negate = function - | Int n -> Int ~-n - | Float n -> Float ~-.n - | _ -> failwith "Operator.negate" - - let vi f a b = - match a, b with - | Int a, Int b -> Int (f a b) - | _ -> raise @@ Invalid_type Int - - let vf f a b = - match a, b with - | Float a, Float b -> Float (f a b) - | _ -> raise @@ Invalid_type Float - - let operators = - let open Type in - let ip = Int, Int and fp = Float, Float 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]; - ] - |> 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_unary = function - | Negate -> negate - | op -> raise @@ Unavailable op - - let get_binary op typ = - Hashtbl.find operators op - |> List.assoc_opt typ -end +let op_to_string = function + | Add -> "+" + | Sub -> "-" + | Mul -> "*" + | Div -> "/" + | Mod -> "%" + | Exp -> "^" + | Negate -> "-" let unary op t = Unary (op, t) @@ -159,23 +73,23 @@ let print ast = | Let (v, e) -> pr "(let %s " v; aux e; pr ")" | Unary (op, t) -> - let op = Operator.to_string op in + let op = op_to_string op in pr "(%s " op; aux t; pr ")" | Binop (left, op, right) -> - let op = Operator.to_string op in + let op = op_to_string op in pr "(%s " op; aux left; pr " "; aux right; pr ")" | Apply (f, args) -> pr "("; List.iter aux @@ f::args; pr ")" | Set_binop_pre (op, pre) -> - pr "(set_pre %s " (Operator.to_string op); + pr "(set_pre %s " (op_to_string op); aux pre; pr ")" | Get_binop_pre op -> - pr "(get_pre %s)" (Operator.to_string op) + pr "(get_pre %s)" (op_to_string op) | Set_binop_aso (op, aso) -> - pr "(set_assoc %s %s)" (Operator.to_string op) aso + pr "(set_assoc %s %s)" (op_to_string op) aso | Get_binop_aso op -> - pr "(get_pre %s)" (Operator.to_string op) + pr "(get_pre %s)" (op_to_string op) in aux ast; pr "\n" diff --git a/env.ml b/env.ml index 4bdedde..fe64a35 100644 --- a/env.ml +++ b/env.ml @@ -1,10 +1,44 @@ -module Value = Ast.Value - type t = { - vars : (string, Value.t) Hashtbl.t; + vars : (string, value) Hashtbl.t; parent : t option; } +and value = + | Int of int + | Float of float + | String of string + | Function of string list * expr + | External of string + | Nop (* return of system operations (will be deprecated) *) + +and expr = Ast.t + +module Value = struct + module Type = Ast.Type + type t = value + + let to_string = function + | Int n -> string_of_int n + | Float n -> string_of_float n + | String s -> "\"" ^ s ^ "\"" + | Function (vars, _) -> + Printf.sprintf "function with %d arguments" @@ List.length vars + | External f -> "external " ^ f + | Nop -> "nop" + + let typeof = function + | Int _ -> Type.Int + | Float _ -> Type.Float + | String _ -> Type.String + | Function _ -> Type.Function + | External _ -> Type.External + | Nop -> failwith "Value.typeof" + + let promote = function + | Int n -> Float (float n) + | _ -> failwith "Value.promote" +end + let init_global () = { vars = Hashtbl.create 100; parent = None; diff --git a/eval.ml b/eval.ml index 52cc6a5..d5fd1a2 100644 --- a/eval.ml +++ b/eval.ml @@ -1,12 +1,65 @@ open Ast -open Ast.Value +open Env +open Env.Value exception No_operation exception No_such_variable of string exception No_such_function of string +exception Invalid_type of Type.t exception Too_many_arguments +(* operators *) +module Operator = struct + type t = Ast.operator + + exception Unavailable of t + + let to_string = Ast.op_to_string + + let negate = function + | Int n -> Int ~-n + | Float n -> Float ~-.n + | _ -> failwith "Operator.negate" + + let vi f a b = + match a, b with + | Int a, Int b -> Int (f a b) + | _ -> raise @@ Invalid_type Int + + let vf f a b = + match a, b with + | Float a, Float b -> Float (f a b) + | _ -> raise @@ Invalid_type Float + + let operators = + let open Type in + let ip = Int, Int and fp = Float, Float 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]; + ] + |> 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_unary = function + | Negate -> negate + | op -> raise @@ Unavailable op + + let get_binary op typ = + Hashtbl.find operators op + |> List.assoc_opt typ +end + let assert_same_length vars args = let vl = List.length vars and al = List.length args in @@ -14,7 +67,6 @@ let assert_same_length vars args = failwith "assert_same_length" else if vl < al then raise Too_many_arguments - else () let resolve_type op tp = let optypes = Operator.get_types op in diff --git a/main.ml b/main.ml index 4ff2848..bd7a75d 100644 --- a/main.ml +++ b/main.ml @@ -8,7 +8,7 @@ let error_to_string e = | Lex.Expected c -> sprintf "expected %c" c | Parser.Expected t -> sprintf "expected %s" t | Parser.Unexpected_token t -> sprintf "unexpected token \"%s\"" t - | Ast.Invalid_type t -> sprintf "invalid type %s" (Ast.Type.to_string t) + | Eval.Invalid_type t -> sprintf "invalid type %s" (Ast.Type.to_string t) | Eval.No_such_variable v -> sprintf "no such variable %s" v | Eval.No_such_function f -> sprintf "no such function \"%s\"" f | Eval.Too_many_arguments -> "applied too many arguments" @@ -24,7 +24,7 @@ let stdlib = [ "deg"; "rad"; ] |> List.to_seq - |> Seq.map (fun v -> v, Ast.Value.External v) + |> Seq.map (fun v -> v, Env.External v) let g = let g = Env.init_global () in @@ -46,12 +46,12 @@ let rep env : unit = | Nop -> () | _ -> Env.set env "ans" v; - printf "%s\n" @@ Ast.Value.to_string v + printf "%s\n" @@ Env.Value.to_string v exception Reset_line (* used to indicate ^C is pressed *) let init_repl () = - Env.set g "ans" (Ast.Value.Int 0); + Env.set g "ans" (Env.Int 0); (* treat Ctrl-C as to reset line *) let reset_line _ = raise Reset_line in Sys.(set_signal sigint (Signal_handle reset_line))