OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2017-01-20  Yannick Moy  <moy@adacore.com>

	* sem_ch10.adb (Check_No_Elab_Code_All): Do not issue an error
	on implicitly with'ed units in GNATprove mode.
	* sinfo.ads (Implicit_With): Document use of flag for implicitly
	with'ed units in GNATprove mode.

2017-01-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_cat.adb (Validate_Static_Object_Name): In a preelaborated
	unit Do not report an error on a non-static entity that appears
	in the context of a spec expression, such as an aspect expression.

2017-01-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb: Flag298 now denotes Is_Underlying_Full_View.
	(Is_Underlying_Full_View): New routine.
	(Set_Is_Underlying_Full_View): New routine.
	(Write_Entity_Flags): Add an entry for Is_Underlying_Full_View.
	* einfo.ads Add new attribute Is_Underlying_Full_View.
	(Is_Underlying_Full_View): New routine along with pragma Inline.
	(Set_Is_Underlying_Full_View): New routine along with pragma Inline.
	* exp_util.adb (Build_DIC_Procedure_Body): Do not consider
	class-wide types and underlying full views. The first subtype
	is used as the working type for all Itypes, not just array base types.
	(Build_DIC_Procedure_Declaration): Do not consider
	class-wide types and underlying full views. The first subtype
	is used as the working type for all Itypes, not just array
	base types.
	* freeze.adb (Freeze_Entity): Inherit the freeze node of a full
	view or an underlying full view without clobbering the attributes
	of a previous freeze node.
	(Inherit_Freeze_Node): New routine.
	* sem_ch3.adb (Build_Derived_Private_Type): Mark an underlying
	full view as such.
	(Build_Underlying_Full_View): Mark an underlying full view as such.
	* sem_ch7.adb (Install_Private_Declarations): Mark an underlying
	full view as such.

From-SVN: r244696
This commit is contained in:
Arnaud Charlet 2017-01-20 11:31:58 +01:00
parent 17d302ec03
commit ce06d6418f
10 changed files with 188 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/ada/ChangeLog
View File

@ -1,3 +1,42 @@
2017-01-20 Yannick Moy <moy@adacore.com>
* sem_ch10.adb (Check_No_Elab_Code_All): Do not issue an error
on implicitly with'ed units in GNATprove mode.
* sinfo.ads (Implicit_With): Document use of flag for implicitly
with'ed units in GNATprove mode.
2017-01-20 Ed Schonberg <schonberg@adacore.com>
* sem_cat.adb (Validate_Static_Object_Name): In a preelaborated
unit Do not report an error on a non-static entity that appears
in the context of a spec expression, such as an aspect expression.
2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb: Flag298 now denotes Is_Underlying_Full_View.
(Is_Underlying_Full_View): New routine.
(Set_Is_Underlying_Full_View): New routine.
(Write_Entity_Flags): Add an entry for Is_Underlying_Full_View.
* einfo.ads Add new attribute Is_Underlying_Full_View.
(Is_Underlying_Full_View): New routine along with pragma Inline.
(Set_Is_Underlying_Full_View): New routine along with pragma Inline.
* exp_util.adb (Build_DIC_Procedure_Body): Do not consider
class-wide types and underlying full views. The first subtype
is used as the working type for all Itypes, not just array base types.
(Build_DIC_Procedure_Declaration): Do not consider
class-wide types and underlying full views. The first subtype
is used as the working type for all Itypes, not just array
base types.
* freeze.adb (Freeze_Entity): Inherit the freeze node of a full
view or an underlying full view without clobbering the attributes
of a previous freeze node.
(Inherit_Freeze_Node): New routine.
* sem_ch3.adb (Build_Derived_Private_Type): Mark an underlying
full view as such.
(Build_Underlying_Full_View): Mark an underlying full view as such.
* sem_ch7.adb (Install_Private_Declarations): Mark an underlying
full view as such.
2017-01-20 Yannick Moy <moy@adacore.com>
* sinfo.ads: Document lack of Do_Division_Check flag

14
gcc/ada/einfo.adb
View File

@ -614,8 +614,8 @@ package body Einfo is
-- Is_Ignored_Transient Flag295
-- Has_Partial_Visible_Refinement Flag296
-- Is_Entry_Wrapper Flag297
-- Is_Underlying_Full_View Flag298
-- (unused) Flag298
-- (unused) Flag299
-- (unused) Flag300
@ -2612,6 +2612,11 @@ package body Einfo is
return Flag117 (Implementation_Base_Type (Id));
end Is_Unchecked_Union;
function Is_Underlying_Full_View (Id : E) return B is
begin
return Flag298 (Id);
end Is_Underlying_Full_View;
function Is_Underlying_Record_View (Id : E) return B is
begin
return Flag246 (Id);
@ -5709,6 +5714,12 @@ package body Einfo is
Set_Flag117 (Id, V);
end Set_Is_Unchecked_Union;
procedure Set_Is_Underlying_Full_View (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag298 (Id, V);
end Set_Is_Underlying_Full_View;
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Record_Type);
@ -9457,6 +9468,7 @@ package body Einfo is
W ("Is_Trivial_Subprogram", Flag235 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
W ("Is_Underlying_Full_View", Flag298 (Id));
W ("Is_Underlying_Record_View", Flag246 (Id));
W ("Is_Unimplemented", Flag284 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));

9
gcc/ada/einfo.ads
View File

@ -3236,6 +3236,11 @@ package Einfo is
-- Defined in all entities. Set only in record types to which the
-- pragma Unchecked_Union has been validly applied.
-- Is_Underlying_Full_View (Flag298)
-- Defined in all entities. Set for types which represent the true full
-- view of a private type completed by another private type. For further
-- details, see attribute Underlying_Full_View.
-- Is_Underlying_Record_View (Flag246) [base type only]
-- Defined in all entities. Set only in record types that represent the
-- underlying record view. This view is built for derivations of types
@ -7183,6 +7188,7 @@ package Einfo is
function Is_Trivial_Subprogram (Id : E) return B;
function Is_True_Constant (Id : E) return B;
function Is_Unchecked_Union (Id : E) return B;
function Is_Underlying_Full_View (Id : E) return B;
function Is_Underlying_Record_View (Id : E) return B;
function Is_Unimplemented (Id : E) return B;
function Is_Unsigned_Type (Id : E) return B;
@ -7868,6 +7874,7 @@ package Einfo is
procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True);
procedure Set_Is_True_Constant (Id : E; V : B := True);
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
procedure Set_Is_Underlying_Full_View (Id : E; V : B := True);
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True);
procedure Set_Is_Unimplemented (Id : E; V : B := True);
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
@ -8705,6 +8712,7 @@ package Einfo is
pragma Inline (Is_True_Constant);
pragma Inline (Is_Type);
pragma Inline (Is_Unchecked_Union);
pragma Inline (Is_Underlying_Full_View);
pragma Inline (Is_Underlying_Record_View);
pragma Inline (Is_Unimplemented);
pragma Inline (Is_Unsigned_Type);
@ -9180,6 +9188,7 @@ package Einfo is
pragma Inline (Set_Is_Trivial_Subprogram);
pragma Inline (Set_Is_True_Constant);
pragma Inline (Set_Is_Unchecked_Union);
pragma Inline (Set_Is_Underlying_Full_View);
pragma Inline (Set_Is_Underlying_Record_View);
pragma Inline (Set_Is_Unimplemented);
pragma Inline (Set_Is_Unsigned_Type);

42
gcc/ada/exp_util.adb
View File

@ -1736,13 +1736,24 @@ package body Exp_Util is
-- Start of processing for Build_DIC_Procedure_Body
begin
Work_Typ := Typ;
Work_Typ := Base_Type (Typ);
-- The input type denotes the implementation base type of a constrained
-- array type. Work with the first subtype as the DIC pragma is on its
-- rep item chain.
-- Do not process class-wide types as these are Itypes, but lack a first
-- subtype (see below).
if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
if Is_Class_Wide_Type (Work_Typ) then
return;
-- Do not process the underlying full view of a private type. There is
-- no way to get back to the partial view, plus the body will be built
-- by the full view or the base type.
elsif Is_Underlying_Full_View (Work_Typ) then
return;
-- Use the first subtype when dealing with various base types
elsif Is_Itype (Work_Typ) then
Work_Typ := First_Subtype (Work_Typ);
-- The input denotes the corresponding record type of a protected or a
@ -1964,13 +1975,24 @@ package body Exp_Util is
-- The working type
begin
Work_Typ := Typ;
Work_Typ := Base_Type (Typ);
-- The input type denotes the implementation base type of a constrained
-- array type. Work with the first subtype as the DIC pragma is on its
-- rep item chain.
-- Do not process class-wide types as these are Itypes, but lack a first
-- subtype (see below).
if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
if Is_Class_Wide_Type (Work_Typ) then
return;
-- Do not process the underlying full view of a private type. There is
-- no way to get back to the partial view, plus the body will be built
-- by the full view or the base type.
elsif Is_Underlying_Full_View (Work_Typ) then
return;
-- Use the first subtype when dealing with various base types
elsif Is_Itype (Work_Typ) then
Work_Typ := First_Subtype (Work_Typ);
-- The input denotes the corresponding record type of a protected or a

78
gcc/ada/freeze.adb
View File

@ -2087,6 +2087,12 @@ package body Freeze is
-- Determine whether an arbitrary entity is subject to Boolean aspect
-- Import and its value is specified as True.
procedure Inherit_Freeze_Node
(Fnod : Node_Id;
Typ : Entity_Id);
-- Set type Typ's freeze node to refer to Fnode. This routine ensures
-- that any attributes attached to Typ's original node are preserved.
procedure Wrap_Imported_Subprogram (E : Entity_Id);
-- If E is an entity for an imported subprogram with pre/post-conditions
-- then this procedure will create a wrapper to ensure that proper run-
@ -4726,6 +4732,60 @@ package body Freeze is
return False;
end Has_Boolean_Aspect_Import;
-------------------------
-- Inherit_Freeze_Node --
-------------------------
procedure Inherit_Freeze_Node
(Fnod : Node_Id;
Typ : Entity_Id)
is
Typ_Fnod : constant Node_Id := Freeze_Node (Typ);
begin
Set_Freeze_Node (Typ, Fnod);
Set_Entity (Fnod, Typ);
-- The input type had an existing node. Propagate relevant attributes
-- from the old freeze node to the inherited freeze node.
-- ??? if both freeze nodes have attributes, would they differ?
if Present (Typ_Fnod) then
-- Attribute Access_Types_To_Process
if Present (Access_Types_To_Process (Typ_Fnod))
and then No (Access_Types_To_Process (Fnod))
then
Set_Access_Types_To_Process (Fnod,
Access_Types_To_Process (Typ_Fnod));
end if;
-- Attribute Actions
if Present (Actions (Typ_Fnod)) and then No (Actions (Fnod)) then
Set_Actions (Fnod, Actions (Typ_Fnod));
end if;
-- Attribute First_Subtype_Link
if Present (First_Subtype_Link (Typ_Fnod))
and then No (First_Subtype_Link (Fnod))
then
Set_First_Subtype_Link (Fnod, First_Subtype_Link (Typ_Fnod));
end if;
-- Attribute TSS_Elist
if Present (TSS_Elist (Typ_Fnod))
and then No (TSS_Elist (Fnod))
then
Set_TSS_Elist (Fnod, TSS_Elist (Typ_Fnod));
end if;
end if;
end Inherit_Freeze_Node;
------------------------------
-- Wrap_Imported_Subprogram --
------------------------------
@ -5776,9 +5836,9 @@ package body Freeze is
F_Node := Freeze_Node (Full);
if Present (F_Node) then
Set_Freeze_Node (Full_View (E), F_Node);
Set_Entity (F_Node, Full_View (E));
Inherit_Freeze_Node
(Fnod => F_Node,
Typ => Full_View (E));
else
Set_Has_Delayed_Freeze (Full_View (E), False);
Set_Freeze_Node (Full_View (E), Empty);
@ -5789,9 +5849,9 @@ package body Freeze is
F_Node := Freeze_Node (Full_View (E));
if Present (F_Node) then
Set_Freeze_Node (E, F_Node);
Set_Entity (F_Node, E);
Inherit_Freeze_Node
(Fnod => F_Node,
Typ => E);
else
-- {Incomplete,Private}_Subtypes with Full_Views
-- constrained by discriminants.
@ -5847,9 +5907,9 @@ package body Freeze is
F_Node := Freeze_Node (Underlying_Full_View (E));
if Present (F_Node) then
Set_Freeze_Node (E, F_Node);
Set_Entity (F_Node, E);
Inherit_Freeze_Node
(Fnod => F_Node,
Typ => E);
else
Set_Has_Delayed_Freeze (E, False);
Set_Freeze_Node (E, Empty);

5
gcc/ada/sem_cat.adb
View File

@ -2171,11 +2171,14 @@ package body Sem_Cat is
-- Error if the name is a primary in an expression. The parent must not
-- be an operator, or a selected component or an indexed component that
-- is itself a primary. Entities that are actuals do not need to be
-- checked, because the call itself will be diagnosed.
-- checked, because the call itself will be diagnosed. Entities in a
-- generic unit or within a preanalyzed expression are not checked:
-- only their use in executable code matters.
if Is_Primary (N)
and then (not Inside_A_Generic
or else Present (Enclosing_Generic_Body (N)))
and then not In_Spec_Expression
then
if Ekind (Entity (N)) = E_Variable
or else Ekind (Entity (N)) in Formal_Object_Kind

8
gcc/ada/sem_ch10.adb
View File

@ -6116,6 +6116,14 @@ package body Sem_Ch10 is
if Nkind (CI) = N_With_Clause
and then not
No_Elab_Code_All (Get_Source_Unit (Library_Unit (CI)))
-- In GNATprove mode, some runtime units are implicitly
-- loaded to make their entities available for analysis. In
-- this case, ignore violations of No_Elaboration_Code_All
-- for this special analysis mode.
and then not
(GNATprove_Mode and then Implicit_With (CI))
then
Error_Msg_Sloc := Sloc (No_Elab_Code_All_Pragma);
Error_Msg_N

4
gcc/ada/sem_ch3.adb
View File

@ -7444,6 +7444,7 @@ package body Sem_Ch3 is
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
Set_Is_Underlying_Full_View (Full_Der);
end if;
if not Is_Base_Type (Derived_Type) then
@ -7501,6 +7502,7 @@ package body Sem_Ch3 is
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
Set_Is_Underlying_Full_View (Full_Der);
end if;
-- In any case, the primitive operations are inherited from the
@ -7607,6 +7609,7 @@ package body Sem_Ch3 is
else
Build_Full_Derivation;
Set_Underlying_Full_View (Derived_Type, Full_Der);
Set_Is_Underlying_Full_View (Full_Der);
end if;
-- The full view will be used to swap entities on entry/exit to
@ -10018,6 +10021,7 @@ package body Sem_Ch3 is
Analyze (Indic);
Set_Underlying_Full_View (Typ, Full_View (Subt));
Set_Is_Underlying_Full_View (Full_View (Subt));
end Build_Underlying_Full_View;
-------------------------------

1
gcc/ada/sem_ch7.adb
View File

@ -2178,6 +2178,7 @@ package body Sem_Ch7 is
then
Set_Full_View (Id, Underlying_Full_View (Full));
Set_Underlying_Full_View (Id, Full);
Set_Is_Underlying_Full_View (Full);
Set_Underlying_Full_View (Full, Empty);
Set_Is_Frozen (Full_View (Id));

19
gcc/ada/sinfo.ads
View File

@ -1563,10 +1563,10 @@ package Sinfo is
-- Implicit_With (Flag16-Sem)
-- This flag is set in the N_With_Clause node that is implicitly
-- generated for runtime units that are loaded by the expander, and also
-- for package System, if it is loaded implicitly by a use of the
-- 'Address or 'Tag attribute. ???There are other implicit with clauses
-- as well.
-- generated for runtime units that are loaded by the expander or in
-- GNATprove mode, and also for package System, if it is loaded
-- implicitly by a use of the 'Address or 'Tag attribute.
-- ??? There are other implicit with clauses as well.
-- Implicit_With_From_Instantiation (Flag12-Sem)
-- Set in N_With_Clause nodes from generic instantiations.
@ -1690,7 +1690,7 @@ package Sinfo is
-- actuals to support a build-in-place style of call have been added to
-- the call.
-- Is_Finalization_Wrapper (Flag9-Sem);
-- Is_Finalization_Wrapper (Flag9-Sem)
-- This flag is present in N_Block_Statement nodes. It is set when the
-- block acts as a wrapper of a handled construct which has controlled
-- objects. The wrapper prevents interference between exception handlers
@ -2477,8 +2477,8 @@ package Sinfo is
-- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that
-- has been constant-folded into its literal value.
-- Intval (Uint3) contains integer value of literal
-- plus fields for expression
-- Print_In_Hex (Flag13-Sem)
-- plus fields for expression
-- N_Real_Literal
-- Sloc points to literal
@ -3367,7 +3367,7 @@ package Sinfo is
-- N_Discriminant_Association
-- Sloc points to first token of discriminant association
-- Selector_Names (List1) (always non-empty, since if no selector
-- names are present, this node is not used, see comment above)
-- names are present, this node is not used, see comment above)
-- Expression (Node3)
---------------------------------
@ -3905,7 +3905,6 @@ package Sinfo is
-- Must_Be_Byte_Aligned (Flag14-Sem)
-- Non_Aliased_Prefix (Flag18-Sem)
-- Redundant_Use (Flag13-Sem)
-- plus fields for expression
-- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded
@ -4431,8 +4430,8 @@ package Sinfo is
-- plus fields for expression
-- N_Op_Expon
-- Is_Power_Of_2_For_Shift (Flag13-Sem)
-- Sloc points to **
-- Is_Power_Of_2_For_Shift (Flag13-Sem)
-- plus fields for binary operator
-- plus fields for expression
@ -4654,8 +4653,8 @@ package Sinfo is
-- Sloc points to apostrophe
-- Subtype_Mark (Node4)
-- Expression (Node3) expression or aggregate
-- plus fields for expression
-- Is_Qualified_Universal_Literal (Flag4-Sem)
-- plus fields for expression
--------------------
-- 4.8 Allocator --