diff --git a/env.ml b/env.ml deleted file mode 100644 index 21257bd..0000000 --- a/env.ml +++ /dev/null @@ -1,94 +0,0 @@ -type t = { - vars : (string, value) Hashtbl.t; - parent : t option; -} - -and value = - | Int of int - | Float of float - | String of string - | Symbol of string - | Function of string list * expr - | External of string - | Nop (* return of system operations (will be deprecated) *) - -and expr = Ast.t - -module Type = struct - type t = - | Int - | Float - | String - | Symbol - | Function - | External - - let to_string = function - | Int -> "int" - | Float -> "float" - | String -> "string" - | Symbol -> "symbol" - | Function -> "fun" - | External -> "external" - - let supertype = function - | Int -> Some Float - | _ -> None -end - -module Value = struct - type t = value - - let to_string = function - | Int n -> string_of_int n - | Float n -> string_of_float n - | String s -> "\"" ^ s ^ "\"" - | Symbol s -> "symbol " ^ 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 - | Symbol _ -> Type.Symbol - | 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; -} - -let make parent = { - vars = Hashtbl.create 100; - parent = Some parent; -} - -exception Not_found - -let rec get e name = - match Hashtbl.find_opt e.vars name with - | None -> begin match e.parent with - | None -> raise Not_found - | Some p -> get p name - end - | Some value -> value - -let get_opt e name = - try Some (get e name) - with Not_found -> None - -let set e name value = - Hashtbl.replace e.vars name value - -let add_seq e seq = - Hashtbl.add_seq e.vars seq diff --git a/eval.ml b/eval.ml index 3ffcfc5..c9692b2 100644 --- a/eval.ml +++ b/eval.ml @@ -1,6 +1,103 @@ open Ast -open Env -open Env.Value + +type value = + | Int of int + | Float of float + | String of string + | Symbol of string + | Function of string list * expr + | External of string + | Nop (* return of system operations (will be deprecated) *) + +and expr = Ast.t + +and env = { + vars : (string, value) Hashtbl.t; + parent : env option; +} + +module Type = struct + type t = + | Int + | Float + | String + | Symbol + | Function + | External + + let to_string = function + | Int -> "int" + | Float -> "float" + | String -> "string" + | Symbol -> "symbol" + | Function -> "fun" + | External -> "external" + + let supertype = function + | Int -> Some Float + | _ -> None +end + +module Value = struct + type t = value + + let to_string = function + | Int n -> string_of_int n + | Float n -> string_of_float n + | String s -> "\"" ^ s ^ "\"" + | Symbol s -> "symbol " ^ 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 + | Symbol _ -> Type.Symbol + | Function _ -> Type.Function + | External _ -> Type.External + | Nop -> failwith "Value.typeof" + + let promote = function + | Int n -> Float (float n) + | _ -> failwith "Value.promote" +end + +module Env = struct + type t = env + + let init_global () = { + vars = Hashtbl.create 100; + parent = None; + } + + let make parent = { + vars = Hashtbl.create 100; + parent = Some parent; + } + + exception Not_found + + let rec get e name = + match Hashtbl.find_opt e.vars name with + | None -> begin match e.parent with + | None -> raise Not_found + | Some p -> get p name + end + | Some value -> value + + let get_opt e name = + try Some (get e name) + with Not_found -> None + + let set e name value = + Hashtbl.replace e.vars name value + + let add_seq e seq = + Hashtbl.add_seq e.vars seq +end exception No_operation exception No_such_variable of string @@ -60,6 +157,27 @@ module Operator = struct |> List.assoc_opt typ end +module External = struct + let rad r = + r *. 180. /. Float.pi + + let deg d = + d /. 180. *. Float.pi + + let floatfun f = function + | Float n -> Float (f n) + | v -> raise @@ Invalid_type (Value.typeof v) + + let apply f args = + match f, args with + | "sin", [n] -> floatfun Float.sin n + | "cos", [n] -> floatfun Float.cos n + | "tan", [n] -> floatfun Float.tan n + | "deg", [n] -> floatfun deg n + | "rad", [n] -> floatfun rad n + | _ -> raise @@ No_such_function f +end + let assert_same_length vars args = let vl = List.length vars and al = List.length args in @@ -85,6 +203,7 @@ let resolve_type op tp = aux tp let rec binop op l r = + let open Value 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 = @@ -101,26 +220,7 @@ let rec binop op l r = end | Some f -> f l r -let rad r = - r *. 180. /. Float.pi - -let deg d = - d /. 180. *. Float.pi - -let floatfun f = function - | Float n -> Float (f n) - | v -> raise @@ Invalid_type (typeof v) - -let ex_apply f args = - match f, args with - | "sin", [n] -> floatfun Float.sin n - | "cos", [n] -> floatfun Float.cos n - | "tan", [n] -> floatfun Float.tan n - | "deg", [n] -> floatfun deg n - | "rad", [n] -> floatfun rad n - | _ -> raise @@ No_such_function f - -let rec eval env ast = +let rec eval env ast : value = let rec aux = function | Nint n -> Int n | Nfloat n -> Float n @@ -153,14 +253,14 @@ let rec eval env ast = eval nenv e | External f -> let args = List.map aux args in - ex_apply f args - | v -> raise @@ Invalid_type (typeof v) + External.apply f args + | v -> raise @@ Invalid_type (Value.typeof v) end | Set_binop_pre (op, l) -> let l = match aux l with | Int n -> n - | v -> raise @@ Invalid_type (typeof v) + | v -> raise @@ Invalid_type (Value.typeof v) in Hashtbl.replace Parser.precedence op l; Nop diff --git a/main.ml b/main.ml index ec12155..d6c828e 100644 --- a/main.ml +++ b/main.ml @@ -1,4 +1,5 @@ open Printf +open Eval let version = "%%VERSION%%" @@ -8,7 +9,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 - | Eval.Invalid_type t -> sprintf "invalid type %s" (Env.Type.to_string t) + | Eval.Invalid_type t -> sprintf "invalid type %s" (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 +25,7 @@ let stdlib = [ "deg"; "rad"; ] |> List.to_seq - |> Seq.map (fun v -> v, Env.External v) + |> Seq.map (fun v -> v, External v) let g = let g = Env.init_global () in @@ -46,12 +47,12 @@ let rep env : unit = | Nop -> () | _ -> Env.set env "ans" v; - printf "%s\n" @@ Env.Value.to_string v + printf "%s\n" @@ Value.to_string v exception Reset_line (* used to indicate ^C is pressed *) let init_repl () = - Env.set g "ans" (Env.Int 0); + Env.set g "ans" (Int 0); (* treat Ctrl-C as to reset line *) let reset_line _ = raise Reset_line in Sys.(set_signal sigint (Signal_handle reset_line))