From ce06d6418fc2863db4b1db8d8d7794cc7c1067ad Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 20 Jan 2017 11:31:58 +0100 Subject: [PATCH] [multiple changes] 2017-01-20 Yannick Moy * 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 * 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 * 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 --- gcc/ada/ChangeLog | 39 ++++++++++++++++++++++ gcc/ada/einfo.adb | 14 +++++++- gcc/ada/einfo.ads | 9 +++++ gcc/ada/exp_util.adb | 42 ++++++++++++++++++------ gcc/ada/freeze.adb | 78 +++++++++++++++++++++++++++++++++++++++----- gcc/ada/sem_cat.adb | 5 ++- gcc/ada/sem_ch10.adb | 8 +++++ gcc/ada/sem_ch3.adb | 4 +++ gcc/ada/sem_ch7.adb | 1 + gcc/ada/sinfo.ads | 19 +++++------ 10 files changed, 188 insertions(+), 31 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 75a44945fe92..428648aa8627 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2017-01-20 Yannick Moy + + * 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 + + * 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 + + * 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 * sinfo.ads: Document lack of Do_Division_Check flag diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index af9dc6975b84..e97d1478bb25 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6b85bb9d5bc2..5a762abcaeed 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 7641540d1266..1cbffd1a96c4 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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); + + -- Do not process class-wide types as these are Itypes, but lack a first + -- subtype (see below). + + 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; - -- 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. + -- Use the first subtype when dealing with various base types - if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then + elsif Is_Itype (Work_Typ) then Work_Typ := First_Subtype (Work_Typ); -- The input denotes the corresponding record type of a protected or a diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index fcbf994df82a..2a5c416ba3f8 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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); diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index a84c0ea475f5..ba684e1268c8 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -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 diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index c1f671fb43a9..53001058eee0 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index dbbb25e7f0d0..68b732398f3d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; ------------------------------- diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 95774e278e43..709f5938fbd7 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -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)); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index bf938525d559..e63229a41f8a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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 -- -- 2.43.5