Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
master
Jérémie Dimino 2013-05-20 11:37:41 +00:00
parent cf273fb995
commit 4e7ae971a7
17 changed files with 204 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -487,19 +487,19 @@ module Make (Ast : Sig.Camlp4Ast) = struct
;
value rec deep_mkrangepat loc c1 c2 =
if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1))
if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1, Char.escaped c1))
else
mkghpat loc
(Ppat_or (mkghpat loc (Ppat_constant (Const_char c1)))
(Ppat_or (mkghpat loc (Ppat_constant (Const_char c1, Char.escaped c1)))
(deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
;
value rec mkrangepat loc c1 c2 =
if c1 > c2 then mkrangepat loc c2 c1
else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1))
else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1, Char.escaped c1))
else
mkpat loc
(Ppat_or (mkghpat loc (Ppat_constant (Const_char c1)))
(Ppat_or (mkghpat loc (Ppat_constant (Const_char c1, Char.escaped c1)))
(deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2))
;
@ -545,24 +545,24 @@ module Make (Ast : Sig.Camlp4Ast) = struct
"this is not a constructor, it cannot be applied in a pattern" ]
| PaArr loc p -> mkpat loc (Ppat_array (List.map patt (list_of_patt p [])))
| PaChr loc s ->
mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s)))
mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s), s))
| PaInt loc s ->
let i = try int_of_string s with [
Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int"
] in mkpat loc (Ppat_constant (Const_int i))
] in mkpat loc (Ppat_constant (Const_int i, s))
| PaInt32 loc s ->
let i32 = try Int32.of_string s with [
Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32"
] in mkpat loc (Ppat_constant (Const_int32 i32))
] in mkpat loc (Ppat_constant (Const_int32 i32, s))
| PaInt64 loc s ->
let i64 = try Int64.of_string s with [
Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64"
] in mkpat loc (Ppat_constant (Const_int64 i64))
] in mkpat loc (Ppat_constant (Const_int64 i64, s))
| PaNativeInt loc s ->
let nati = try Nativeint.of_string s with [
Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint"
] in mkpat loc (Ppat_constant (Const_nativeint nati))
| PaFlo loc s -> mkpat loc (Ppat_constant (Const_float (remove_underscores s)))
] in mkpat loc (Ppat_constant (Const_nativeint nati, s))
| PaFlo loc s -> mkpat loc (Ppat_constant (Const_float (remove_underscores s), s))
| PaLab loc _ _ -> error loc "labeled pattern not allowed here"
| PaOlb loc _ _ | PaOlbi loc _ _ _ -> error loc "labeled pattern not allowed here"
| PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2))
@ -580,7 +580,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
let is_closed = if wildcards = [] then Closed else Open in
mkpat loc (Ppat_record (List.map mklabpat ps, is_closed))
| PaStr loc s ->
mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s) None))
mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s) None, s))
| <:patt@loc< ($p1$, $p2$) >> ->
mkpat loc (Ppat_tuple
(List.map patt (list_of_patt p1 (list_of_patt p2 []))))
@ -763,14 +763,14 @@ value varify_constructors var_names =
mkexp loc e
| ExAsr loc e -> mkexp loc (Pexp_assert (expr e))
| ExChr loc s ->
mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s)))
mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s), s))
| ExCoe loc e t1 t2 ->
let t1 =
match t1 with
[ <:ctyp<>> -> None
| t -> Some (ctyp t) ] in
mkexp loc (Pexp_coerce (expr e) t1 (ctyp t2))
| ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s)))
| ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s), s))
| ExFor loc i e1 e2 df el ->
let e3 = ExSeq loc el in
mkexp loc (Pexp_for (with_loc i loc) (expr e1) (expr e2) (mkdirection df) (expr e3))
@ -788,19 +788,19 @@ value varify_constructors var_names =
| ExInt loc s ->
let i = try int_of_string s with [
Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int"
] in mkexp loc (Pexp_constant (Const_int i))
] in mkexp loc (Pexp_constant (Const_int i, s))
| ExInt32 loc s ->
let i32 = try Int32.of_string s with [
Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32"
] in mkexp loc (Pexp_constant (Const_int32 i32))
] in mkexp loc (Pexp_constant (Const_int32 i32, s))
| ExInt64 loc s ->
let i64 = try Int64.of_string s with [
Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64"
] in mkexp loc (Pexp_constant (Const_int64 i64))
] in mkexp loc (Pexp_constant (Const_int64 i64, s))
| ExNativeInt loc s ->
let nati = try Nativeint.of_string s with [
Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint"
] in mkexp loc (Pexp_constant (Const_nativeint nati))
] in mkexp loc (Pexp_constant (Const_nativeint nati, s))
| ExLab loc _ _ -> error loc "labeled expression not allowed here"
| ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))
| ExLet loc rf bi e ->
@ -843,7 +843,7 @@ value varify_constructors var_names =
(Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get")))
[("", expr e1); ("", expr e2)])
| ExStr loc s ->
mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s) None))
mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s) None, s))
| ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a []))
| <:expr@loc< ($e1$, $e2$) >> ->
mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 []))))

36
camlp4/boot/Camlp4.ml
View File

@ -14664,10 +14664,10 @@ module Struct =
let rec deep_mkrangepat loc c1 c2 =
if c1 = c2
then mkghpat loc (Ppat_constant (Const_char c1))
then mkghpat loc (Ppat_constant (Const_char c1, Char.escaped c1))
else
mkghpat loc
(Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1))),
(Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1, Char.escaped c1))),
(deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) c2)))
let rec mkrangepat loc c1 c2 =
@ -14675,10 +14675,10 @@ module Struct =
then mkrangepat loc c2 c1
else
if c1 = c2
then mkpat loc (Ppat_constant (Const_char c1))
then mkpat loc (Ppat_constant (Const_char c1, Char.escaped c1))
else
mkpat loc
(Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1))),
(Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1, Char.escaped c1))),
(deep_mkrangepat loc (Char.chr ((Char.code c1) + 1))
c2)))
@ -14732,7 +14732,7 @@ module Struct =
mkpat loc (Ppat_array (List.map patt (list_of_patt p [])))
| PaChr (loc, s) ->
mkpat loc
(Ppat_constant (Const_char (char_of_char_token loc s)))
(Ppat_constant (Const_char (char_of_char_token loc s), s))
| PaInt (loc, s) ->
let i =
(try int_of_string s
@ -14740,7 +14740,7 @@ module Struct =
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int")
in mkpat loc (Ppat_constant (Const_int i))
in mkpat loc (Ppat_constant (Const_int i, s))
| PaInt32 (loc, s) ->
let i32 =
(try Int32.of_string s
@ -14748,7 +14748,7 @@ module Struct =
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int32")
in mkpat loc (Ppat_constant (Const_int32 i32))
in mkpat loc (Ppat_constant (Const_int32 i32, s))
| PaInt64 (loc, s) ->
let i64 =
(try Int64.of_string s
@ -14756,7 +14756,7 @@ module Struct =
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int64")
in mkpat loc (Ppat_constant (Const_int64 i64))
in mkpat loc (Ppat_constant (Const_int64 i64, s))
| PaNativeInt (loc, s) ->
let nati =
(try Nativeint.of_string s
@ -14764,10 +14764,10 @@ module Struct =
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type nativeint")
in mkpat loc (Ppat_constant (Const_nativeint nati))
in mkpat loc (Ppat_constant (Const_nativeint nati, s))
| PaFlo (loc, s) ->
mkpat loc
(Ppat_constant (Const_float (remove_underscores s)))
(Ppat_constant (Const_float (remove_underscores s), s))
| PaLab (loc, _, _) ->
error loc "labeled pattern not allowed here"
| PaOlb (loc, _, _) | PaOlbi (loc, _, _, _) ->
@ -14794,7 +14794,7 @@ module Struct =
| PaStr (loc, s) ->
mkpat loc
(Ppat_constant
(Const_string (string_of_string_token loc s, None)))
(Const_string (string_of_string_token loc s, None), s))
| Ast.PaTup (loc, (Ast.PaCom (_, p1, p2))) ->
mkpat loc
(Ppat_tuple
@ -14995,7 +14995,7 @@ module Struct =
| ExAsr (loc, e) -> mkexp loc (Pexp_assert (expr e))
| ExChr (loc, s) ->
mkexp loc
(Pexp_constant (Const_char (char_of_char_token loc s)))
(Pexp_constant (Const_char (char_of_char_token loc s), s))
| ExCoe (loc, e, t1, t2) ->
let t1 =
(match t1 with | Ast.TyNil _ -> None | t -> Some (ctyp t))
@ -15004,7 +15004,7 @@ module Struct =
(Pexp_coerce ((expr e), t1, ctyp t2))
| ExFlo (loc, s) ->
mkexp loc
(Pexp_constant (Const_float (remove_underscores s)))
(Pexp_constant (Const_float (remove_underscores s), s))
| ExFor (loc, i, e1, e2, df, el) ->
let e3 = ExSeq (loc, el)
in
@ -15036,7 +15036,7 @@ module Struct =
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int")
in mkexp loc (Pexp_constant (Const_int i))
in mkexp loc (Pexp_constant (Const_int i, s))
| ExInt32 (loc, s) ->
let i32 =
(try Int32.of_string s
@ -15044,7 +15044,7 @@ module Struct =
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int32")
in mkexp loc (Pexp_constant (Const_int32 i32))
in mkexp loc (Pexp_constant (Const_int32 i32, s))
| ExInt64 (loc, s) ->
let i64 =
(try Int64.of_string s
@ -15052,7 +15052,7 @@ module Struct =
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int64")
in mkexp loc (Pexp_constant (Const_int64 i64))
in mkexp loc (Pexp_constant (Const_int64 i64, s))
| ExNativeInt (loc, s) ->
let nati =
(try Nativeint.of_string s
@ -15060,7 +15060,7 @@ module Struct =
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type nativeint")
in mkexp loc (Pexp_constant (Const_nativeint nati))
in mkexp loc (Pexp_constant (Const_nativeint nati, s))
| ExLab (loc, _, _) ->
error loc "labeled expression not allowed here"
| ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e))
@ -15113,7 +15113,7 @@ module Struct =
| ExStr (loc, s) ->
mkexp loc
(Pexp_constant
(Const_string (string_of_string_token loc s, None)))
(Const_string (string_of_string_token loc s, None), s))
| ExTry (loc, e, a) ->
mkexp loc (Pexp_try ((expr e), (match_case a [])))
| Ast.ExTup (loc, (Ast.ExCom (_, e1, e2))) ->

2
experimental/frisch/copy_typedef.ml
View File

@ -133,7 +133,7 @@ module Main : sig end = struct
file, path, name
| [{pstr_desc=Pstr_eval
({pexp_desc=Pexp_apply
({pexp_desc=Pexp_constant(Const_string (file, _)); _},
({pexp_desc=Pexp_constant(Const_string (file, _), _); _},
["", {pexp_desc=Pexp_ident{txt=lid;_}; _}]); _}, _); _}] ->
begin match List.rev (Longident.flatten lid) with
| [] -> assert false

2
experimental/frisch/metaquot.ml
View File

@ -120,7 +120,7 @@ module Main : sig end = struct
Format.fprintf ppf "@[%a@]@." report exn
let extract_str parse kind = function
| {pexp_desc = Pexp_constant (Const_string (s, _)); pexp_loc = loc; _} ->
| {pexp_desc = Pexp_constant (Const_string (s, _), _); pexp_loc = loc; _} ->
begin try parse (Lexing.from_string s)
with exn ->
Location.print_error Format.std_formatter loc;

4
experimental/frisch/minidoc.ml
View File

@ -8,10 +8,10 @@ let pendings = ref []
let doc ppf = function
| ({txt="doc";_}, [{pstr_desc=Pstr_eval(e, _); _}]) ->
begin match e.pexp_desc with
| Pexp_constant(Const_string (s, _)) ->
| Pexp_constant(Const_string (s, _), _) ->
Format.fprintf ppf " --> %s@." s
| Pexp_apply({pexp_desc=Pexp_ident{txt=Lident "section"}},
["", {pexp_desc=Pexp_constant(Const_string (s, _))}]) ->
["", {pexp_desc=Pexp_constant(Const_string (s, _), _)}]) ->
Format.fprintf ppf " ==== %s ====@." s
| _ -> ()
end

20
parsing/ast_helper.ml
View File

@ -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

6
parsing/ast_helper.mli
View File

@ -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

11
parsing/ast_mapper.ml
View File

@ -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)

2
parsing/asttypes.mli
View File

@ -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

116
parsing/lexer.mll
View File

@ -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

86
parsing/parser.mly
View File

@ -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) }

6
parsing/parsetree.mli
View File

@ -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)

3
parsing/pprintast.ml
View File

@ -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

2
parsing/pprintast.mli
View File

@ -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

2
parsing/printast.ml
View File

@ -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);

4
tools/untypeast.ml
View File

@ -165,7 +165,7 @@ and untype_pattern pat =
end
| Tpat_alias (pat, _id, name) ->
Ppat_alias (untype_pattern pat, name)
| Tpat_constant cst -> Ppat_constant cst
| Tpat_constant cst -> Ppat_constant (cst, string_of_constant cst)
| Tpat_tuple list ->
Ppat_tuple (List.map untype_pattern list)
| Tpat_construct (lid, _, args) ->
@ -217,7 +217,7 @@ and untype_expression exp =
let desc =
match exp.exp_desc with
Texp_ident (_path, lid, _) -> Pexp_ident (lid)
| Texp_constant cst -> Pexp_constant cst
| Texp_constant cst -> Pexp_constant (cst, string_of_constant cst)
| Texp_let (rec_flag, list, exp) ->
Pexp_let (rec_flag,
List.map (fun (pat, exp) ->

13
typing/typecore.ml
View File

@ -233,7 +233,8 @@ let all_idents_cases el =
(* Typing of constants *)
let type_constant = function
let type_constant (c, _) =
match c with
Const_int _ -> instance_def Predef.type_int
| Const_char _ -> instance_def Predef.type_char
| Const_string _ -> instance_def Predef.type_string
@ -927,12 +928,12 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
| Ppat_constant cst ->
unify_pat_types loc !env (type_constant cst) expected_ty;
rp {
pat_desc = Tpat_constant cst;
pat_desc = Tpat_constant (fst cst);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_interval (Const_char c1, Const_char c2) ->
| Ppat_interval ((Const_char c1, _), (Const_char c2, _)) ->
let open Ast_helper.Pat in
let rec loop c1 c2 =
if c1 = c2 then constant ~loc (Const_char c1)
@ -1893,9 +1894,9 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_constant(Const_string (s, _) as cst) ->
| Pexp_constant(Const_string (s, _), _ as cst) ->
rue {
exp_desc = Texp_constant cst;
exp_desc = Texp_constant (fst cst);
exp_loc = loc; exp_extra = [];
exp_type =
(* Terrible hack for format strings *)
@ -1908,7 +1909,7 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_env = env }
| Pexp_constant cst ->
rue {
exp_desc = Texp_constant cst;
exp_desc = Texp_constant (fst cst);
exp_loc = loc; exp_extra = [];
exp_type = type_constant cst;
exp_attributes = sexp.pexp_attributes;