ce/ast.ml

157 lines
3.5 KiB
OCaml

module Type = struct
type t =
| Int
| Float
| String
let to_string = function
| Int -> "int"
| Float -> "float"
| String -> "string"
let supertype = function
| Int -> Some Float
| _ -> None
end
exception Invalid_type of Type.t
module Value = struct
type t =
| Int of int
| Float of float
| String of string
| Nop (* return of system operations *)
let to_string = function
| Int n -> string_of_int n
| Float n -> string_of_float n
| String s -> "\"" ^ s ^ "\""
| Nop -> "nop"
let typeof = function
| Int _ -> Type.Int
| Float _ -> Type.Float
| String _ -> Type.String
| 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 =
| Add | Sub | Mul | Div (* arithmetics *)
| Mod (* modular operation *)
| Exp (* exponentation *)
| Negate
exception Unavailable of t
let to_string = function
| Add -> "+"
| Sub -> "-"
| Mul -> "*"
| Div -> "/"
| Mod -> "%"
| Exp -> "^"
| Negate -> "-"
let negate = function
| Value.Int n -> Value.Int ~-n
| Float n -> Value.Float ~-.n
| _ -> failwith "Operator.negate"
let vi f a b =
let open Value in
match a, b with
| Int a, Int b -> Int (f a b)
| _ -> raise @@ Invalid_type Int
let vf f a b =
let open Value in
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
type t =
| Value of Value.t
| Var of string
| Let of string * t
| Unary of Operator.t * t
| Binop of t * Operator.t * t
| Apply of t * t list
| Set_binop_pre of Operator.t * t
| Get_binop_pre of Operator.t
| Set_binop_aso of Operator.t * string
| Get_binop_aso of Operator.t
let value v = Value v
let unary op t =
Unary (op, t)
let binop left op right =
Binop (left, op, right)
(* print ast LISP style. *)
let print ast =
let pr = Printf.printf in
let pv v = pr "%s" @@ Value.to_string v in
let rec aux = function
| Value n -> pv n
| Var v -> pr "%s" v
| Let (v, e) ->
pr "(let %s " v; aux e; pr ")"
| Unary (op, t) ->
let op = Operator.to_string op in
pr "(%s " op; aux t; pr ")"
| Binop (left, op, right) ->
let op = Operator.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);
aux pre;
pr ")"
| Get_binop_pre op ->
pr "(get_pre %s)" (Operator.to_string op)
| Set_binop_aso (op, aso) ->
pr "(set_assoc %s %s)" (Operator.to_string op) aso
| Get_binop_aso op ->
pr "(get_pre %s)" (Operator.to_string op)
in
aux ast; pr "\n"