Commit d1b83e62 by Arnaud Charlet

[multiple changes]

2016-06-16  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Overridden_Ancestor): Clean up code to use
	controlling type of desired primitive rather than its scope,
	because the primitive that inherits the classwide condition may
	comes from several derivation steps.

2016-06-16  Javier Miranda  <miranda@adacore.com>

	* einfo.adb (Set_Default_Init_Cond_Procedure): Allow calls setting
	this attribute to Empty (only if the attribute has not been set).
	* sem_util.adb (Build_Default_Init_Cond_Procedure_Body):
	No action needed if the spec was not built.
	(Build_Default_Init_Cond_Procedure_Declaration): The spec is
	not built if DIC is set to NULL or no condition was specified.
	* exp_ch3.adb (Expand_N_Object_Declaration): Check availability
	of the Init_Cond procedure before generating code to call it.

2016-06-16  Emmanuel Briot  <briot@adacore.com>

	* s-regpat.adb: Fix invalid index check when matching end-of-line
	on substrings.

2016-06-16  Arnaud Charlet  <charlet@adacore.com>

	* gnat1drv.adb: Minor reformatting.

From-SVN: r237516
parent 3386e3ae
2016-06-16 Ed Schonberg <schonberg@adacore.com> 2016-06-16 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Overridden_Ancestor): Clean up code to use
controlling type of desired primitive rather than its scope,
because the primitive that inherits the classwide condition may
comes from several derivation steps.
2016-06-16 Javier Miranda <miranda@adacore.com>
* einfo.adb (Set_Default_Init_Cond_Procedure): Allow calls setting
this attribute to Empty (only if the attribute has not been set).
* sem_util.adb (Build_Default_Init_Cond_Procedure_Body):
No action needed if the spec was not built.
(Build_Default_Init_Cond_Procedure_Declaration): The spec is
not built if DIC is set to NULL or no condition was specified.
* exp_ch3.adb (Expand_N_Object_Declaration): Check availability
of the Init_Cond procedure before generating code to call it.
2016-06-16 Emmanuel Briot <briot@adacore.com>
* s-regpat.adb: Fix invalid index check when matching end-of-line
on substrings.
2016-06-16 Arnaud Charlet <charlet@adacore.com>
* gnat1drv.adb: Minor reformatting.
2016-06-16 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Check_Entry_Contracts): New procedure, subsidiary * sem_ch3.adb (Check_Entry_Contracts): New procedure, subsidiary
of Analyze_Declarations, that performs pre-analysis of of Analyze_Declarations, that performs pre-analysis of
pre/postconditions on entry declarations before full analysis pre/postconditions on entry declarations before full analysis
......
...@@ -8567,6 +8567,13 @@ package body Einfo is ...@@ -8567,6 +8567,13 @@ package body Einfo is
Subp_Id : Entity_Id; Subp_Id : Entity_Id;
begin begin
-- Once set this attribute it cannot be reset
if No (V) then
pragma Assert (No (Default_Init_Cond_Procedure (Id)));
return;
end if;
pragma Assert pragma Assert
(Is_Type (Id) (Is_Type (Id)
and then (Has_Default_Init_Cond (Id) and then (Has_Default_Init_Cond (Id)
......
...@@ -6963,6 +6963,7 @@ package body Exp_Ch3 is ...@@ -6963,6 +6963,7 @@ package body Exp_Ch3 is
or else or else
Has_Inherited_Default_Init_Cond (Typ)) Has_Inherited_Default_Init_Cond (Typ))
and then not Has_Init_Expression (N) and then not Has_Init_Expression (N)
and then Present (Default_Init_Cond_Procedure (Typ))
then then
declare declare
DIC_Call : constant Node_Id := DIC_Call : constant Node_Id :=
......
...@@ -317,7 +317,7 @@ procedure Gnat1drv is ...@@ -317,7 +317,7 @@ procedure Gnat1drv is
Assertions_Enabled := True; Assertions_Enabled := True;
-- Set normal RM validity checking and checking of copies (to catch -- Set normal RM validity checking and checking of copies (to catch
-- e.g. wrong values used in unchecked conversions). -- e.g. wrong values used in unchecked conversions).
-- All other validity checking is turned off, since this can generate -- All other validity checking is turned off, since this can generate
-- very complex trees that only confuse CodePeer and do not bring -- very complex trees that only confuse CodePeer and do not bring
-- enough useful info. -- enough useful info.
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1986 by University of Toronto. -- -- Copyright (C) 1986 by University of Toronto. --
-- Copyright (C) 1999-2015, AdaCore -- -- Copyright (C) 1999-2016, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2614,16 +2614,16 @@ package body System.Regpat is ...@@ -2614,16 +2614,16 @@ package body System.Regpat is
exit State_Machine when Input_Pos /= BOL_Pos; exit State_Machine when Input_Pos /= BOL_Pos;
when EOL => when EOL =>
exit State_Machine when Input_Pos <= Data'Last exit State_Machine when Input_Pos <= Last_In_Data
and then ((Self.Flags and Multiple_Lines) = 0 and then ((Self.Flags and Multiple_Lines) = 0
or else Data (Input_Pos) /= ASCII.LF); or else Data (Input_Pos) /= ASCII.LF);
when MEOL => when MEOL =>
exit State_Machine when Input_Pos <= Data'Last exit State_Machine when Input_Pos <= Last_In_Data
and then Data (Input_Pos) /= ASCII.LF; and then Data (Input_Pos) /= ASCII.LF;
when SEOL => when SEOL =>
exit State_Machine when Input_Pos <= Data'Last; exit State_Machine when Input_Pos <= Last_In_Data;
when BOUND | NBOUND => when BOUND | NBOUND =>
......
...@@ -26342,13 +26342,18 @@ package body Sem_Prag is ...@@ -26342,13 +26342,18 @@ package body Sem_Prag is
------------------------- -------------------------
function Overridden_Ancestor (S : Entity_Id) return Entity_Id is function Overridden_Ancestor (S : Entity_Id) return Entity_Id is
Par : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
Anc : Entity_Id; Anc : Entity_Id;
begin begin
Anc := S; Anc := S;
-- Locate the ancestor subprogram with the proper controlling
-- type.
while Present (Overridden_Operation (Anc)) loop while Present (Overridden_Operation (Anc)) loop
exit when Scope (Anc) = Scope (Inher_Id);
Anc := Overridden_Operation (Anc); Anc := Overridden_Operation (Anc);
exit when Find_Dispatching_Type (Anc) = Par;
end loop; end loop;
return Anc; return Anc;
......
...@@ -1214,9 +1214,9 @@ package body Sem_Util is ...@@ -1214,9 +1214,9 @@ package body Sem_Util is
Prag : constant Node_Id := Prag : constant Node_Id :=
Get_Pragma (Typ, Pragma_Default_Initial_Condition); Get_Pragma (Typ, Pragma_Default_Initial_Condition);
Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ); Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id);
Body_Decl : Node_Id; Body_Decl : Node_Id;
Expr : Node_Id; Expr : Node_Id;
Spec_Decl : Node_Id;
Stmt : Node_Id; Stmt : Node_Id;
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
...@@ -1230,11 +1230,14 @@ package body Sem_Util is ...@@ -1230,11 +1230,14 @@ package body Sem_Util is
pragma Assert (Has_Default_Init_Cond (Typ)); pragma Assert (Has_Default_Init_Cond (Typ));
pragma Assert (Present (Prag)); pragma Assert (Present (Prag));
pragma Assert (Present (Proc_Id));
-- Nothing to do if the body was already built -- No action needed if the spec was not built or if the body was
-- already built.
if Present (Corresponding_Body (Spec_Decl)) then if No (Proc_Id)
or else
Present (Corresponding_Body (Unit_Declaration_Node (Proc_Id)))
then
return; return;
end if; end if;
...@@ -1293,6 +1296,7 @@ package body Sem_Util is ...@@ -1293,6 +1296,7 @@ package body Sem_Util is
-- <Stmt>; -- <Stmt>;
-- end <Typ>Default_Init_Cond; -- end <Typ>Default_Init_Cond;
Spec_Decl := Unit_Declaration_Node (Proc_Id);
Body_Decl := Body_Decl :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
...@@ -1378,6 +1382,17 @@ package body Sem_Util is ...@@ -1378,6 +1382,17 @@ package body Sem_Util is
if Present (Default_Init_Cond_Procedure (Typ)) then if Present (Default_Init_Cond_Procedure (Typ)) then
return; return;
-- The procedure must not be generated when DIC has one of these two
-- forms: 1. Default_Initial_Condition => null
-- 2. Default_Initial_Condition
elsif No (Pragma_Argument_Associations (Prag))
or else
Nkind (Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))))
= N_Null
then
return;
end if; end if;
-- The related type may be subject to pragma Ghost. Set the mode now to -- The related type may be subject to pragma Ghost. Set the mode now to
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment