bool_op now traverses properly and typecasts are pruned when not int->float or float->int

phases/assemble.ml

@@ -159,7 +159,11 @@ let assemble program =
             let vtype = typeof value in
             (match (ctype, vtype) with
             | (Float, Int) | (Int, Float) -> ()
-            | _ -> raise (NodeError (node, "invalid typecast"))
+            | _ ->
+                let msg = sprintf
+                    "invalid typecast: %s -> %s"
+                    (type2str vtype) (type2str ctype)
+                in raise (NodeError (node, msg))
             );
             trav value @ [Convert (vtype, ctype)]
 

phases/bool_op.ml

@@ -26,36 +26,39 @@ 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)
+    | ((Eq | Ne) as op, left, right, ann) ->
+        bool_op (Binop (op, cast Int left, cast Int right, ann))
 
-    | (And, left, right, loc) ->
-        Cond (bool_op left, bool_op right, boolconst false, loc)
+    | (And, left, right, ann) ->
+        bool_op (Cond (left, right, boolconst false, ann))
 
-    | (Or, left, right, loc) ->
-        Cond (bool_op left, boolconst true, bool_op right, loc)
+    | (Or, left, right, ann) ->
+        bool_op (Cond (left, boolconst true, right, ann))
 
-    | ((Add | Mul) as op, left, right, loc) ->
-        cast Bool (Binop (op, cast Int (bool_op left), cast Int (bool_op right), loc))
+    | ((Add | Mul) as op, left, right, ann) ->
+        bool_op (cast Bool (Binop (op, cast Int left, cast Int right, ann)))
 
-    | (op, left, right, loc) ->
-        Binop (op, bool_op left, bool_op right, loc)
+    | (op, left, right, ann) ->
+        Binop (op, left, right, ann)
 
 and bool_op = function
-    | Binop (op, left, right, loc) when typeof left = Bool && typeof right = Bool ->
-        trav_binop (op, left, right, loc)
+    | Binop (op, left, right, ann) when typeof left = Bool && typeof right = Bool ->
+        trav_binop (op, bool_op left, bool_op right, ann)
 
-    | TypeCast (Bool, value, loc) when typeof value = Int ->
-        Binop (Ne, value, intconst 0, loc)
+    | TypeCast (Bool, value, ann) when typeof value = Int ->
+        Binop (Ne, bool_op value, intconst 0, ann)
 
-    | TypeCast (Bool, value, loc) when typeof value = Float ->
-        Binop (Ne, value, floatconst 0.0, loc)
+    | TypeCast (Bool, value, ann) when typeof value = Float ->
+        Binop (Ne, bool_op value, floatconst 0.0, ann)
 
-    | TypeCast (Int, value, loc) when typeof value = Bool ->
-        Cond (value, intconst 1, intconst 0, loc)
+    | TypeCast (Int, value, ann) when typeof value = Bool ->
+        Cond (bool_op value, intconst 1, intconst 0, ann)
 
-    | TypeCast (Float, value, loc) when typeof value = Bool ->
-        Cond (value, floatconst 1.0, floatconst 0.0, loc)
+    | 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 -> transform_children bool_op node
 

phases/typecheck.ml

@@ -116,7 +116,7 @@ let rec typecheck node =
     | TypeCast (ctype, value, ann) ->
         let value = typecheck value in
         check_type_op [Bool; Int; Float] "typecast" value;
-        TypeCast (ctype, value, Type (typeof value) :: ann)
+        TypeCast (ctype, value, Type (ctype) :: ann)
 
     (* Array allocation dimensions must have type int *)
     | Allocate (dec, dims, ann) ->