124 lines
3.2 KiB
OCaml
124 lines
3.2 KiB
OCaml
open Ast
|
|
open Ast.Value
|
|
|
|
exception No_operation
|
|
exception No_such_variable of string
|
|
exception No_such_function of string
|
|
|
|
exception Too_many_arguments
|
|
|
|
let assert_same_length vars args =
|
|
let vl = List.length vars
|
|
and al = List.length args in
|
|
if vl > al then
|
|
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
|
|
let q = Queue.create () in
|
|
let rec aux (t1, t2) =
|
|
if List.mem (t1, t2) optypes then
|
|
t1, t2
|
|
else begin
|
|
[ Type.supertype t1 |> Option.map (fun t1 -> t1, t2);
|
|
Type.supertype t2 |> Option.map (fun t2 -> t1, t2); ]
|
|
|> List.filter_map Fun.id
|
|
|> List.iter (Fun.flip Queue.push q);
|
|
aux @@ Queue.pop q
|
|
end
|
|
in
|
|
aux tp
|
|
|
|
let rec binop op l r =
|
|
let t1 = typeof l and t2 = typeof r in
|
|
let t1, t2 = resolve_type op (t1, t2) in
|
|
let rec promote_until t x =
|
|
if typeof x = t
|
|
then x
|
|
else promote_until t (promote x)
|
|
in
|
|
let l = promote_until t1 l
|
|
and r = promote_until t2 r in
|
|
match Operator.get_binary op (t1, t2) with
|
|
| None -> begin
|
|
try binop op (promote l) (promote r)
|
|
with _ -> raise No_operation
|
|
end
|
|
| Some f -> f l r
|
|
|
|
let deg r =
|
|
r *. 180. /. Float.pi
|
|
|
|
let rad 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 aux = function
|
|
| Nint n -> Int n
|
|
| Nfloat n -> Float n
|
|
| Nstring s -> String s
|
|
| Nfunction (args, e) -> Function (args, e)
|
|
| Nexternal f -> External f
|
|
| Var v -> begin match Env.get_opt env v with
|
|
| None -> raise @@ No_such_variable v
|
|
| Some v -> v
|
|
end
|
|
| Unary (op, t) ->
|
|
let t = aux t in
|
|
let op = Operator.get_unary op in
|
|
op t
|
|
| Binop (l, op, r) ->
|
|
let l = aux l and r = aux r in
|
|
binop op l r
|
|
| Let (var, e) ->
|
|
let v = aux e in
|
|
Env.set env var v; v
|
|
| Apply (v, args) ->
|
|
begin match aux v with
|
|
| Function (vars, e) ->
|
|
assert_same_length vars args;
|
|
let args = List.map aux args in
|
|
let nenv = Env.make env in
|
|
List.combine vars args
|
|
|> List.iter (fun (v, a) -> Env.set nenv v a);
|
|
eval nenv e
|
|
| External f ->
|
|
let args = List.map aux args in
|
|
ex_apply f args
|
|
| v -> raise @@ Invalid_type (typeof v)
|
|
end
|
|
| Set_binop_pre (op, l) ->
|
|
let l =
|
|
match aux l with
|
|
| Int n -> n
|
|
| v -> raise @@ Invalid_type (typeof v)
|
|
in
|
|
Hashtbl.replace Parser.precedence op l;
|
|
Nop
|
|
| Get_binop_pre op ->
|
|
Int (Hashtbl.find Parser.precedence op)
|
|
| Set_binop_aso (op, a) ->
|
|
Hashtbl.replace Parser.oper_assoc op @@ Parser.assoc_of_string a;
|
|
Nop
|
|
| Get_binop_aso op ->
|
|
match Hashtbl.find_opt Parser.oper_assoc op with
|
|
| None -> String "left"
|
|
| Some a -> String (Parser.assoc_to_string a)
|
|
in
|
|
aux ast
|