add the raw representation of constants to the parsetree

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

10 files changed, 155 insertions, 99 deletions

diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index e6ecbb7264..a8e99c9cb0 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -28,6 +28,15 @@ let with_default_loc l f =
   try let r = f () in default_loc := old; r
   with exn -> default_loc := old; raise exn
 
+let string_of_constant = function
+  | Const_int x -> string_of_int x
+  | Const_char x -> Char.escaped x
+  | Const_string (x, _) -> String.escaped x
+  | Const_float x -> x
+  | Const_int32 x -> Int32.to_string x
+  | Const_int64 x -> Int64.to_string x
+  | Const_nativeint x -> Nativeint.to_string x
+
 module Typ = struct
   let mk ?(loc = !default_loc) ?(attrs = []) d = {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs}
   let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]}
@@ -58,8 +67,10 @@ module Pat = struct
   let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any
   let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a)
   let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
-  let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
-  let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
+  let raw_constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
+  let raw_interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
+  let constant ?loc ?attrs a = raw_constant ?loc ?attrs (a, string_of_constant a)
+  let interval ?loc ?attrs a b = raw_interval ?loc ?attrs (a, string_of_constant a) (b, string_of_constant b)
   let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
   let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
   let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
@@ -78,7 +89,8 @@ module Exp = struct
   let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]}
 
   let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
-  let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
+  let raw_constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
+  let constant ?loc ?attrs a = raw_constant ?loc ?attrs (a, string_of_constant a)
   let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
   let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
   let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
@@ -391,7 +403,7 @@ module Convenience = struct
   let tconstr c l = Typ.constr (lid c) l
 
   let get_str = function
-    | {pexp_desc=Pexp_constant (Const_string (s, _)); _} -> Some s
+    | {pexp_desc=Pexp_constant (Const_string (s, _), _); _} -> Some s
     | e -> None
 
   let get_lid = function
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index a6c6ac0055..dfe1942a4c 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -63,6 +63,8 @@ module Pat:
     val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern
     val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern
     val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern
+    val raw_constant: ?loc:loc -> ?attrs:attrs -> raw_constant -> pattern
+    val raw_interval: ?loc:loc -> ?attrs:attrs -> raw_constant -> raw_constant -> pattern
     val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern
     val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern
     val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern
@@ -84,6 +86,7 @@ module Exp:
 
     val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
     val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
+    val raw_constant: ?loc:loc -> ?attrs:attrs -> raw_constant -> expression
     val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> (pattern * expression) list -> expression -> expression
     val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> expression -> expression
     val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
@@ -305,6 +308,9 @@ module Cstr:
 
 (** {2 Convenience functions} *)
 
+val string_of_constant: constant -> string
+    (** Return the canonical literal representation of a constant. *)
+
 (** Convenience functions to help build and deconstruct AST fragments. *)
 module Convenience :
   sig
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 4621f1dd12..a910fe2a0e 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -12,7 +12,6 @@
 
 (* A generic Parsetree mapping class *)
 
-open Location
 open Config
 open Parsetree
 open Asttypes
@@ -187,17 +186,13 @@ end
 module E = struct
   (* Value expressions for the core language *)
 
-  let lid ?(loc = Location.none) ?attrs lid = Exp.ident ~loc ?attrs (mkloc (Longident.parse lid) loc)
-  let apply_nolabs ?loc ?attrs f el = Exp.apply ?loc ?attrs f (List.map (fun e -> ("", e)) el)
-  let strconst ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_string (x, None))
-
   let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
     let open Exp in
     let loc = sub # location loc in
     let attrs = sub # attributes attrs in
     match desc with
     | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
-    | Pexp_constant x -> constant ~loc ~attrs x
+    | Pexp_constant x -> raw_constant ~loc ~attrs x
     | Pexp_let (r, pel, e) -> let_ ~loc ~attrs r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
     | Pexp_fun (lab, def, p, e) -> fun_ ~loc ~attrs lab (map_opt (sub # expr) def) (sub # pat p) (sub # expr e)
     | Pexp_function pel -> function_ ~loc ~attrs (sub # cases pel)
@@ -243,8 +238,8 @@ module P = struct
     | Ppat_any -> any ~loc ~attrs ()
     | Ppat_var s -> var ~loc ~attrs (map_loc sub s)
     | Ppat_alias (p, s) -> alias ~loc ~attrs (sub # pat p) (map_loc sub s)
-    | Ppat_constant c -> constant ~loc ~attrs c
-    | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
+    | Ppat_constant c -> raw_constant ~loc ~attrs c
+    | Ppat_interval (c1, c2) -> raw_interval ~loc ~attrs c1 c2
     | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub # pat) pl)
     | Ppat_construct (l, p) -> construct ~loc ~attrs (map_loc sub l) (map_opt (sub # pat) p)
     | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub # pat) p)
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index b212a2b9a7..29ce250df0 100644
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -21,6 +21,8 @@ type constant =
   | Const_int64 of int64
   | Const_nativeint of nativeint
 
+type raw_constant = constant * string
+
 type rec_flag = Nonrecursive | Recursive
 
 type direction_flag = Upto | Downto
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index db5b8a5021..a841d25c31 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -124,6 +124,36 @@ let get_stored_string () =
   string_buff := initial_string_buffer;
   s
 
+let initial_raw_string_buffer = String.create 256
+let raw_string_buff = ref initial_raw_string_buffer
+let raw_string_index = ref 0
+
+let reset_raw_string_buffer () =
+  raw_string_buff := initial_raw_string_buffer;
+  raw_string_index := 0
+
+let store_raw_string_char c =
+  if !raw_string_index >= String.length (!raw_string_buff) then begin
+    let new_buff = String.create (String.length (!raw_string_buff) * 2) in
+    String.blit (!raw_string_buff) 0 new_buff 0 (String.length (!raw_string_buff));
+    raw_string_buff := new_buff
+  end;
+  String.unsafe_set (!raw_string_buff) (!raw_string_index) c;
+  incr raw_string_index
+
+let store_raw_string s =
+  for i = 0 to String.length s - 1 do
+    store_raw_string_char s.[i];
+  done
+
+let store_raw_lexeme lexbuf =
+  store_raw_string (Lexing.lexeme lexbuf)
+
+let get_stored_raw_string () =
+  let s = String.sub (!raw_string_buff) 0 (!raw_string_index) in
+  raw_string_buff := initial_raw_string_buffer;
+  s
+
 (* To store the position of the beginning of a string and comment *)
 let string_start_loc = ref Location.none;;
 let comment_start_loc = ref [];;
@@ -170,11 +200,11 @@ let char_for_hexadecimal_code lexbuf i =
 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)))
+  Int32.neg (Int32.of_string ("-" ^ s))
 let cvt_int64_literal s =
-  Int64.neg (Int64.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
+  Int64.neg (Int64.of_string ("-" ^ s))
 let cvt_nativeint_literal s =
-  Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
+  Nativeint.neg (Nativeint.of_string ("-" ^ s))
 
 (* Remove underscores from float literals *)
 
@@ -282,38 +312,39 @@ rule token = parse
             LIDENT s }
   | uppercase identchar *
       { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
-  | int_literal
+  | int_literal as lit
       { try
-          INT (cvt_int_literal (Lexing.lexeme lexbuf))
+          INT (cvt_int_literal lit, lit)
         with Failure _ ->
           raise (Error(Literal_overflow "int", Location.curr lexbuf))
       }
-  | float_literal
-      { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) }
-  | int_literal "l"
+  | float_literal as lit
+      { FLOAT (remove_underscores lit, lit) }
+  | int_literal as lit "l"
       { try
-          INT32 (cvt_int32_literal (Lexing.lexeme lexbuf))
+          INT32 (cvt_int32_literal lit, lit)
         with Failure _ ->
           raise (Error(Literal_overflow "int32", Location.curr lexbuf)) }
-  | int_literal "L"
+  | int_literal as lit "L"
       { try
-          INT64 (cvt_int64_literal (Lexing.lexeme lexbuf))
+          INT64 (cvt_int64_literal lit, lit)
         with Failure _ ->
           raise (Error(Literal_overflow "int64", Location.curr lexbuf)) }
-  | int_literal "n"
+  | int_literal as lit "n"
       { try
-          NATIVEINT (cvt_nativeint_literal (Lexing.lexeme lexbuf))
+          NATIVEINT (cvt_nativeint_literal lit, lit)
         with Failure _ ->
           raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) }
   | "\""
       { reset_string_buffer();
+        reset_raw_string_buffer();
         is_in_string := true;
         let string_start = lexbuf.lex_start_p in
         string_start_loc := Location.curr lexbuf;
-        string lexbuf;
+        string true lexbuf;
         is_in_string := false;
         lexbuf.lex_start_p <- string_start;
-        STRING (get_stored_string(), None) }
+        STRING (get_stored_string(), get_stored_raw_string(), None) }
   | "{" lowercase* "|"
       { reset_string_buffer();
         let delim = Lexing.lexeme lexbuf in
@@ -324,18 +355,19 @@ rule token = parse
         quoted_string delim lexbuf;
         is_in_string := false;
         lexbuf.lex_start_p <- string_start;
-        STRING (get_stored_string(), Some delim) }
-  | "'" newline "'"
+        let s = get_stored_string() in
+        STRING (s, s, Some delim) }
+  | "'" (newline as lit) "'"
       { update_loc lexbuf None 1 false 1;
-        CHAR (Lexing.lexeme_char lexbuf 1) }
-  | "'" [^ '\\' '\'' '\010' '\013'] "'"
-      { CHAR(Lexing.lexeme_char lexbuf 1) }
-  | "'\\" ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] "'"
-      { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) }
-  | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
-      { CHAR(char_for_decimal_code lexbuf 2) }
-  | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
-      { CHAR(char_for_hexadecimal_code lexbuf 3) }
+        CHAR(lit.[0], lit) }
+  | "'" ([^ '\\' '\'' '\010' '\013'] as lit) "'"
+      { CHAR(lit, String.make 1 lit) }
+  | "'" ("\\" ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] as lit) "'"
+      { CHAR(char_for_backslash lit.[1], lit) }
+  | "'" ("\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] as lit) "'"
+      { CHAR(char_for_decimal_code lexbuf 2, lit) }
+  | "'" ("\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] as lit) "'"
+      { CHAR(char_for_hexadecimal_code lexbuf 3, lit) }
   | "'\\" _
       { let l = Lexing.lexeme lexbuf in
         let esc = String.sub l 1 (String.length l - 1) in
@@ -461,7 +493,7 @@ and comment = parse
         string_start_loc := Location.curr lexbuf;
         store_string_char '"';
         is_in_string := true;
-        begin try string lexbuf
+        begin try string false lexbuf
         with Error (Unterminated_string, _) ->
           match !comment_start_loc with
           | [] -> assert false
@@ -526,25 +558,29 @@ and comment = parse
   | _
       { store_lexeme lexbuf; comment lexbuf }
 
-and string = parse
+and string save_raw  = parse
     '"'
       { () }
   | '\\' newline ([' ' '\t'] * as space)
       { update_loc lexbuf None 1 false (String.length space);
-        string lexbuf
+        if save_raw then store_raw_lexeme lexbuf;
+        string save_raw lexbuf
       }
   | '\\' ['\\' '\'' '"' 'n' 't' 'b' 'r' ' ']
       { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
-        string lexbuf }
+        if save_raw then store_raw_lexeme lexbuf;
+        string save_raw lexbuf }
   | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
       { store_string_char(char_for_decimal_code lexbuf 1);
-         string lexbuf }
+        if save_raw then store_raw_lexeme lexbuf;
+        string save_raw lexbuf }
   | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
       { store_string_char(char_for_hexadecimal_code lexbuf 2);
-         string lexbuf }
+        if save_raw then store_raw_lexeme lexbuf;
+        string save_raw lexbuf }
   | '\\' _
       { if in_comment ()
-        then string lexbuf
+        then string save_raw lexbuf
         else begin
 (*  Should be an error, but we are very lax.
           raise (Error (Illegal_escape (Lexing.lexeme lexbuf),
@@ -554,22 +590,26 @@ and string = parse
           Location.prerr_warning loc Warnings.Illegal_backslash;
           store_string_char (Lexing.lexeme_char lexbuf 0);
           store_string_char (Lexing.lexeme_char lexbuf 1);
-          string lexbuf
+          string save_raw lexbuf
         end
       }
   | newline
       { if not (in_comment ()) then
           Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string;
         update_loc lexbuf None 1 false 0;
-        store_lexeme lexbuf;
-        string lexbuf
+        let s = Lexing.lexeme lexbuf in
+        store_string s;
+        if save_raw then store_raw_string s;
+        string save_raw lexbuf
       }
   | eof
       { is_in_string := false;
         raise (Error (Unterminated_string, !string_start_loc)) }
   | _
-      { store_string_char(Lexing.lexeme_char lexbuf 0);
-        string lexbuf }
+      { let c = Lexing.lexeme_char lexbuf 0 in
+        store_string_char c;
+        if save_raw then store_raw_string_char c;
+        string save_raw lexbuf }
 
 and quoted_string delim = parse
   | newline
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 33651d6507..11a152ea2e 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -81,27 +81,27 @@ let neg_float_string 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(Const_int n, lit) ->
+      mkexp(Pexp_constant(Const_int(-n), "-"^lit))
+  | "-", Pexp_constant(Const_int32 n, lit) ->
+      mkexp(Pexp_constant(Const_int32(Int32.neg n), "-"^lit))
+  | "-", Pexp_constant(Const_int64 n, lit) ->
+      mkexp(Pexp_constant(Const_int64(Int64.neg n), "-"^lit))
+  | "-", Pexp_constant(Const_nativeint n, lit) ->
+      mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n), "-"^lit))
+  | ("-" | "-."), Pexp_constant(Const_float f, lit) ->
+      mkexp(Pexp_constant(Const_float(neg_float_string f), "-"^lit))
   | _ ->
       mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", 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(Const_int _, _)
+  | "+", Pexp_constant(Const_int32 _, _)
+  | "+", Pexp_constant(Const_int64 _, _)
+  | "+", Pexp_constant(Const_nativeint _, _)
+  | ("+" | "+."), Pexp_constant(Const_float _, _) -> mkexp desc
   | _ ->
       mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
 
@@ -296,7 +296,7 @@ let mkexp_attrs d attrs =
 %token BARBAR
 %token BARRBRACKET
 %token BEGIN
-%token <char> CHAR
+%token <char * string> CHAR
 %token CLASS
 %token COLON
 %token COLONCOLON
@@ -316,7 +316,7 @@ let mkexp_attrs d attrs =
 %token EXCEPTION
 %token EXTERNAL
 %token FALSE
-%token <string> FLOAT
+%token <string * string> FLOAT
 %token FOR
 %token FUN
 %token FUNCTION
@@ -334,9 +334,9 @@ let mkexp_attrs d attrs =
 %token <string> INFIXOP4
 %token INHERIT
 %token INITIALIZER
-%token <int> INT
-%token <int32> INT32
-%token <int64> INT64
+%token <int * string> INT
+%token <int32 * string> INT32
+%token <int64 * string> INT64
 %token <string> LABEL
 %token LAZY
 %token LBRACE
@@ -361,7 +361,7 @@ let mkexp_attrs d attrs =
 %token MINUSGREATER
 %token MODULE
 %token MUTABLE
-%token <nativeint> NATIVEINT
+%token <nativeint * string> NATIVEINT
 %token NEW
 %token OBJECT
 %token OF
@@ -385,7 +385,7 @@ let mkexp_attrs d attrs =
 %token SHARP
 %token SIG
 %token STAR
-%token <string * string option> STRING
+%token <string * string * string option> STRING
 %token STRUCT
 %token THEN
 %token TILDE
@@ -1418,8 +1418,8 @@ lbl_pattern:
 /* Primitive declarations */
 
 primitive_declaration:
-    STRING                                      { [fst $1] }
-  | STRING primitive_declaration                { fst $1 :: $2 }
+    STRING                                      { let s, _, _ = $1 in [s] }
+  | STRING primitive_declaration                { let s, _, _ = $1 in s :: $2 }
 ;
 
 /* Type declarations */
@@ -1737,26 +1737,26 @@ 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 x, l = $1 in (Const_int x, l) }
+  | CHAR                                        { let x, l = $1 in (Const_char x, l) }
+  | STRING                                      { let (s, l, d) = $1 in (Const_string (s, d), l) }
+  | FLOAT                                       { let x, l = $1 in (Const_float x, l) }
+  | INT32                                       { let x, l = $1 in (Const_int32 x, l) }
+  | INT64                                       { let x, l = $1 in (Const_int64 x, l) }
+  | NATIVEINT                                   { let x, l = $1 in (Const_nativeint x, l) }
 ;
 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 x, l = $2 in (Const_int(- x), l) }
+  | MINUS FLOAT                                 { let x, l = $2 in (Const_float("-" ^ x), l) }
+  | MINUS INT32                                 { let x, l = $2 in (Const_int32(Int32.neg x), l) }
+  | MINUS INT64                                 { let x, l = $2 in (Const_int64(Int64.neg x), l) }
+  | MINUS NATIVEINT                             { let x, l = $2 in (Const_nativeint(Nativeint.neg x), l) }
+  | PLUS INT                                    { let x, l = $2 in (Const_int x, l) }
+  | PLUS FLOAT                                  { let x, l = $2 in (Const_float x, l) }
+  | PLUS INT32                                  { let x, l = $2 in (Const_int32 x, l) }
+  | PLUS INT64                                  { let x, l = $2 in (Const_int64 x, l) }
+  | PLUS NATIVEINT                              { let x, l = $2 in (Const_nativeint x, l) }
 ;
 
 /* Identifiers and long identifiers */
@@ -1849,8 +1849,8 @@ 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 STRING          { Ptop_dir($2, Pdir_string (let s, _, _ = $3 in s)) }
+  | SHARP ident INT             { Ptop_dir($2, Pdir_int (fst $3)) }
   | SHARP ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
   | SHARP ident FALSE           { Ptop_dir($2, Pdir_bool false) }
   | SHARP ident TRUE            { Ptop_dir($2, Pdir_bool true) }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 2dc932fa50..68161fcb71 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -130,9 +130,9 @@ and pattern_desc =
         (* x *)
   | Ppat_alias of pattern * string loc
         (* P as 'a *)
-  | Ppat_constant of constant
+  | Ppat_constant of raw_constant
         (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
-  | Ppat_interval of constant * constant
+  | Ppat_interval of raw_constant * raw_constant
         (* 'a'..'z'
 
            Other forms of interval are recognized by the parser
@@ -183,7 +183,7 @@ and expression_desc =
         (* x
            M.x
          *)
-  | Pexp_constant of constant
+  | Pexp_constant of raw_constant
         (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
   | Pexp_let of rec_flag * (pattern * expression) list * expression
         (* let P1 = E1 and ... and Pn = EN in E       (flag = Nonrecursive)
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 36c6599ca1..3a53684b9b 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -167,7 +167,8 @@ class printer  ()= object(self:'self)
     | Lapply (y,s)->
         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
+  method constant f (c, _) =
+    match c with
     | 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
diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
index 1d70abf460..b916e41276 100644
--- 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 -> Asttypes.raw_constant -> unit
     method constant_string : Format.formatter -> string -> unit
     method core_type : Format.formatter -> Parsetree.core_type -> unit
     method core_type1 : Format.formatter -> Parsetree.core_type -> unit
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 7d964700cb..daa6e9fd7d 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -49,7 +49,7 @@ let fmt_string_loc f x =
   fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
 ;;
 
-let fmt_constant f x =
+let fmt_constant f (x, _) =
   match x with
   | Const_int (i) -> fprintf f "Const_int %d" i;
   | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c);