civicaml/phases/bool_op.ml

(**
 * The phase applies the transformations shown below. These transformations are
 * required because the CiviC VM does not offer instructions that perform these
 * operations. Another reason is that conjunction and disjunction require
 * short-circuit evaluation. In the examples below, `b1` and `b2` are
 * expressions of type boolean, `i` is of type int and `f` is of type float.
 *
 * > b1 == b2   ==>   (int)b1 == (int)b2
 * > b1 != b2   ==>   (int)b1 != (int)b2
 * > b1 && b2   ==>   b1 ? b2 : false
 * > b1 || b2   ==>   b1 ? true : b2
 * > b1 + b2    ==>   (bool)((int)b1 + (int)b2)
 * > b1 * b2    ==>   (bool)((int)b1 * (int)b2)
 * > (bool)i    ==>   i != 0
 * > (bool)f    ==>   f != 0.0
 * > (int)b1    ==>   b1 ? 1 : 0
 * > (float)b1  ==>   b1 ? 1.0 : 0.0
 *)
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
    | ((Eq | Ne) as op, left, right, loc) ->
        Binop (op, cast Int (bool_op left), cast Int (bool_op right), loc)

    | (And, left, right, loc) ->
        Cond (bool_op left, bool_op right, boolconst false, loc)

    | (Or, left, right, loc) ->
        Cond (bool_op left, boolconst true, bool_op right, loc)

    | ((Add | Mul) as op, left, right, loc) ->
        cast Bool (Binop (op, cast Int (bool_op left), cast Int (bool_op right), loc))

    | (op, left, right, loc) ->
        Binop (op, bool_op left, bool_op right, loc)

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

    | TypeCast (Bool, value, loc) when typeof value = Int ->
        Binop (Ne, value, intconst 0, loc)

    | TypeCast (Bool, value, loc) when typeof value = Float ->
        Binop (Ne, value, floatconst 0.0, loc)

    | TypeCast (Int, value, loc) when typeof value = Bool ->
        Cond (value, intconst 1, intconst 0, loc)

    | TypeCast (Float, value, loc) when typeof value = Bool ->
        Cond (value, floatconst 1.0, floatconst 0.0, loc)

    | node -> transform_children bool_op node

let rec phase input =
    log_line 1 "- Convert bool operations";
    match input with
    | Ast node -> Ast (bool_op node)
    | _ -> raise (InvalidInput "bool operations")