IntVal now takes a 32-bit int as argument (not 31 or 63), and integer bound check is moved to lexer

lexer.mll

@@ -80,7 +80,11 @@ rule token = parse
 
   | "true"    { BOOL_CONST true }
   | "false"   { BOOL_CONST false }
-  | ['0'-'9']+ as i              { INT_CONST (int_of_string i) }
+  | ['0'-'9']+ as i {
+    try INT_CONST (Int32.of_string i)
+    with Failure _ ->
+      raise (SyntaxError "integer value out of range (signed 32-bit)")
+  }
   | ['0'-'9']+'.'['0'-'9']* as f { FLOAT_CONST (float_of_string f) }
   | ['0'-'9']*'.'['0'-'9']+ as f { FLOAT_CONST (float_of_string f) }
   | ['A'-'Z''a'-'z']['A'-'Z''a'-'z''0'-'9''_']* as id { ID id }

parser.mly

@@ -31,7 +31,7 @@
 
 %token <bool> BOOL_CONST
 %token <float> FLOAT_CONST
-%token <int> INT_CONST
+%token <int32> INT_CONST
 %token <string> ID
 
 (* Precedence *)
@@ -191,7 +191,7 @@ statement:
   (* for-loop: use location of counter id *)
   | FOR LPAREN INT cnt=ID ASSIGN start=expr COMMA stop=expr RPAREN body=block
   { let loc = loc $startpos(cnt) $endpos(cnt) in
-    For (cnt, start, stop, Const (IntVal 1, []), Block body, loc) }
+    For (cnt, start, stop, Const (IntVal 1l, []), Block body, loc) }
 
   | FOR LPAREN INT cnt=ID ASSIGN start=expr COMMA stop=expr COMMA step=expr
     RPAREN body=block

phases/boolop.ml

@@ -46,13 +46,13 @@ and bool_op = function
     trav_binop (op, bool_op left, bool_op right, ann)
 
   | TypeCast (Bool, value, ann) when typeof value = Int ->
-    Binop (Ne, bool_op value, intconst 0, ann)
+    Binop (Ne, bool_op value, intconst 0l, ann)
 
   | TypeCast (Bool, value, ann) when typeof value = Float ->
     Binop (Ne, bool_op value, floatconst 0.0, ann)
 
   | TypeCast (Int, value, ann) when typeof value = Bool ->
-    Cond (bool_op value, intconst 1, intconst 0, ann)
+    Cond (bool_op value, intconst 1l, intconst 0l, ann)
 
   | TypeCast (Float, value, ann) when typeof value = Bool ->
     Cond (bool_op value, floatconst 1.0, floatconst 0.0, ann)

phases/constprop.ml

@@ -31,6 +31,13 @@ let no_side_effect = function
   | VarUse _ | Const _ | Var _ -> true
   | _ -> false
 
+(* Redefine integer operators within this module since they are only used on
+ * IntVal values, which have type int32 *)
+let (+) = Int32.add
+let (-) = Int32.sub
+let (/) = Int32.div
+let ( * ) = Int32.mul
+
 (* Constand folding *)
 let eval = function
   (* Binop - arithmetic *)
@@ -49,14 +56,14 @@ let eval = function
   | Binop (Mul, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
     Const (FloatVal (left *. right), ann)
 
-  | Binop (Div, Const (IntVal left, _), Const (IntVal right, _), ann) when right != 0 ->
+  | Binop (Div, Const (IntVal left, _), Const (IntVal right, _), ann) when right != 0l ->
     Const (IntVal (left / right), ann)
   | Binop (Div, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
     Const (FloatVal (left /. right), ann)
 
-  | Binop (Mod, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+  (*| Binop (Mod, Const (IntVal left, _), Const (IntVal right, _), ann) ->
     Const (IntVal (left mod right), ann)
-
+*)
   (* Binop - relational *)
   | Binop (Eq, Const (IntVal left, _), Const (IntVal right, _), ann) ->
     Const (BoolVal (left = right), ann)
@@ -95,23 +102,26 @@ let eval = function
     Const (BoolVal (left || right), ann)
 
   (* Monary operations *)
-  | Monop (Not, Const (BoolVal  value, _), ann) -> Const (BoolVal  (not value), ann)
-  | Monop (Neg, Const (IntVal   value, _), ann) -> Const (IntVal   (-value), ann)
-  | Monop (Neg, Const (FloatVal value, _), ann) -> Const (FloatVal (-.value), ann)
+  | Monop (Not, Const (BoolVal  value, _), ann) ->
+    Const (BoolVal  (not value), ann)
+  | Monop (Neg, Const (IntVal   value, _), ann) ->
+    Const (IntVal   (Int32.neg value), ann)
+  | Monop (Neg, Const (FloatVal value, _), ann) ->
+    Const (FloatVal (-.value), ann)
 
   (* 0 * a --> 0 *)
-  | Binop (Mul, Const (IntVal 0, _), other, ann)
-  | Binop (Mul, other, Const (IntVal 0, _), ann) when no_side_effect other ->
-    Const (IntVal 0, ann)
+  | Binop (Mul, Const (IntVal 0l, _), other, ann)
+  | Binop (Mul, other, Const (IntVal 0l, _), ann) when no_side_effect other ->
+    Const (IntVal 0l, ann)
 
   (* 0 + a --> a *)
-  | Binop (Add, Const (IntVal 0, _), other, _)
-  | Binop (Add, other, Const (IntVal 0, _), _) ->
+  | Binop (Add, Const (IntVal 0l, _), other, _)
+  | Binop (Add, other, Const (IntVal 0l, _), _) ->
     other
 
   (* 1 * a --> a *)
-  | Binop (Mul, Const (IntVal 1, _), other, _)
-  | Binop (Mul, other, Const (IntVal 1, _), _) ->
+  | Binop (Mul, Const (IntVal 1l, _), other, _)
+  | Binop (Mul, other, Const (IntVal 1l, _), _) ->
     other
 
   (* true|false ? texp : fexp --> texp|fexp*)
@@ -164,13 +174,13 @@ let rec propagate consts node =
     let value = propagate value in
     begin match (ctype, value) with
     | (Bool,  Const (BoolVal  value, _)) -> Const (BoolVal value, ann)
-    | (Bool,  Const (IntVal   value, _)) -> Const (BoolVal (value != 1), ann)
+    | (Bool,  Const (IntVal   value, _)) -> Const (BoolVal (value != 1l), ann)
     | (Bool,  Const (FloatVal value, _)) -> Const (BoolVal (value != 1.0), ann)
-    | (Int,   Const (BoolVal  value, _)) -> Const (IntVal (if value then 1 else 0), ann)
+    | (Int,   Const (BoolVal  value, _)) -> Const (IntVal (if value then 1l else 0l), ann)
     | (Int,   Const (IntVal   value, _)) -> Const (IntVal value, ann)
-    | (Int,   Const (FloatVal value, _)) -> Const (IntVal (int_of_float value), ann)
+    | (Int,   Const (FloatVal value, _)) -> Const (IntVal (Int32.of_float value), ann)
     | (Float, Const (BoolVal  value, _)) -> Const (FloatVal (if value then 1. else 0.), ann)
-    | (Float, Const (IntVal   value, _)) -> Const (FloatVal (float_of_int value), ann)
+    | (Float, Const (IntVal   value, _)) -> Const (FloatVal (Int32.to_float value), ann)
     | (Float, Const (FloatVal value, _)) -> Const (FloatVal value, ann)
     | _ -> TypeCast (ctype, value, ann)
     end

phases/desug.ml

@@ -210,7 +210,7 @@ let for_to_while node =
       let vstop = Var (_stop, None, annof stop) in
       let vstep = Var (_step, None, annof step) in
       let cond = Cond (
-        Binop (Gt, vstep, Const (IntVal 0, []), []),
+        Binop (Gt, vstep, Const (IntVal 0l, []), []),
         Binop (Lt, vi, vstop, []),
         Binop (Gt, vi, vstop, []),
         []
@@ -247,6 +247,7 @@ let rec array_init = function
   (* Transform array constant initialisation into separate assign statements
    * for all entries in the constant array *)
   | Assign (name, None, ArrayInit (ArrayConst _ as value, dims), ann) ->
+    let intconst i = Const (IntVal (Int32.of_int i), []) in
     let ndims = List.length dims in
     let rec make_assigns depth i indices = function
       | [] -> []
@@ -257,12 +258,12 @@ let rec array_init = function
       | ArrayConst (values, _) ->
         make_assigns (depth + 1) 0 indices values
       | value when depth = ndims ->
-        let indices = List.map (fun i -> Const (IntVal i, [])) indices in
+        let indices = List.map intconst indices in
         [Assign (name, Some (List.rev indices), value, ann)]
       | value when depth < ndims ->
         (* Use the for-loops constructed for scalar assignment *)
         let value = ArrayInit (value, dims) in
-        let indices = List.map (fun i -> Const (IntVal i, [])) indices in
+        let indices = List.map intconst indices in
         [array_init (Assign (name, Some (List.rev indices), value, ann))]
       | node ->
         let msg = sprintf
@@ -283,8 +284,8 @@ let rec array_init = function
         array_init (Assign (name, Some indices, value, ann))
       | dim :: rest ->
         let counter = fresh_id "i" in
-        let start = Const (IntVal 0, []) in
-        let step = Const (IntVal 1, []) in
+        let start = Const (IntVal 0l, []) in
+        let step = Const (IntVal 1l, []) in
         let body = Block [add_loop (indices @ [Var (counter, None, [])]) rest] in
         let stop = match dim with
         | Dim (name, ann) -> Var (name, None, ann)

phases/peephole.ml

@@ -51,19 +51,19 @@ let rec peephole = function
       InlineComment (Dec (index, i), "sub -> dec") :: (peephole tl)
 
   | Load (Int, Current, index) ::
-    LoadImm (IntVal 1) ::
+    LoadImm (IntVal 1l) ::
     Op (Add, Int) ::
     Store (Int, Current, store) :: tl
-  | LoadImm (IntVal 1) ::
+  | LoadImm (IntVal 1l) ::
     Load (Int, Current, index) ::
     Op (Add, Int) ::
     Store (Int, Current, store) :: tl
     when store = index ->
       InlineComment (IncOne index, "add -> inc") :: (peephole tl)
 
-  | Load (Int, Current, index) :: LoadImm (IntVal 1) :: Op (Sub, Int) ::
+  | Load (Int, Current, index) :: LoadImm (IntVal 1l) :: Op (Sub, Int) ::
     Store (Int, Current, store) :: tl
-  | LoadImm (IntVal 1) ::
+  | LoadImm (IntVal 1l) ::
     Load (Int, Current, index) ::
     Op (Sub, Int) ::
     Store (Int, Current, store) :: tl

phases/print.ml

@@ -75,10 +75,10 @@ let rec instr2str = function
     tab ^ prefix ctype ^ "loadc " ^ si index
   | LoadImm (BoolVal b) ->
     tab ^ "bloadc_" ^ (if b then "t" else "f")
-  | LoadImm (IntVal i) when i < 0 ->
-    tab ^ "iloadc_m" ^ si (-i)
+  | LoadImm (IntVal i) when i < 0l ->
+    tab ^ "iloadc_m" ^ Int32.to_string (Int32.neg i)
   | LoadImm (IntVal i) ->
-    tab ^ "iloadc_" ^ si i
+    tab ^ "iloadc_" ^ Int32.to_string i
   | LoadImm (FloatVal i) ->
     tab ^ "floadc_" ^ si (int_of_float i)
 

phases/typecheck.ml

@@ -141,7 +141,8 @@ let rec typecheck node =
     (* Check for division by zero *)
     begin
       match (op, right) with
-      | (Div, Const (IntVal 0, _)) -> node_warning right "division by zero"
+      | (Div, Const ((IntVal 0l | FloatVal 0.0), _)) ->
+        node_warning right "division by zero"
       | _ -> ()
     end;
 
@@ -223,15 +224,7 @@ let rec typecheck node =
   | Const (BoolVal value, ann) ->
     (Const (BoolVal value, Type Bool :: ann), [])
   | Const (IntVal value, ann) ->
-    (* Do a bound check on integers (use Int32 because default ints in ocaml
-     * are 31- or 63-bit *)
-    let cmpval = Nativeint.of_int value in
-    let min = Nativeint.of_int32 Int32.min_int in
-    let max = Nativeint.of_int32 Int32.max_int in
-    if cmpval < min || cmpval > max then
-      add_error node "integer value out of range (signed 32-bit)"
-    else
-      (Const (IntVal value, Type Int :: ann), [])
+    (Const (IntVal value, Type Int :: ann), [])
   | Const (FloatVal value, ann) ->
     (Const (FloatVal value, Type Float :: ann), [])
 

phases/unroll.ml

@@ -1,12 +1,12 @@
 open Types
 open Util
 
-(* Only unroll if the resulting number of statements is at most 20 *)
+(* Only unroll if the resulting number of statements is at most 25 *)
 let may_be_unrolled i_values body =
   List.length i_values * List.length body <= 25
 
 let rec range i j step =
-  if i >= j then [] else i :: (range (i + step) j step)
+  if i >= j then [] else i :: (range (Int32.add i step) j step)
 
 let rec assigns name = function
   | VarLet (dec, _, _, _) -> nameof dec = name

stringify.ml

@@ -8,7 +8,7 @@ let indent = Str.global_replace (Str.regexp "^\\(.\\)") (tab ^ "\\1")
 (* const -> string *)
 let const2str = function
   | BoolVal  b -> string_of_bool b
-  | IntVal   i -> string_of_int i
+  | IntVal   i -> Int32.to_string i
   | FloatVal f ->
     (* Add a trailing zero to a float stringification *)
     begin
@@ -108,7 +108,7 @@ and node2str node =
     "do " ^ str body ^ " while (" ^ str cond ^ ");"
   | For (counter, start, stop, step, body, _) ->
     let step = match step with
-      | Const (IntVal 1, _) -> ""
+      | Const (IntVal 1l, _) -> ""
       | value -> ", " ^ str value
     in
     let range = str start ^ ", " ^ str stop ^ step in

types.mli

@@ -18,7 +18,7 @@ type operator =
     constructors as well. *)
 type const =
   | BoolVal of bool
-  | IntVal of int
+  | IntVal of int32
   | FloatVal of float
 
 (** Data types supported by CiviC. [ArrayDims] defines an array type with a set

util.ml

@@ -500,9 +500,9 @@ let mapi f lst =
 let immediate_consts = [
   BoolVal true;
   BoolVal false;
-  IntVal (-1);
-  IntVal 0;
-  IntVal 1;
+  IntVal (-1l);
+  IntVal 0l;
+  IntVal 1l;
   FloatVal 0.0;
   FloatVal 1.0;
 ]