Move Value module into Env
This commit is contained in:
parent
995d95df41
commit
05797676ce
4 changed files with 110 additions and 110 deletions
102
ast.ml
102
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,49 +42,7 @@ 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
|
||||
let op_to_string = function
|
||||
| Add -> "+"
|
||||
| Sub -> "-"
|
||||
| Mul -> "*"
|
||||
|
|
@ -92,51 +51,6 @@ module Operator = struct
|
|||
| 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 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"
|
||||
|
|
|
|||
40
env.ml
40
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;
|
||||
|
|
|
|||
56
eval.ml
56
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
|
||||
|
|
|
|||
8
main.ml
8
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))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue