civicaml/phases/boolop.ml

open Types
open Util

let cast ctype node = TypeCast (ctype, node, [Type ctype])

let boolconst  value = Const (BoolVal  value, [Type Bool])
let intconst   value = Const (IntVal   value, [Type Int])
let floatconst value = Const (FloatVal value, [Type Float])

let rec trav_binop = function
  (* b1 == b2   ==>   (int)b1 == (int)b2
   * b1 != b2   ==>   (int)b1 != (int)b2 *)
  | ((Eq | Ne) as op, left, right, ann) ->
    bool_op (Binop (op, cast Int left, cast Int right, ann))

  (* b1 && b2   ==>   b1 ? b2 : false *)
  | (And, left, right, ann) ->
    bool_op (Cond (left, right, boolconst false, ann))

  (* b1 || b2   ==>   b1 ? true : b2 *)
  | (Or, left, right, ann) ->
    bool_op (Cond (left, boolconst true, right, ann))

  | (op, left, right, ann) ->
    Binop (op, left, right, ann)

and bool_op = function
  | Binop (op, left, right, ann) when typeof left = Bool && typeof right = Bool ->
    trav_binop (op, bool_op left, bool_op right, ann)

  (* (bool)i    ==>   i != 0 *)
  | TypeCast (Bool, value, ann) when typeof value = Int ->
    Binop (Ne, bool_op value, intconst 0l, ann)

  (* (bool)f    ==>   f != 0.0 *)
  | TypeCast (Bool, value, ann) when typeof value = Float ->
    Binop (Ne, bool_op value, floatconst 0.0, ann)

  (* (int)b1    ==>   b1 ? 1 : 0 *)
  | TypeCast (Int, value, ann) when typeof value = Bool ->
    Cond (bool_op value, intconst 1l, intconst 0l, ann)

  (* (float)b1  ==>   b1 ? 1.0 : 0.0 *)
  | TypeCast (Float, value, ann) when typeof value = Bool ->
    Cond (bool_op value, floatconst 1.0, floatconst 0.0, ann)

  | TypeCast (ctype, value, ann) when typeof value = ctype ->
    bool_op value

  | node -> traverse_unit bool_op node

let phase = function
  | Ast node -> Ast (bool_op node)
  | _ -> raise InvalidInput