Merge Eval and Env
This commit is contained in:
parent
700356022b
commit
36fd3de4e7
3 changed files with 130 additions and 123 deletions
94
env.ml
94
env.ml
|
|
@ -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
|
||||
150
eval.ml
150
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
|
||||
|
|
|
|||
9
main.ml
9
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))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue