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

Merge branch 'trunk' of ssh://github.com/ocaml/ocaml into trunk

master
alainfrisch 2015-12-04 09:01:40 +01:00
parent 66e864a53f e8625747fa
commit 54d01d0d9c
28 changed files with 336 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
.depend
View File

@ -70,9 +70,9 @@ parsing/builtin_attributes.cmx : utils/warnings.cmx parsing/parsetree.cmi \
parsing/location.cmx parsing/asttypes.cmi parsing/ast_mapper.cmx \
parsing/builtin_attributes.cmi
parsing/docstrings.cmo : utils/warnings.cmi parsing/parsetree.cmi \
parsing/location.cmi parsing/asttypes.cmi parsing/docstrings.cmi
parsing/location.cmi parsing/docstrings.cmi
parsing/docstrings.cmx : utils/warnings.cmx parsing/parsetree.cmi \
parsing/location.cmx parsing/asttypes.cmi parsing/docstrings.cmi
parsing/location.cmx parsing/docstrings.cmi
parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
parsing/location.cmi parsing/docstrings.cmi parsing/lexer.cmi
parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
@ -176,7 +176,8 @@ typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/env.cmi parsing/asttypes.cmi
typing/untypeast.cmi : typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
parsing/asttypes.cmi
typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \
typing/ident.cmi parsing/asttypes.cmi typing/btype.cmi
typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \
@ -263,18 +264,18 @@ typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \
typing/oprint.cmi
typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \
typing/oprint.cmi
typing/parmatch.cmo : utils/warnings.cmi typing/types.cmi \
typing/typedtree.cmi typing/subst.cmi typing/predef.cmi typing/path.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
typing/parmatch.cmi
typing/parmatch.cmx : utils/warnings.cmx typing/types.cmx \
typing/typedtree.cmx typing/subst.cmx typing/predef.cmx typing/path.cmx \
parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
typing/parmatch.cmi
typing/parmatch.cmo : utils/warnings.cmi typing/untypeast.cmi \
typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/predef.cmi \
typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \
parsing/ast_helper.cmi typing/parmatch.cmi
typing/parmatch.cmx : utils/warnings.cmx typing/untypeast.cmx \
typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/predef.cmx \
typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \
parsing/ast_helper.cmx typing/parmatch.cmi
typing/path.cmo : typing/ident.cmi typing/path.cmi
typing/path.cmx : typing/ident.cmx typing/path.cmi
typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
@ -1118,34 +1119,34 @@ toplevel/topdirs.cmx : utils/warnings.cmx typing/typetexp.cmx \
utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
toplevel/topdirs.cmi
toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \
typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \
typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
bytecomp/printinstr.cmi parsing/printast.cmi typing/predef.cmi \
parsing/pprintast.cmi driver/pparse.cmi typing/path.cmi \
toplevel/toploop.cmo : utils/warnings.cmi typing/typetexp.cmi \
typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \
typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \
bytecomp/simplif.cmi typing/printtyped.cmi typing/printtyp.cmi \
bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \
typing/predef.cmi parsing/pprintast.cmi driver/pparse.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \
typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \
parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \
typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \
bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
utils/config.cmi driver/compmisc.cmi utils/clflags.cmi \
bytecomp/bytegen.cmi typing/btype.cmi parsing/ast_helper.cmi \
toplevel/toploop.cmi
toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \
typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
bytecomp/translmod.cmx bytecomp/symtable.cmx bytecomp/simplif.cmx \
typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
bytecomp/printinstr.cmx parsing/printast.cmx typing/predef.cmx \
parsing/pprintast.cmx driver/pparse.cmx typing/path.cmx \
bytecomp/bytegen.cmi typing/btype.cmi parsing/asttypes.cmi \
parsing/ast_helper.cmi toplevel/toploop.cmi
toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \
typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \
typing/typecore.cmx bytecomp/translmod.cmx bytecomp/symtable.cmx \
bytecomp/simplif.cmx typing/printtyped.cmx typing/printtyp.cmx \
bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \
typing/predef.cmx parsing/pprintast.cmx driver/pparse.cmx typing/path.cmx \
parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \
typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \
parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \
typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \
bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \
utils/config.cmx driver/compmisc.cmx utils/clflags.cmx \
bytecomp/bytegen.cmx typing/btype.cmx parsing/ast_helper.cmx \
toplevel/toploop.cmi
bytecomp/bytegen.cmx typing/btype.cmx parsing/asttypes.cmi \
parsing/ast_helper.cmx toplevel/toploop.cmi
toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \
toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \
parsing/location.cmi utils/config.cmi driver/compenv.cmi \

12
Changes
View File

@ -295,6 +295,8 @@ Bug fixes:
- PR#6744: Univars can escape through polymorphic variants (partial fix)
- PR#6776: Failure to kill the "tick" thread, segfault when exiting the runtime
- PR#6752: Extensible variant types and scope escaping
- PR#6805: Duplicated expression in case of hole in a non-failing switch.
(Luc Maranget)
- PR#6808: the parsing of OCAMLRUNPARAM is too lax
(Damien Doligez)
- PR#6874: Inefficient code generated for module function arguments
@ -382,7 +384,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)
@ -416,6 +420,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):
---------------------------

4
Makefile.shared
View File

@ -59,11 +59,11 @@ TYPING=typing/ident.cmo typing/path.cmo \
typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
typing/typedtreeIter.cmo typing/typedtreeMap.cmo \
typing/tast_mapper.cmo \
typing/cmt_format.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 \

18
bytecomp/matching.ml
View File

@ -1820,7 +1820,7 @@ let share_actions_tree sw d =
let sw =
List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in
(* Retrieve all actions, includint potentiel default *)
(* Retrieve all actions, including potentiel default *)
let acts = store.Switch.act_get_shared () in
(* Array of actual actions *)
@ -2071,7 +2071,10 @@ let as_interval_canfail fail low high l =
let as_interval_nofail l =
let store = StoreExp.mk_store () in
let rec some_hole = function
| []|[_] -> false
| (i,_)::((j,_)::_ as rem) ->
j > i+1 || some_hole rem in
let rec i_rec cur_low cur_high cur_act = function
| [] ->
[cur_low, cur_high, cur_act]
@ -2084,7 +2087,16 @@ let as_interval_nofail l =
i_rec i i act_index rem in
let inters = match l with
| (i,act)::rem ->
let act_index = store.act_store act in
let act_index =
(* In case there is some hole and that a switch is emited,
action 0 will be used as the action of unreacheable
cases (cf. switch.ml, make_switch).
Hence, this action will be shared *)
if some_hole rem then
store.act_store_shared act
else
store.act_store act in
assert (act_index = 0) ;
i_rec i i act_index rem
| _ -> assert false in

2
parsing/ast_helper.mli
View File

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

11
parsing/ast_mapper.ml
View File

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

10
parsing/builtin_attributes.ml
View File

@ -14,7 +14,7 @@ open Asttypes
open Parsetree
let string_of_cst = function
| Const_string(s, _) -> Some s
| PConst_string(s, _) -> Some s
| _ -> None
let string_of_payload = function
@ -37,13 +37,13 @@ let rec error_of_extension ext =
in
begin match p with
| PStr({pstr_desc=Pstr_eval
({pexp_desc=Pexp_constant(Const_string(msg,_))}, _)}::
({pexp_desc=Pexp_constant(PConst_string(msg,_))}, _)}::
{pstr_desc=Pstr_eval
({pexp_desc=Pexp_constant(Const_string(if_highlight,_))}, _)}::
({pexp_desc=Pexp_constant(PConst_string(if_highlight,_))}, _)}::
inner) ->
Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg
| PStr({pstr_desc=Pstr_eval
({pexp_desc=Pexp_constant(Const_string(msg,_))}, _)}::inner) ->
({pexp_desc=Pexp_constant(PConst_string(msg,_))}, _)}::inner) ->
Location.error ~loc ~sub:(sub_from inner) msg
| _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt
end
@ -113,7 +113,7 @@ let emit_external_warnings =
begin match a with
| {txt="ocaml.ppwarning"|"ppwarning"},
PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
(Const_string (s, _))},_);
(PConst_string (s, _))},_);
pstr_loc}] ->
Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
| _ -> ()

6
parsing/docstrings.ml
View File

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

1
parsing/lexer.mli
View File

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

47
parsing/lexer.mll
View File

@ -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)))
(* recover the name from a LABEL or OPTLABEL token *)
let get_label_name lexbuf =
@ -257,9 +244,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
@ -300,10 +284,11 @@ let float_literal =
('.' ['0'-'9' '_']* )?
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
let hex_float_literal =
'0' ['x' 'X']
'0' ['x' 'X']
['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']*)?
(['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
let literal_modifier = ['G'-'Z' 'g'-'z']
rule token = parse
| "\\" newline {
@ -341,29 +326,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 | hex_float_literal
{ FLOAT (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 (Lexing.lexeme lexbuf, None) }
| ((float_literal | hex_float_literal) as lit) (literal_modifier as modif)
{ FLOAT (lit, Some modif) }
| (float_literal | hex_float_literal | int_literal) identchar+
{ raise (Error(Invalid_literal (Lexing.lexeme lexbuf),
Location.curr lexbuf)) }

61
parsing/parser.mly
View File

@ -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]))
@ -430,7 +421,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
@ -448,9 +439,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
@ -476,7 +465,6 @@ let class_of_let_bindings lbs body =
%token MINUSGREATER
%token MODULE
%token MUTABLE
%token <nativeint> NATIVEINT
%token NEW
%token NONREC
%token OBJECT
@ -583,9 +571,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
@ -2159,26 +2147,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 */
@ -2293,7 +2272,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) }

8
parsing/parsetree.mli
View File

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

20
parsing/pprintast.ml
View File

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

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 -> Parsetree.constant -> unit
method constant_string : Format.formatter -> string -> unit
method constructor_declaration :
Format.formatter -> (string * Parsetree.constructor_arguments

22
parsing/printast.ml
View File

@ -49,17 +49,18 @@ let fmt_string_loc f x =
fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
;;
let fmt_char_option f = function
| None -> fprintf f "None"
| Some c -> fprintf f "Some %c" c
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);
| Const_string (s, None) -> fprintf f "Const_string(%S,None)" s;
| Const_string (s, Some delim) ->
fprintf f "Const_string (%S,Some %S)" s delim;
| Const_float (s) -> fprintf f "Const_float %s" s;
| Const_int32 (i) -> fprintf f "Const_int32 %ld" i;
| Const_int64 (i) -> fprintf f "Const_int64 %Ld" i;
| Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i;
| PConst_int (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m;
| PConst_char (c) -> fprintf f "PConst_char %02x" (Char.code c);
| PConst_string (s, None) -> fprintf f "PConst_string(%S,None)" s;
| PConst_string (s, Some delim) ->
fprintf f "PConst_string (%S,Some %S)" s delim;
| PConst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m;
;;
let fmt_mutable_flag f x =
@ -887,7 +888,8 @@ and directive_argument i ppf x =
match x with
| Pdir_none -> line i ppf "Pdir_none\n"
| Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
| Pdir_int (n) -> line i ppf "Pdir_int %d\n" n;
| Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
| Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;
| Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
| Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
;;

6
testsuite/tests/basic/min_int.ml Normal file
View File

@ -0,0 +1,6 @@
let min_int = -4611686018427387904
let () = match min_int with
| -4611686018427387904 as i ->
assert (string_of_int i = "-4611686018427387904");
print_endline "OK"
| _ -> assert false

1
testsuite/tests/basic/min_int.reference Normal file
View File

@ -0,0 +1 @@
OK

12
testsuite/tests/parsing/int_and_float_with_modifier.ml Normal file
View File

@ -0,0 +1,12 @@
let int_with_custom_modifier = 1234567890_1234567890_1234567890_1234567890_1234567890z
let float_with_custom_modifier = 1234567890_1234567890_1234567890_1234567890_1234567890.z
let int32 = 1234l
let int64 = 1234L
let nativeint = 1234n
let hex_without_modifier = 0x32f
let hex_with_modifier = 0x32g
let float_without_modifer = 1.2e3
let float_with_modifer = 1.2g

86
testsuite/tests/parsing/int_and_float_with_modifier.ml.reference Normal file
View File

@ -0,0 +1,86 @@
[
structure_item (int_and_float_with_modifier.ml[1,0+0]..[1,0+88])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[1,0+4]..[1,0+28])
Ppat_var "int_with_custom_modifier" (int_and_float_with_modifier.ml[1,0+4]..[1,0+28])
expression (int_and_float_with_modifier.ml[1,0+33]..[1,0+88])
Pexp_constant PConst_int (1234567890_1234567890_1234567890_1234567890_1234567890,Some z)
]
structure_item (int_and_float_with_modifier.ml[2,89+0]..[2,89+89])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[2,89+4]..[2,89+30])
Ppat_var "float_with_custom_modifier" (int_and_float_with_modifier.ml[2,89+4]..[2,89+30])
expression (int_and_float_with_modifier.ml[2,89+33]..[2,89+89])
Pexp_constant PConst_float (1234567890_1234567890_1234567890_1234567890_1234567890.,Some z)
]
structure_item (int_and_float_with_modifier.ml[4,180+0]..[4,180+21])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[4,180+4]..[4,180+9])
Ppat_var "int32" (int_and_float_with_modifier.ml[4,180+4]..[4,180+9])
expression (int_and_float_with_modifier.ml[4,180+16]..[4,180+21])
Pexp_constant PConst_int (1234,Some l)
]
structure_item (int_and_float_with_modifier.ml[5,202+0]..[5,202+21])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[5,202+4]..[5,202+9])
Ppat_var "int64" (int_and_float_with_modifier.ml[5,202+4]..[5,202+9])
expression (int_and_float_with_modifier.ml[5,202+16]..[5,202+21])
Pexp_constant PConst_int (1234,Some L)
]
structure_item (int_and_float_with_modifier.ml[6,224+0]..[6,224+21])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[6,224+4]..[6,224+13])
Ppat_var "nativeint" (int_and_float_with_modifier.ml[6,224+4]..[6,224+13])
expression (int_and_float_with_modifier.ml[6,224+16]..[6,224+21])
Pexp_constant PConst_int (1234,Some n)
]
structure_item (int_and_float_with_modifier.ml[8,247+0]..[8,247+32])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[8,247+4]..[8,247+24])
Ppat_var "hex_without_modifier" (int_and_float_with_modifier.ml[8,247+4]..[8,247+24])
expression (int_and_float_with_modifier.ml[8,247+27]..[8,247+32])
Pexp_constant PConst_int (0x32f,None)
]
structure_item (int_and_float_with_modifier.ml[9,280+0]..[9,280+32])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[9,280+4]..[9,280+21])
Ppat_var "hex_with_modifier" (int_and_float_with_modifier.ml[9,280+4]..[9,280+21])
expression (int_and_float_with_modifier.ml[9,280+27]..[9,280+32])
Pexp_constant PConst_int (0x32,Some g)
]
structure_item (int_and_float_with_modifier.ml[11,314+0]..[11,314+33])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[11,314+4]..[11,314+25])
Ppat_var "float_without_modifer" (int_and_float_with_modifier.ml[11,314+4]..[11,314+25])
expression (int_and_float_with_modifier.ml[11,314+28]..[11,314+33])
Pexp_constant PConst_float (1.2e3,None)
]
structure_item (int_and_float_with_modifier.ml[12,348+0]..[12,348+32])
Pstr_value Nonrec
[
<def>
pattern (int_and_float_with_modifier.ml[12,348+4]..[12,348+22])
Ppat_var "float_with_modifer" (int_and_float_with_modifier.ml[12,348+4]..[12,348+22])
expression (int_and_float_with_modifier.ml[12,348+28]..[12,348+32])
Pexp_constant PConst_float (1.2,Some g)
]
]
File "int_and_float_with_modifier.ml", line 1, characters 33-88:
Error: Unknown modifier 'z' for literal 1234567890_1234567890_1234567890_1234567890_1234567890z

2
testsuite/tests/parsing/pr6865.ml.reference
View File

@ -9,7 +9,7 @@
pattern (pr6865.ml[1,0+8]..[1,0+9])
Ppat_var "x" (pr6865.ml[1,0+8]..[1,0+9])
expression (pr6865.ml[1,0+12]..[1,0+14])
Pexp_constant Const_int 42
Pexp_constant PConst_int (42,None)
]
]
structure_item (pr6865.ml[2,15+0]..[2,15+25]) ghost

14
toplevel/toploop.ml
View File

@ -305,7 +305,19 @@ let execute_phrase print_outcome ppf phr =
match d, dir_arg with
| Directive_none f, Pdir_none -> f (); true
| Directive_string f, Pdir_string s -> f s; true
| Directive_int f, Pdir_int n -> f n; true
| Directive_int f, Pdir_int (n,None) ->
begin match Int_literal_converter.int n with
| n -> f n; true
| exception _ ->
fprintf ppf "Integer literal exceeds the range of \
representable integers for directive `%s'.@."
dir_name;
false
end
| Directive_int f, Pdir_int (n, Some _) ->
fprintf ppf "Wrong integer literal for directive `%s'.@."
dir_name;
false
| Directive_ident f, Pdir_ident lid -> f lid; true
| Directive_bool f, Pdir_bool b -> f b; true
| _ ->

2
typing/parmatch.ml
View File

@ -1709,7 +1709,7 @@ module Conv = struct
| Tpat_var _ ->
mkpat Ppat_any
| Tpat_constant c ->
mkpat (Ppat_constant c)
mkpat (Ppat_constant (Untypeast.constant c))
| Tpat_alias (p,_,_) -> loop p
| Tpat_tuple lst ->
mkpat (Ppat_tuple (List.map loop lst))

57
typing/typecore.ml
View File

@ -71,6 +71,8 @@ type error =
| Unrefuted_pattern of pattern
| Invalid_extension_constructor_payload
| Not_an_extension_constructor
| Literal_overflow of string
| Unknown_literal of string * char
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
@ -262,6 +264,38 @@ let type_constant = function
| Const_int64 _ -> instance_def Predef.type_int64
| Const_nativeint _ -> instance_def Predef.type_nativeint
let constant : Parsetree.constant -> (Asttypes.constant, error) result = function
| PConst_int (i,None) ->
begin
try Ok (Const_int (Misc.Int_literal_converter.int i))
with Failure _ -> Error (Literal_overflow "int")
end
| PConst_int (i,Some 'l') ->
begin
try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))
with Failure _ -> Error (Literal_overflow "int32")
end
| PConst_int (i,Some 'L') ->
begin
try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))
with Failure _ -> Error (Literal_overflow "int64")
end
| PConst_int (i,Some 'n') ->
begin
try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))
with Failure _ -> Error (Literal_overflow "nativeint")
end
| PConst_int (i,Some c) -> Error (Unknown_literal (i, c))
| PConst_char c -> Ok (Const_char c)
| PConst_string (s,d) -> Ok (Const_string (s,d))
| PConst_float (f,None)-> Ok (Const_float f)
| PConst_float (f,Some c) -> Error (Unknown_literal (f, c))
let constant_or_raise env loc cst =
match constant cst with
| Ok c -> c
| Error err -> raise (Error (loc, env, err))
(* Specific version of type_option, using newty rather than newgenty *)
let type_option ty =
@ -1028,6 +1062,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
pat_attributes = sp.ppat_attributes;
pat_env = !env })
| Ppat_constant cst ->
let cst = constant_or_raise !env loc cst in
unify_pat_types loc !env (type_constant cst) expected_ty;
rp k {
pat_desc = Tpat_constant cst;
@ -1035,14 +1070,14 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
pat_type = expected_ty;
pat_attributes = sp.ppat_attributes;
pat_env = !env }
| Ppat_interval (Const_char c1, Const_char c2) ->
| Ppat_interval (PConst_char c1, PConst_char c2) ->
let open Ast_helper.Pat in
let gloc = {loc with Location.loc_ghost=true} in
let rec loop c1 c2 =
if c1 = c2 then constant ~loc:gloc (Const_char c1)
if c1 = c2 then constant ~loc:gloc (PConst_char c1)
else
or_ ~loc:gloc
(constant ~loc:gloc (Const_char c1))
(constant ~loc:gloc (PConst_char c1))
(loop (Char.chr(Char.code c1 + 1)) c2)
in
let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
@ -1918,7 +1953,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
exp_attributes = sexp.pexp_attributes;
exp_env = env }
end
| Pexp_constant(Const_string (str, _) as cst) -> (
| Pexp_constant(PConst_string (str, _) as cst) -> (
let cst = constant_or_raise env loc cst in
(* Terrible hack for format strings *)
let ty_exp = expand_head env ty_expected in
let fmt6_path =
@ -1945,6 +1981,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
exp_env = env }
)
| Pexp_constant cst ->
let cst = constant_or_raise env loc cst in
rue {
exp_desc = Texp_constant cst;
exp_loc = loc; exp_extra = [];
@ -2958,9 +2995,9 @@ and type_format loc str env =
| _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in
mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in
let mk_cst cst = mk_exp_loc (Pexp_constant cst) in
let mk_int n = mk_cst (Const_int n)
and mk_string str = mk_cst (Const_string (str, None))
and mk_char chr = mk_cst (Const_char chr) in
let mk_int n = mk_cst (PConst_int (string_of_int n, None))
and mk_string str = mk_cst (PConst_string (str, None))
and mk_char chr = mk_cst (PConst_char chr) in
let rec mk_formatting_lit fmting = match fmting with
| Close_box ->
mk_constr "Close_box" []
@ -4242,6 +4279,12 @@ let report_error env ppf = function
| Not_an_extension_constructor ->
fprintf ppf
"This constructor is not an extension constructor."
| Literal_overflow ty ->
fprintf ppf "Integer literal exceeds the range of representable \
integers of type %s" ty
| Unknown_literal (n, m) ->
fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m
let report_error env ppf err =
wrap_printing_env env (fun () -> report_error env ppf err)

4
typing/typecore.mli
View File

@ -116,6 +116,8 @@ type error =
| Unrefuted_pattern of Typedtree.pattern
| Invalid_extension_constructor_payload
| Not_an_extension_constructor
| Literal_overflow of string
| Unknown_literal of string * char
exception Error of Location.t * Env.t * error
exception Error_forward of Location.error
@ -140,3 +142,5 @@ val type_package:
val create_package_type : Location.t -> Env.t ->
Longident.t * (Longident.t * Parsetree.core_type) list ->
Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr
val constant: Parsetree.constant -> (Asttypes.constant, error) result

13
typing/untypeast.ml
View File

@ -112,6 +112,15 @@ let fresh_name s env =
(** Mapping functions. *)
let constant = function
| Const_char c -> PConst_char c
| Const_string (s,d) -> PConst_string (s,d)
| Const_int i -> PConst_int (string_of_int i, None)
| Const_int32 i -> PConst_int (Int32.to_string i, Some 'l')
| Const_int64 i -> PConst_int (Int64.to_string i, Some 'L')
| Const_nativeint i -> PConst_int (Nativeint.to_string i, Some 'n')
| Const_float f -> PConst_float (f,None)
let attribute sub (s, p) = (map_loc sub s, p)
let attributes sub l = List.map (sub.attribute sub) l
@ -280,7 +289,7 @@ let pattern sub pat =
| Tpat_alias (pat, _id, name) ->
Ppat_alias (sub.pat sub pat, name)
| Tpat_constant cst -> Ppat_constant cst
| Tpat_constant cst -> Ppat_constant (constant cst)
| Tpat_tuple list ->
Ppat_tuple (List.map (sub.pat sub) list)
| Tpat_construct (lid, _, args) ->
@ -345,7 +354,7 @@ let expression sub exp =
let desc =
match exp.exp_desc with
Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid)
| Texp_constant cst -> Pexp_constant cst
| Texp_constant cst -> Pexp_constant (constant cst)
| Texp_let (rec_flag, list, exp) ->
Pexp_let (rec_flag,
List.map (sub.value_binding sub) list,

2
typing/untypeast.mli
View File

@ -71,3 +71,5 @@ val default_mapper : mapper
val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure
val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature
val constant : Asttypes.constant -> Parsetree.constant

12
utils/misc.ml
View File

@ -188,6 +188,18 @@ let no_overflow_mul a b = b <> 0 && (a * b) / b = a
let no_overflow_lsl a k =
0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k
module Int_literal_converter = struct
(* To convert integer literals, allowing max_int + 1 (PR#4210) *)
let cvt_int_aux str neg of_string =
if String.length str = 0 || str.[0]= '-'
then of_string str
else neg (of_string ("-" ^ str))
let int s = cvt_int_aux s (~-) int_of_string
let int32 s = cvt_int_aux s Int32.neg Int32.of_string
let int64 s = cvt_int_aux s Int64.neg Int64.of_string
let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
end
(* String operations *)
let chop_extension_if_any fname =

7
utils/misc.mli
View File

@ -89,6 +89,13 @@ val no_overflow_lsl: int -> int -> bool
(* [no_overflow_lsl n k] returns [true] if the computation of
[n lsl k] does not overflow. *)
module Int_literal_converter : sig
val int : string -> int
val int32 : string -> int32
val int64 : string -> int64
val nativeint : string -> nativeint
end
val chop_extension_if_any: string -> string
(* Like Filename.chop_extension but returns the initial file
name if it has no extension *)