PR#4210, PR#4245: tightened bound checking in string->integer conversion functions, without changing what the lexer accepts

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@9317 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

3 files changed, 43 insertions, 19 deletions

diff --git a/Changes b/Changes
index 11e90c7bc2..303405f8e5 100644
--- a/Changes
+++ b/Changes
@@ -1,11 +1,21 @@
 Objective Caml 3.12.0:
 ----------------------
 
+(Changes that can break existing programs are marked with a "*"  )
+
+Compilers and toplevel:
+- Added option '-no-app-funct' to turn applicative functors off.
+  This option can help working around mysterious type incompatibilities
+  caused by the incomplete comparison of applicative paths F(X).t.
+
 Standard library:
-* To prevent confusion when mixing Format printing functions and direct low
+- PR#4210, #4245: stricter range checking in string->integer conversion
+  functions (int_of_string, Int32.of_string, Int64.of_string,
+  Nativeint.of_string).  The decimal string corresponding to
+  max_int + 1 is no longer accepted.
+- To prevent confusion when mixing Format printing functions and direct low
   level output, values Format.stdout and Format.stderr have been added.
-
-* To prevent confusion when mixing Scanf scanning functions and direct low
+- To prevent confusion when mixing Scanf scanning functions and direct low
   level input, value Scanf.stdin has been added.
 
 Bug Fixes:
diff --git a/byterun/ints.c b/byterun/ints.c
index 5fc15c6264..7b8a136751 100644
--- a/byterun/ints.c
+++ b/byterun/ints.c
@@ -83,9 +83,12 @@ static intnat parse_intnat(value s, int nbits)
     caml_failwith("int_of_string");
   }
   if (base == 10) {
-    /* Signed representation expected, allow -2^(nbits-1) to 2^(nbits - 1) */
-    if (res > (uintnat)1 << (nbits - 1))
-      caml_failwith("int_of_string");
+    /* Signed representation expected, allow -2^(nbits-1) to 2^(nbits-1) - 1 */
+    if (sign >= 0) {
+      if (res >= (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string");
+    } else {
+      if (res >  (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string");
+    }
   } else {
     /* Unsigned representation expected, allow 0 to 2^nbits - 1
        and tolerate -(2^nbits - 1) to 0 */
@@ -540,7 +543,8 @@ CAMLprim value caml_int64_of_string(value s)
 {
   char * p;
   uint64 max_uint64 = I64_literal(0xFFFFFFFF, 0xFFFFFFFF);
-  uint64 max_int64  = I64_literal(0x80000000, 0x00000000);
+  uint64 max_int64_pos = I64_literal(0x7FFFFFFF, 0xFFFFFFFF);
+  uint64 max_int64_neg = I64_literal(0x80000000, 0x00000000);
   uint64 res, threshold;
   int sign, base, d;
 
@@ -563,7 +567,10 @@ CAMLprim value caml_int64_of_string(value s)
   if (p != String_val(s) + caml_string_length(s)){
     caml_failwith("int_of_string");
   }
-  if (base == 10 && I64_ult(max_int64, res)) caml_failwith("int_of_string");
+  if (base == 10) {
+    if (I64_ult((sign >= 0 ? max_int64_pos : max_int64_neg), res))
+      caml_failwith("int_of_string");
+  }
   if (sign < 0) res = I64_neg(res);
   return caml_copy_int64(res);
 }
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index c2e693dc40..0696aac807 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -156,6 +156,17 @@ let char_for_hexadecimal_code lexbuf i =
   in
   Char.chr (val1 * 16 + val2)
 
+(* To convert integer literals, allowing max_int + 1 (PR#4210) *)
+
+let cvt_int_literal s =
+  - int_of_string ("-" ^ s)
+let cvt_int32_literal s =
+  Int32.neg (Int32.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
+let cvt_int64_literal s =
+  Int64.neg (Int64.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
+let cvt_nativeint_literal s =
+  Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
+
 (* Remove underscores from float literals *)
 
 let remove_underscores s =
@@ -264,29 +275,25 @@ rule token = parse
       { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
   | int_literal
       { try
-          INT (int_of_string(Lexing.lexeme lexbuf))
+          INT (cvt_int_literal (Lexing.lexeme lexbuf))
         with Failure _ ->
           raise (Error(Literal_overflow "int", Location.curr lexbuf))
       }
   | float_literal
       { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) }
   | int_literal "l"
-      { let s = Lexing.lexeme lexbuf in
-        try
-          INT32 (Int32.of_string(String.sub s 0 (String.length s - 1)))
+      { try
+          INT32 (cvt_int32_literal (Lexing.lexeme lexbuf))
         with Failure _ ->
           raise (Error(Literal_overflow "int32", Location.curr lexbuf)) }
   | int_literal "L"
-      { let s = Lexing.lexeme lexbuf in
-        try
-          INT64 (Int64.of_string(String.sub s 0 (String.length s - 1)))
+      { try
+          INT64 (cvt_int64_literal (Lexing.lexeme lexbuf))
         with Failure _ ->
           raise (Error(Literal_overflow "int64", Location.curr lexbuf)) }
   | int_literal "n"
-      { let s = Lexing.lexeme lexbuf in
-        try
-          NATIVEINT
-            (Nativeint.of_string(String.sub s 0 (String.length s - 1)))
+      { try
+          NATIVEINT (cvt_nativeint_literal (Lexing.lexeme lexbuf))
         with Failure _ ->
           raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) }
   | "\""