ocaml · hhugo · Apr 19, 2015 · Jul 27, 2015 · Oct 28, 2015 · bobot
diff --git a/.depend b/.depend
diff --git a/Changes b/Changes
@@ -292,7 +292,9 @@ Features wishes:
 - PR#6742: remove duplicate virtual_flag information from Tstr_class
 - PR#6719: improve Buffer.add_channel when not enough input is available
   (Simon Cruanes)
-* PR#6816: reject integer and float literals followed by alphanum
+* PR#6816: reject integer and float literals directly followed by an identifier.
+  This was prevously read as two separate tokens.
+  [let abc = 1 in (+) 123abc] was accepted and is now rejected.
   (Hugo Heuzard)
 - PR#6876: improve warning 6 by listing the omitted labels.
   (Eyyüb Sari)
@@ -328,6 +330,12 @@ Features wishes:
   (Florian Angeletti)
 - GPR#252: improve build instructions in MSVC Windows README
   (Philip Daian)
+* GPR#170: Parse arbitrary precision integers.
+  Accept a single [A-Za-z] as modifier for integers (generalizing 'l','L','n') and floats.
+  May cause breakage (ie. ppx preprocessor) because of changes in the parsetree.
+  This changes PR#6816 a little bit by reading the literal [123a] as a single token that can
+  later be rewritten by a ppx preprocessor.
+  (Hugo Heuzard)
 
 OCaml 4.02.3 (27 Jul 2015):
 ---------------------------

diff --git a/Makefile.shared b/Makefile.shared
@@ -59,10 +59,11 @@ TYPING=typing/ident.cmo typing/path.cmo \
   typing/typedtreeIter.cmo typing/typedtreeMap.cmo \
   typing/tast_mapper.cmo \
   typing/cmt_format.cmo \
+  typing/untypeast.cmo \
   typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
   typing/stypes.cmo typing/typecore.cmo \
   typing/typedecl.cmo typing/typeclass.cmo \
-  typing/typemod.cmo typing/untypeast.cmo
+  typing/typemod.cmo
 
 COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
   bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \

diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
@@ -12,9 +12,9 @@
 
 (** Helpers to produce Parsetree fragments *)
 
-open Parsetree
 open Asttypes
 open Docstrings
+open Parsetree
 
 type lid = Longident.t loc
 type str = string loc

diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
@@ -18,7 +18,6 @@
 *)
 
 
-open Asttypes
 open Parsetree
 open Ast_helper
 open Location
@@ -626,13 +625,13 @@ let default_mapper =
 
 let rec extension_of_error {loc; msg; if_highlight; sub} =
   { loc; txt = "ocaml.error" },
-  PStr ([Str.eval (Exp.constant (Const_string (msg, None)));
-         Str.eval (Exp.constant (Const_string (if_highlight, None)))] @
+  PStr ([Str.eval (Exp.constant (PConst_string (msg, None)));
+         Str.eval (Exp.constant (PConst_string (if_highlight, None)))] @
         (List.map (fun ext -> Str.extension (extension_of_error ext)) sub))
 
 let attribute_of_warning loc s =
   { loc; txt = "ocaml.ppwarning" },
-  PStr ([Str.eval ~loc (Exp.constant (Const_string (s, None)))])
+  PStr ([Str.eval ~loc (Exp.constant (PConst_string (s, None)))])
 
 module StringMap = Map.Make(struct
     type t = string
@@ -660,7 +659,7 @@ module PpxContext = struct
 
   let lid name = { txt = Lident name; loc = Location.none }
 
-  let make_string x = Exp.constant (Const_string (x, None))
+  let make_string x = Exp.constant (PConst_string (x, None))
 
   let make_bool x =
     if x
@@ -715,7 +714,7 @@ module PpxContext = struct
   let restore fields =
     let field name payload =
       let rec get_string = function
-        | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str
+        | { pexp_desc = Pexp_constant (PConst_string (str, None)) } -> str
         | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \
                              { %s }] string syntax" name
       and get_bool pexp =

diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml
@@ -83,10 +83,9 @@ let empty_docs = { docs_pre = None; docs_post = None }
 let doc_loc = {txt = "ocaml.doc"; loc = Location.none}
 
 let docs_attr ds =
-  let open Asttypes in
   let open Parsetree in
   let exp =
-    { pexp_desc = Pexp_constant (Const_string(ds.ds_body, None));
+    { pexp_desc = Pexp_constant (PConst_string(ds.ds_body, None));
       pexp_loc = ds.ds_loc;
       pexp_attributes = []; }
   in
@@ -133,10 +132,9 @@ let empty_text = []
 let text_loc = {txt = "ocaml.text"; loc = Location.none}
 
 let text_attr ds =
-  let open Asttypes in
   let open Parsetree in
   let exp =
-    { pexp_desc = Pexp_constant (Const_string(ds.ds_body, None));
+    { pexp_desc = Pexp_constant (PConst_string(ds.ds_body, None));
       pexp_loc = ds.ds_loc;
       pexp_attributes = []; }
   in

diff --git a/parsing/lexer.mli b/parsing/lexer.mli
@@ -23,7 +23,6 @@ type error =
   | Unterminated_string
   | Unterminated_string_in_comment of Location.t * Location.t
   | Keyword_as_label of string
-  | Literal_overflow of string
   | Invalid_literal of string
 ;;
 

diff --git a/parsing/lexer.mll b/parsing/lexer.mll
@@ -24,7 +24,6 @@ type error =
   | Unterminated_string
   | Unterminated_string_in_comment of Location.t * Location.t
   | Keyword_as_label of string
-  | Literal_overflow of string
   | Invalid_literal of string
 ;;
 
@@ -177,18 +176,6 @@ 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 =
@@ -271,9 +258,6 @@ let report_error ppf = function
               Location.print_error loc
   | Keyword_as_label kwd ->
       fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
-  | Literal_overflow ty ->
-      fprintf ppf "Integer literal exceeds the range of representable \
-                   integers of type %s" ty
   | Invalid_literal s ->
       fprintf ppf "Invalid literal %s" s
 
@@ -313,6 +297,7 @@ let float_literal =
   ['0'-'9'] ['0'-'9' '_']*
   ('.' ['0'-'9' '_']* )?
   (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
+let literal_modifier = ['A'-'Z' 'a'-'z']
 
 rule token = parse
   | "\\" newline {
@@ -350,29 +335,13 @@ rule token = parse
       { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
   | uppercase_latin1 identchar_latin1 *
       { warn_latin1 lexbuf; UIDENT(Lexing.lexeme lexbuf) }
-  | int_literal
-      { try
-          INT (cvt_int_literal (Lexing.lexeme lexbuf))
-        with Failure _ ->
-          raise (Error(Literal_overflow "int", Location.curr lexbuf))
-      }
+  | int_literal { INT (Lexing.lexeme lexbuf, None) }
+  | (int_literal as lit) (literal_modifier as modif)
+      { INT (lit, Some modif) }
   | float_literal
-      { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) }
-  | int_literal "l"
-      { try
-          INT32 (cvt_int32_literal (Lexing.lexeme lexbuf))
-        with Failure _ ->
-          raise (Error(Literal_overflow "int32", Location.curr lexbuf)) }
-  | int_literal "L"
-      { try
-          INT64 (cvt_int64_literal (Lexing.lexeme lexbuf))
-        with Failure _ ->
-          raise (Error(Literal_overflow "int64", Location.curr lexbuf)) }
-  | int_literal "n"
-      { try
-          NATIVEINT (cvt_nativeint_literal (Lexing.lexeme lexbuf))
-        with Failure _ ->
-          raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) }
+      { FLOAT (remove_underscores(Lexing.lexeme lexbuf), None) }
+  | (float_literal as lit) (literal_modifier as modif)
+      { FLOAT (remove_underscores lit, Some modif) }
   | (float_literal | int_literal) identchar+
       { raise (Error(Invalid_literal (Lexing.lexeme lexbuf),
                      Location.curr lexbuf)) }

diff --git a/parsing/parser.mly b/parsing/parser.mly
@@ -72,34 +72,25 @@ let ghstr d = Str.mk ~loc:(symbol_gloc()) d
 let mkinfix arg1 name arg2 =
   mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2]))
 
-let neg_float_string f =
+let neg_string f =
   if String.length f > 0 && f.[0] = '-'
   then String.sub f 1 (String.length f - 1)
   else "-" ^ f
 
 let mkuminus name arg =
   match name, arg.pexp_desc with
-  | "-", Pexp_constant(Const_int n) ->
-      mkexp(Pexp_constant(Const_int(-n)))
-  | "-", Pexp_constant(Const_int32 n) ->
-      mkexp(Pexp_constant(Const_int32(Int32.neg n)))
-  | "-", Pexp_constant(Const_int64 n) ->
-      mkexp(Pexp_constant(Const_int64(Int64.neg n)))
-  | "-", Pexp_constant(Const_nativeint n) ->
-      mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n)))
-  | ("-" | "-."), Pexp_constant(Const_float f) ->
-      mkexp(Pexp_constant(Const_float(neg_float_string f)))
+  | "-", Pexp_constant(PConst_int (n,m)) ->
+      mkexp(Pexp_constant(PConst_int(neg_string n,m)))
+  | ("-" | "-."), Pexp_constant(PConst_float (f, m)) ->
+      mkexp(Pexp_constant(PConst_float(neg_string f, m)))
   | _ ->
       mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
 
 let mkuplus name arg =
   let desc = arg.pexp_desc in
   match name, desc with
-  | "+", Pexp_constant(Const_int _)
-  | "+", Pexp_constant(Const_int32 _)
-  | "+", Pexp_constant(Const_int64 _)
-  | "+", Pexp_constant(Const_nativeint _)
-  | ("+" | "+."), Pexp_constant(Const_float _) -> mkexp desc
+  | "+", Pexp_constant(PConst_int _)
+  | ("+" | "+."), Pexp_constant(PConst_float _) -> mkexp desc
   | _ ->
       mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
 
@@ -438,7 +429,7 @@ let class_of_let_bindings lbs body =
 %token EXCEPTION
 %token EXTERNAL
 %token FALSE
-%token <string> FLOAT
+%token <string * char option> FLOAT
 %token FOR
 %token FUN
 %token FUNCTION
@@ -456,9 +447,7 @@ let class_of_let_bindings lbs body =
 %token <string> INFIXOP4
 %token INHERIT
 %token INITIALIZER
-%token <int> INT
-%token <int32> INT32
-%token <int64> INT64
+%token <string * char option> INT
 %token <string> LABEL
 %token LAZY
 %token LBRACE
@@ -484,7 +473,6 @@ let class_of_let_bindings lbs body =
 %token MINUSGREATER
 %token MODULE
 %token MUTABLE
-%token <nativeint> NATIVEINT
 %token NEW
 %token NONREC
 %token OBJECT
@@ -591,9 +579,9 @@ The precedences must be listed from low to high.
 %nonassoc below_DOT
 %nonassoc DOT
 /* Finally, the first tokens of simple_expr are above everything else. */
-%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64
+%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT
           LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
-          NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
+          NEW PREFIXOP STRING TRUE UIDENT
           LBRACKETPERCENT LBRACKETPERCENTPERCENT
 
 
@@ -2165,26 +2153,17 @@ label:
 /* Constants */
 
 constant:
-    INT                               { Const_int $1 }
-  | CHAR                              { Const_char $1 }
-  | STRING                            { let (s, d) = $1 in Const_string (s, d) }
-  | FLOAT                             { Const_float $1 }
-  | INT32                             { Const_int32 $1 }
-  | INT64                             { Const_int64 $1 }
-  | NATIVEINT                         { Const_nativeint $1 }
+  | INT                               { let (n, m) = $1 in PConst_int (n, m) }
+  | CHAR                              { PConst_char $1 }
+  | STRING                            { let (s, d) = $1 in PConst_string (s, d) }
+  | FLOAT                             { let (f, m) = $1 in PConst_float (f, m) }
 ;
 signed_constant:
     constant                               { $1 }
-  | MINUS INT                              { Const_int(- $2) }
-  | MINUS FLOAT                            { Const_float("-" ^ $2) }
-  | MINUS INT32                            { Const_int32(Int32.neg $2) }
-  | MINUS INT64                            { Const_int64(Int64.neg $2) }
-  | MINUS NATIVEINT                        { Const_nativeint(Nativeint.neg $2) }
-  | PLUS INT                               { Const_int $2 }
-  | PLUS FLOAT                             { Const_float $2 }
-  | PLUS INT32                             { Const_int32 $2 }
-  | PLUS INT64                             { Const_int64 $2 }
-  | PLUS NATIVEINT                         { Const_nativeint $2 }
+  | MINUS INT                              { let (n, m) = $2 in PConst_int("-" ^ n, m) }
+  | MINUS FLOAT                            { let (f, m) = $2 in PConst_float("-" ^ f, m) }
+  | PLUS INT                               { let (n, m) = $2 in PConst_int (n, m) }
+  | PLUS FLOAT                             { let (f, m) = $2 in PConst_float(f, m) }
 ;
 
 /* Identifiers and long identifiers */
@@ -2299,7 +2278,7 @@ class_longident:
 toplevel_directive:
     SHARP ident                 { Ptop_dir($2, Pdir_none) }
   | SHARP ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
-  | SHARP ident INT             { Ptop_dir($2, Pdir_int $3) }
+  | SHARP ident INT             { let (n, m) = $3 in Ptop_dir($2, Pdir_int (n ,m)) }
   | SHARP ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
   | SHARP ident mod_longident   { Ptop_dir($2, Pdir_ident $3) }
   | SHARP ident FALSE           { Ptop_dir($2, Pdir_bool false) }

diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
@@ -14,6 +14,12 @@
 
 open Asttypes
 
+type constant =
+    PConst_int of string * char option
+  | PConst_char of char
+  | PConst_string of string * string option
+  | PConst_float of string * char option
+
 (** {2 Extension points} *)
 
 type attribute = string loc * payload
@@ -833,6 +839,6 @@ type toplevel_phrase =
 and directive_argument =
   | Pdir_none
   | Pdir_string of string
-  | Pdir_int of int
+  | Pdir_int of string * char option
   | Pdir_ident of Longident.t
   | Pdir_bool of bool
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
@@ -168,16 +168,13 @@ class printer  ()= object(self:'self)
         pp f "%a(%a)" self#longident y self#longident s
   method longident_loc f x = pp f "%a" self#longident x.txt
   method constant f  = function
-    | Const_char i -> pp f "%C"  i
-    | Const_string (i, None) -> pp f "%S" i
-    | Const_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
-    | Const_int i -> self#paren (i<0) (fun f -> pp f "%d") f i
-    | Const_float  i -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i
-    | Const_int32 i -> self#paren (i<0l) (fun f -> pp f "%ldl") f i
-    | Const_int64 i -> self#paren (i<0L) (fun f -> pp f "%LdL") f i
-                                         (* pp f "%LdL" i *)
-    | Const_nativeint i -> self#paren (i<0n) (fun f -> pp f "%ndn") f i
-                                             (* pp f "%ndn" i *)
+    | PConst_char i -> pp f "%C"  i
+    | PConst_string (i, None) -> pp f "%S" i
+    | PConst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
+    | PConst_int (i,None) -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i
+    | PConst_int (i,Some m) -> self#paren (i.[0]='-') (fun f (i,m) -> pp f "%s%c" i m) f (i,m)
+    | PConst_float (i,None) -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i
+    | PConst_float (i, Some m) -> self#paren (i.[0]='-') (fun f (i,m) -> pp f "%s%c" i m) f (i,m)
 
   (* trailing space*)
   method mutable_flag f   = function
@@ -1372,7 +1369,8 @@ class printer  ()= object(self:'self)
     (match x with
     | Pdir_none -> ()
     | Pdir_string (s) -> pp f "@ %S" s
-    | Pdir_int (i) -> pp f "@ %d" i
+    | Pdir_int (n,None) -> pp f "@ %s" n
+    | Pdir_int (n,Some m) -> pp f "@ %s%c" n m
     | Pdir_ident (li) -> pp f "@ %a" self#longident li
     | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
 

diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
@@ -35,7 +35,7 @@ class printer :
     method class_type : Format.formatter -> Parsetree.class_type -> unit
     method class_type_declaration_list :
       Format.formatter -> Parsetree.class_type_declaration list -> unit
-    method constant : Format.formatter -> Asttypes.constant -> unit
+    method constant : Format.formatter -> Parsetree.constant -> unit
     method constant_string : Format.formatter -> string -> unit
     method constructor_declaration :
       Format.formatter -> (string * Parsetree.constructor_arguments