76 lines
1.9 KiB
OCaml
76 lines
1.9 KiB
OCaml
open Ast
|
|
open Ast.Value
|
|
|
|
exception No_operation
|
|
exception No_such_variable of string
|
|
|
|
let resolve_type op tp =
|
|
let optypes = Binop.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 Binop.get op (t1, t2) with
|
|
| None -> begin
|
|
try binop op (promote l) (promote r)
|
|
with _ -> raise No_operation
|
|
end
|
|
| Some f -> f l r
|
|
|
|
let eval vars ast =
|
|
let rec aux = function
|
|
| Value v -> v
|
|
| Var v -> begin match Hashtbl.find_opt vars v with
|
|
| None -> raise @@ No_such_variable v
|
|
| Some v -> v
|
|
end
|
|
| Unary (op, t) ->
|
|
let t = aux t in
|
|
let op = Unary.get op (Value.typeof t) 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
|
|
Hashtbl.replace vars var v;
|
|
v
|
|
| 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
|