ce/ast.ml

(* simple, untyped AST. *)
type t =
  | Nint of int
  | Nfloat of float
  | Nbool of bool
  | Nstring of string
  | Nsymbol of string
  | Nfunction of string list * t
  | Nexternal of string
  | Var of string
  | Let of string * t
  | Letin of string * t * t
  | Unary of operator * t
  | Binop of t * operator * t
  | If of t * t * t (* cond then else *)
  | 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
  | Get_binop_aso of operator

and operator =
  | Add | Sub | Mul | Div (* arithmetics *)
  | Mod (* modular operation *)
  | Exp (* exponentation *)
  | Eq | Neq | GE | LE | GT | LT
  | Negate

let op_to_string = function
  | Add -> "+"
  | Sub -> "-"
  | Mul -> "*"
  | Div -> "/"
  | Mod -> "%"
  | Exp -> "^"
  | Eq -> "="
  | Neq -> "<>"
  | GE -> ">="
  | LE -> "<="
  | GT -> ">"
  | LT -> "<"
  | Negate -> "-"

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 rec aux = function
    | Nint n -> pr "%d" n
    | Nfloat n -> pr "%f" n
    | Nbool b -> pr "%b" b
    | Nstring s -> pr "\"%s\"" s
    | Nsymbol s -> pr "#%s" s
    | Nfunction (args, e) ->
      pr "(lambda (%s" @@ List.hd args;
      List.iter (pr " %s") @@ List.tl args;
      pr ") "; aux e; pr ")"
    | Nexternal e -> pr "(extern %s)" e

    | Var v -> pr "%s" v
    | Let (v, e) ->
      pr "(define %s " v; aux e; pr ")"
    | Letin (v, e, f) ->
      pr "(let ((%s " v; aux e; pr "))"; aux f; pr ")"
    | Unary (op, t) ->
      let op = op_to_string op in
      pr "(%s " op; aux t; pr ")"
    | Binop (left, op, right) ->
      let op = op_to_string op in
      pr "(%s " op; aux left; pr " "; aux right; pr ")"
    | If (co, th, el) ->
      let f e = pr " "; aux e in
      pr "(if"; f co; f th; f el; pr ")"
    | Apply (f, args) ->
      pr "("; aux f; List.iter (fun a -> pr " "; aux a) args; pr ")"

    | Set_binop_pre (op, pre) ->
      pr "(set_pre %s " (op_to_string op);
      aux pre;
      pr ")"
    | Get_binop_pre op ->
      pr "(get_pre %s)" (op_to_string op)
    | Set_binop_aso (op, aso) ->
      pr "(set_assoc %s %s)" (op_to_string op) aso
    | Get_binop_aso op ->
      pr "(get_pre %s)" (op_to_string op)
  in
  aux ast; pr "\n"