From: charlet Date: Tue, 29 Jul 2014 13:30:02 +0000 (+0000) Subject: 2014-07-29 Robert Dewar X-Git-Tag: upstream/5.3.0~6901 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=04d38ee4ac2b0b323eb71d2e5700ee7497053deb;p=platform%2Fupstream%2Flinaro-gcc.git 2014-07-29 Robert Dewar * einfo.adb (Derived_Type_Link): New function (Set_Derived_Type_Link): New procedure. (Write_Field31_Name): Output Derived_Type_Link. * einfo.ads: New field Derived_Type_Link. * exp_ch6.adb (Expand_Call): Warn if change of representation needed on call. * sem_ch13.adb: Minor addition of ??? comment. (Rep_Item_Too_Late): Warn on case that is legal but could cause an expensive implicit conversion. * sem_ch3.adb (Build_Derived_Type): Set Derived_Type_Link if needed. 2014-07-29 Hristian Kirtchev * exp_ch3.adb (Build_Init_Procedure): Renamed Local_DF_Id to DF_Id. Add new local variable DF_Call. Do not perform any elaboration-related checks on the call to the partial finalization routine within an init proc to avoid generating bogus elaboration warnings on expansion-related code. * sem_elab.adb (Check_A_Call): Move constant Access_Case to the top level of the routine. Ensure that Output_Calls takes into account flags -gnatel and -gnatwl when emitting warnings or info messages. (Check_Internal_Call_Continue): Update the call to Output_Calls. (Elab_Warning): Moved to the top level of routine Check_A_Call. (Emit): New routines. (Output_Calls): Add new formal parameter Check_Elab_Flag along with a comment on usage. Output all warnings or info messages only when the caller context demands it and the proper elaboration flag is set. 2014-07-29 Yannick Moy * sem_attr.adb (Analyze_Attribute/Attribute_Old): Check rule about Old appearing in potentially unevaluated expression everywhere, not only in Post. 2014-07-29 Arnaud Charlet * sem_prag.adb: Update comment. * a-except.adb, a-except-2005.adb: Minor editing. 2014-07-29 Pierre-Marie Derodat * exp_dbug.adb (Debug_Renaming_Declaration): Do not create renaming entities for renamings of non-packed objects and for exceptions. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@213175 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 58a3246..a04acf4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,53 @@ 2014-07-29 Robert Dewar + * einfo.adb (Derived_Type_Link): New function + (Set_Derived_Type_Link): New procedure. + (Write_Field31_Name): Output Derived_Type_Link. + * einfo.ads: New field Derived_Type_Link. + * exp_ch6.adb (Expand_Call): Warn if change of representation + needed on call. + * sem_ch13.adb: Minor addition of ??? comment. + (Rep_Item_Too_Late): Warn on case that is legal but could cause an + expensive implicit conversion. + * sem_ch3.adb (Build_Derived_Type): Set Derived_Type_Link if needed. + +2014-07-29 Hristian Kirtchev + + * exp_ch3.adb (Build_Init_Procedure): Renamed Local_DF_Id + to DF_Id. Add new local variable DF_Call. Do not perform any + elaboration-related checks on the call to the partial finalization + routine within an init proc to avoid generating bogus elaboration + warnings on expansion-related code. + * sem_elab.adb (Check_A_Call): Move constant Access_Case to + the top level of the routine. Ensure that Output_Calls takes + into account flags -gnatel and -gnatwl when emitting warnings + or info messages. + (Check_Internal_Call_Continue): Update the call to Output_Calls. + (Elab_Warning): Moved to the top level of routine Check_A_Call. + (Emit): New routines. + (Output_Calls): Add new formal parameter Check_Elab_Flag along with a + comment on usage. Output all warnings or info messages only when the + caller context demands it and the proper elaboration flag is set. + +2014-07-29 Yannick Moy + + * sem_attr.adb (Analyze_Attribute/Attribute_Old): + Check rule about Old appearing in potentially unevaluated + expression everywhere, not only in Post. + +2014-07-29 Arnaud Charlet + + * sem_prag.adb: Update comment. + * a-except.adb, a-except-2005.adb: Minor editing. + +2014-07-29 Pierre-Marie Derodat + + * exp_dbug.adb (Debug_Renaming_Declaration): + Do not create renaming entities for renamings of non-packed + objects and for exceptions. + +2014-07-29 Robert Dewar + * sem_ch3.adb, sinfo.ads, types.ads, sem_prag.adb, a-except-2005.adb, sem_ch6.adb, par-ch3.adb: Minor reformatting. diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 168a619..2cedb83 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -404,17 +404,6 @@ package body Ada.Exceptions is -- attached. The parameters are the file name and line number in each -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. - -- Note on ordering of these routines. Normally in the Ada.Exceptions units - -- we don't care about the ordering of entries for Rcheck routines, and - -- the normal approach is to keep them in the same order as declarations - -- in Types. - - -- This section is an IMPORTANT EXCEPTION. It is essential that the - -- routines in this section be declared in the same order as the Rmsg_xx - -- constants in the following section. This is required by the .Net runtime - -- which uses the exceptmsg.awk script to generate require exception data, - -- and this script requires and expects that this ordering rule holds. - procedure Rcheck_CE_Access_Check (File : System.Address; Line : Integer); procedure Rcheck_CE_Null_Access_Parameter diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 6163204..dbde478 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -360,6 +360,17 @@ package body Ada.Exceptions is -- attached. The parameters are the file name and line number in each -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. + -- Note on ordering of these routines. Normally in the Ada.Exceptions units + -- we don't care about the ordering of entries for Rcheck routines, and + -- the normal approach is to keep them in the same order as declarations + -- in Types. + + -- This section is an IMPORTANT EXCEPTION. It is essential that the + -- routines in this section be declared in the same order as the Rmsg_xx + -- constants in the following section. This is required by the .Net runtime + -- which uses the exceptmsg.awk script to generate require exception data, + -- and this script requires and expects that this ordering rule holds. + procedure Rcheck_CE_Access_Check (File : System.Address; Line : Integer); procedure Rcheck_CE_Null_Access_Parameter @@ -418,8 +429,6 @@ package body Ada.Exceptions is (File : System.Address; Line : Integer); procedure Rcheck_PE_Potentially_Blocking_Operation (File : System.Address; Line : Integer); - procedure Rcheck_PE_Stream_Operation_Not_Allowed - (File : System.Address; Line : Integer); procedure Rcheck_PE_Stubbed_Subprogram_Called (File : System.Address; Line : Integer); procedure Rcheck_PE_Unchecked_Union_Restriction @@ -432,6 +441,8 @@ package body Ada.Exceptions is (File : System.Address; Line : Integer); procedure Rcheck_SE_Object_Too_Large (File : System.Address; Line : Integer); + procedure Rcheck_PE_Stream_Operation_Not_Allowed + (File : System.Address; Line : Integer); procedure Rcheck_PE_Finalize_Raised_Exception (File : System.Address; Line : Integer); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 80f5be0..c815c18 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -249,6 +249,7 @@ package body Einfo is -- Last_Aggregate_Assignment Node30 -- Static_Initialization Node30 + -- Derived_Type_Link Node31 -- Thunk_Entity Node31 -- SPARK_Pragma Node32 @@ -949,6 +950,12 @@ package body Einfo is return Flag14 (Id); end Depends_On_Private; + function Derived_Type_Link (Id : E) return E is + begin + pragma Assert (Is_Type (Id)); + return Node31 (Base_Type (Id)); + end Derived_Type_Link; + function Digits_Value (Id : E) return U is begin pragma Assert @@ -3682,6 +3689,12 @@ package body Einfo is Set_Flag14 (Id, V); end Set_Depends_On_Private; + procedure Set_Derived_Type_Link (Id : E; V : E) is + begin + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); + Set_Node31 (Id, V); + end Set_Derived_Type_Link; + procedure Set_Digits_Value (Id : E; V : U) is begin pragma Assert @@ -9596,6 +9609,9 @@ package body Einfo is E_Function => Write_Str ("Thunk_Entity"); + when Type_Kind => + Write_Str ("Derived_Type_Link"); + when others => Write_Str ("Field31??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6065d19..fb64097 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -819,6 +819,28 @@ package Einfo is -- Defined in all type entities. Set if the type is private or if it -- depends on a private type. +-- Derived_Type_Link (Node31) +-- Defined in all type and subtype entries. Set in a base type if +-- a derived type declaration is encountered which derives from +-- this base type or one of its subtypes, and there are already +-- primitive operations declared. In this case, it references the +-- entity for the type declared by the derived type declaration. +-- For example: +-- +-- type R is ... +-- subtype RS is R ... +-- ... +-- type G is new RS ... +-- +-- In this case, if primitive operations have been declared for R, at +-- the point of declaration of G, then the Derived_Type_Link of R is set +-- to point to the entity for G. This is used to generate warnings for +-- rep clauses that appear later on for R, which might result in an +-- unexpected implicit conversion operation. +-- +-- Note: if there is more than one such derived type, the link will point +-- to the last one (this is only used in generating warning messages). + -- Designated_Type (synthesized) -- Applies to access types. Returns the designated type. Differs from -- Directly_Designated_Type in that if the access type refers to an @@ -5199,6 +5221,7 @@ package Einfo is -- Related_Expression (Node24) -- Current_Use_Clause (Node27) -- Subprograms_For_Type (Node29) + -- Derived_Type_Link (Node31) -- Linker_Section_Pragma (Node33) -- Depends_On_Private (Flag14) @@ -6461,6 +6484,7 @@ package Einfo is function Delta_Value (Id : E) return R; function Dependent_Instances (Id : E) return L; function Depends_On_Private (Id : E) return B; + function Derived_Type_Link (Id : E) return E; function Digits_Value (Id : E) return U; function Direct_Primitive_Operations (Id : E) return L; function Directly_Designated_Type (Id : E) return E; @@ -7095,6 +7119,7 @@ package Einfo is procedure Set_Delta_Value (Id : E; V : R); procedure Set_Dependent_Instances (Id : E; V : L); procedure Set_Depends_On_Private (Id : E; V : B := True); + procedure Set_Derived_Type_Link (Id : E; V : E); procedure Set_Digits_Value (Id : E; V : U); procedure Set_Direct_Primitive_Operations (Id : E; V : L); procedure Set_Directly_Designated_Type (Id : E; V : E); @@ -7841,6 +7866,7 @@ package Einfo is pragma Inline (Delta_Value); pragma Inline (Dependent_Instances); pragma Inline (Depends_On_Private); + pragma Inline (Derived_Type_Link); pragma Inline (Digits_Value); pragma Inline (Direct_Primitive_Operations); pragma Inline (Directly_Designated_Type); @@ -8322,6 +8348,7 @@ package Einfo is pragma Inline (Set_Delta_Value); pragma Inline (Set_Dependent_Instances); pragma Inline (Set_Depends_On_Private); + pragma Inline (Set_Derived_Type_Link); pragma Inline (Set_Digits_Value); pragma Inline (Set_Direct_Primitive_Operations); pragma Inline (Set_Directly_Designated_Type); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index ae9f911..5a6b0f9 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2596,7 +2596,7 @@ package body Exp_Ch3 is Set_Statements (Handled_Stmt_Node, Body_Stmts); -- Generate: - -- Local_DF_Id (_init, C1, ..., CN); + -- Deep_Finalize (_init, C1, ..., CN); -- raise; if Counter > 0 @@ -2605,30 +2605,36 @@ package body Exp_Ch3 is and then not Restriction_Active (No_Exception_Propagation) then declare - Local_DF_Id : Entity_Id; + DF_Call : Node_Id; + DF_Id : Entity_Id; begin -- Create a local version of Deep_Finalize which has indication -- of partial initialization state. - Local_DF_Id := Make_Temporary (Loc, 'F'); + DF_Id := Make_Temporary (Loc, 'F'); - Append_To (Decls, - Make_Local_Deep_Finalize (Rec_Type, Local_DF_Id)); + Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id)); + + DF_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (DF_Id, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_uInit), + New_Occurrence_Of (Standard_False, Loc))); + + -- Do not emit warnings related to the elaboration order when a + -- controlled object is declared before the body of Finalize is + -- seen. + + Set_No_Elaboration_Check (DF_Call); Set_Exception_Handlers (Handled_Stmt_Node, New_List ( Make_Exception_Handler (Loc, Exception_Choices => New_List ( Make_Others_Choice (Loc)), - - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Local_DF_Id, Loc), - Parameter_Associations => New_List ( - Make_Identifier (Loc, Name_uInit), - New_Occurrence_Of (Standard_False, Loc))), - + Statements => New_List ( + DF_Call, Make_Raise_Statement (Loc))))); end; else diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 703a427..2e4ef82 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3705,19 +3705,27 @@ package body Exp_Ch6 is Resolve (Actual, Parent_Typ); end if; + -- If there is a change of representation, then generate a + -- warning, and do the change of representation. + + elsif not Same_Representation (Formal_Typ, Parent_Typ) then + Error_Msg_N + ("??change of representation required", Actual); + Convert (Actual, Parent_Typ); + -- For array and record types, the parent formal type and -- derived formal type have different sizes or pragma Pack -- status. elsif ((Is_Array_Type (Formal_Typ) - and then Is_Array_Type (Parent_Typ)) + and then Is_Array_Type (Parent_Typ)) or else (Is_Record_Type (Formal_Typ) - and then Is_Record_Type (Parent_Typ))) + and then Is_Record_Type (Parent_Typ))) and then (Esize (Formal_Typ) /= Esize (Parent_Typ) - or else Has_Pragma_Pack (Formal_Typ) /= - Has_Pragma_Pack (Parent_Typ)) + or else Has_Pragma_Pack (Formal_Typ) /= + Has_Pragma_Pack (Parent_Typ)) then Convert (Actual, Parent_Typ); end if; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index e184cb6..5e0d614 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -306,6 +306,16 @@ package body Exp_Dbug is Obj : Entity_Id; Res : Node_Id; + Enable : Boolean := Nkind (N) = N_Package_Renaming_Declaration; + -- By default, we do not generate an encoding for renaming. This is + -- however done (in which case this is set to True) in a few cases: + -- - when a package is renamed, + -- - when the renaming involves a packed array, + -- - when the renaming involves a packed record. + + procedure Enable_If_Packed_Array (N : Node_Id); + -- Enable encoding generation if N is a packed array + function Output_Subscript (N : Node_Id; S : String) return Boolean; -- Outputs a single subscript value as ?nnn (subscript is compile time -- known value with value nnn) or as ?e (subscript is local constant @@ -314,6 +324,21 @@ package body Exp_Dbug is -- output in one of these two forms. The result is prepended to the -- name stored in Name_Buffer. + ---------------------------- + -- Enable_If_Packed_Array -- + ---------------------------- + + procedure Enable_If_Packed_Array (N : Node_Id) is + T : constant Entity_Id := Etype (N); + begin + Enable := + (Enable + or else + (Ekind (T) in Array_Kind + and then + Present (Packed_Array_Impl_Type (T)))); + end Enable_If_Packed_Array; + ---------------------- -- Output_Subscript -- ---------------------- @@ -372,6 +397,8 @@ package body Exp_Dbug is exit; when N_Selected_Component => + Enable := + Enable or else Is_Packed (Etype (Prefix (Ren))); Prepend_String_To_Buffer (Get_Name_String (Chars (Selector_Name (Ren)))); Prepend_String_To_Buffer ("XR"); @@ -382,6 +409,7 @@ package body Exp_Dbug is X : Node_Id := Last (Expressions (Ren)); begin + Enable_If_Packed_Array (Prefix (Ren)); while Present (X) loop if not Output_Subscript (X, "XS") then Set_Materialize_Entity (Ent); @@ -396,6 +424,7 @@ package body Exp_Dbug is when N_Slice => + Enable_If_Packed_Array (Prefix (Ren)); Typ := Etype (First_Index (Etype (Nam))); if not Output_Subscript (Type_High_Bound (Typ), "XS") then @@ -422,6 +451,13 @@ package body Exp_Dbug is end case; end loop; + -- If we found no reason here to emit an encoding, stop now. + + if not Enable then + Set_Materialize_Entity (Ent); + return Empty; + end if; + Prepend_String_To_Buffer ("___XE"); -- Include the designation of the form of renaming diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 0495c7c..09ab607 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4564,25 +4564,11 @@ package body Sem_Attr is -- Ensure that the obtained expression is the consequence of a -- contract case as this is the only postcondition-like part of - -- the pragma. + -- the pragma. Otherwise, attribute 'Old appears in the condition + -- of a contract case. Emit an error since this is not a + -- postcondition-like context. (SPARK RM 6.1.3(2)) - if Expr = Expression (Parent (Expr)) then - - -- Warn that a potentially unevaluated prefix is always - -- evaluated when the corresponding consequence is selected. - - if Is_Potentially_Unevaluated (P) then - Error_Msg_Name_1 := Aname; - Error_Msg_N - ("??prefix of attribute % is always evaluated when " - & "related consequence is selected", P); - end if; - - -- Attribute 'Old appears in the condition of a contract case. - -- Emit an error since this is not a postcondition-like context. - -- (SPARK RM 6.1.3(2)) - - else + if Expr /= Expression (Parent (Expr)) then Error_Attr ("attribute % cannot appear in the condition " & "of a contract case", P); @@ -4773,11 +4759,10 @@ package body Sem_Attr is ("??attribute Old applied to constant has no effect", P); end if; - -- Check that the prefix of 'Old is an entity, when it appears in - -- a postcondition and may be potentially unevaluated (6.1.1 (27/3)). + -- Check that the prefix of 'Old is an entity when it may be + -- potentially unevaluated (6.1.1 (27/3)). if Present (Prag) - and then Get_Pragma_Id (Prag) = Pragma_Postcondition and then Is_Potentially_Unevaluated (N) and then not Is_Entity_Name (P) then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e63d4dd..fc09f6f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -11074,6 +11074,9 @@ package body Sem_Ch13 is -- Note that neither of the above errors is considered a serious one, -- since the effect is simply that we ignore the representation clause -- in these cases. + -- Is this really true? In any case if we make this change we must + -- document the requirement in the spec of Rep_Item_Too_Late that + -- if True is returned, then the rep item must be completely ignored??? ---------------------- -- No_Type_Rep_Item -- @@ -11122,8 +11125,10 @@ package body Sem_Ch13 is S := First_Subtype (T); if Present (Freeze_Node (S)) then - Error_Msg_NE - ("??no more representation items for }", Freeze_Node (S), S); + if not Relaxed_RM_Semantics then + Error_Msg_NE + ("??no more representation items for }", Freeze_Node (S), S); + end if; end if; return True; @@ -11142,18 +11147,68 @@ package body Sem_Ch13 is if Has_Primitive_Operations (Parent_Type) then No_Type_Rep_Item; - Error_Msg_NE - ("\parent type & has primitive operations!", N, Parent_Type); + + if not Relaxed_RM_Semantics then + Error_Msg_NE + ("\parent type & has primitive operations!", N, Parent_Type); + end if; + return True; elsif Is_By_Reference_Type (Parent_Type) then No_Type_Rep_Item; - Error_Msg_NE - ("\parent type & is a by reference type!", N, Parent_Type); + + if not Relaxed_RM_Semantics then + Error_Msg_NE + ("\parent type & is a by reference type!", N, Parent_Type); + end if; + return True; end if; end if; + -- No error, but one more warning to consider. The RM (surprisingly) + -- allows this pattern: + + -- type S is ... + -- primitive operations for S + -- type R is new S; + -- rep clause for S + + -- Meaning that calls on the primitive operations of S for values of + -- type R may require possibly expensive implicit conversion operations. + -- This is not an error, but is worth a warning. + + if not Relaxed_RM_Semantics and then Is_Type (T) then + declare + DTL : constant Entity_Id := Derived_Type_Link (Base_Type (T)); + + begin + if Present (DTL) + and then Has_Primitive_Operations (Base_Type (T)) + + -- For now, do not generate this warning for the case of aspect + -- specification using Ada 2012 syntax, since we get wrong + -- messages we do not understand. The whole business of derived + -- types and rep items seems a bit confused when aspects are + -- used, since the aspects are not evaluated till freeze time. + + and then not From_Aspect_Specification (N) + then + Error_Msg_Sloc := Sloc (DTL); + Error_Msg_N + ("representation item for& appears after derived type " + & "declaration#??", N); + Error_Msg_NE + ("\may result in implicit conversions for primitive " + & "operations of&??", N, T); + Error_Msg_NE + ("\to change representations when called with arguments " + & "of type&??", N, DTL); + end if; + end; + end if; + -- No error, link item into head of chain of rep items for the entity, -- but avoid chaining if we have an overloadable entity, and the pragma -- is one that can apply to multiple overloaded entities. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9c70acb..506a4b0 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8503,6 +8503,12 @@ package body Sem_Ch3 is Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); + -- If the parent has primitive routines, set the derived type link + + if Has_Primitive_Operations (Parent_Type) then + Set_Derived_Type_Link (Parent_Base, Derived_Type); + end if; + -- If the parent type is a private subtype, the convention on the base -- type may be set in the private part, and not propagated to the -- subtype until later, so we obtain the convention from the base type. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index e8f68e5..adf5fd1 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -263,11 +263,15 @@ package body Sem_Elab is function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; -- Determine whether entity Id denotes a [Deep_]Finalize procedure - procedure Output_Calls (N : Node_Id); + procedure Output_Calls + (N : Node_Id; + Check_Elab_Flag : Boolean); -- Outputs chain of calls stored in the Elab_Call table. The caller has -- already generated the main warning message, so the warnings generated -- are all continuation messages. The argument is the call node at which - -- the messages are to be placed. + -- the messages are to be placed. When Check_Elab_Flag is set, calls are + -- enumerated only when flag Elab_Warning is set for the dynamic case or + -- when flag Elab_Info_Messages is set for the statis case. function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; -- Given two scopes, determine whether they are the same scope from an @@ -497,6 +501,48 @@ package body Sem_Elab is Generate_Warnings : Boolean := True; In_Init_Proc : Boolean := False) is + Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; + -- Indicates if we have Access attribute case + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id); + -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for + -- dynamic or static elaboration model), N and Ent. Msg_D is a real + -- warning (output if Msg_D is non-null and Elab_Warnings is set), + -- Msg_S is an info message (output if Elab_Info_Messages is set. + + ------------------ + -- Elab_Warning -- + ------------------ + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id) + is + begin + -- Dynamic elaboration checks, real warning + + if Dynamic_Elaboration_Checks then + if not Access_Case then + if Msg_D /= "" and then Elab_Warnings then + Error_Msg_NE (Msg_D, N, Ent); + end if; + end if; + + -- Static elaboration checks, info message + + else + if Elab_Info_Messages then + Error_Msg_NE (Msg_S, N, Ent); + end if; + end if; + end Elab_Warning; + + -- Local variables + Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; Decl : Node_Id; @@ -525,9 +571,6 @@ package body Sem_Elab is Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; -- Indicates if we have instantiation case - Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; - -- Indicates if we have Access attribute case - Caller_Unit_Internal : Boolean; Callee_Unit_Internal : Boolean; @@ -544,6 +587,8 @@ package body Sem_Elab is -- warnings on the scope are also suppressed. For the internal case, -- we ignore this flag. + -- Start of processing for Check_A_Call + begin -- If the call is known to be within a local Suppress Elaboration -- pragma, nothing to check. This can happen in task bodies. But @@ -873,101 +918,64 @@ package body Sem_Elab is and then (Elab_Warnings or Elab_Info_Messages) and then Generate_Warnings then - Generate_Elab_Warnings : declare - procedure Elab_Warning - (Msg_D : String; - Msg_S : String; - Ent : Node_Or_Entity_Id); - -- Generate a call to Error_Msg_NE with parameters Msg_D or - -- Msg_S (for dynamic or static elaboration model), N and Ent. - -- Msg_D is a real warning (output if Msg_D is non-null and - -- Elab_Warnings is set), Msg_S is an info message (output if - -- Elab_Info_Messages is set. - - ------------------ - -- Elab_Warning -- - ------------------ - - procedure Elab_Warning - (Msg_D : String; - Msg_S : String; - Ent : Node_Or_Entity_Id) - is - begin - -- Dynamic elaboration checks, real warning - - if Dynamic_Elaboration_Checks then - if not Access_Case then - if Msg_D /= "" and then Elab_Warnings then - Error_Msg_NE (Msg_D, N, Ent); - end if; - end if; + -- Instantiation case - -- Static elaboration checks, info message - - else - if Elab_Info_Messages then - Error_Msg_NE (Msg_S, N, Ent); - end if; - end if; - end Elab_Warning; - - -- Start of processing for Generate_Elab_Warnings + if Inst_Case then + Elab_Warning + ("instantiation of& may raise Program_Error?l?", + "info: instantiation of& during elaboration?$?", Ent); - begin - -- Instantiation case + -- Indirect call case, info message only in static elaboration + -- case, because the attribute reference itself cannot raise an + -- exception. - if Inst_Case then - Elab_Warning - ("instantiation of& may raise Program_Error?l?", - "info: instantiation of& during elaboration?$?", Ent); + elsif Access_Case then + Elab_Warning + ("", "info: access to& during elaboration?$?", Ent); - -- Indirect call case, info message only in static elaboration - -- case, because the attribute reference itself cannot raise - -- an exception. + -- Subprogram call case - elsif Access_Case then + else + if Nkind (Name (N)) in N_Has_Entity + and then Is_Init_Proc (Entity (Name (N))) + and then Comes_From_Source (Ent) + then Elab_Warning - ("", "info: access to& during elaboration?$?", Ent); - - -- Subprogram call case + ("implicit call to & may raise Program_Error?l?", + "info: implicit call to & during elaboration?$?", + Ent); else - if Nkind (Name (N)) in N_Has_Entity - and then Is_Init_Proc (Entity (Name (N))) - and then Comes_From_Source (Ent) - then - Elab_Warning - ("implicit call to & may raise Program_Error?l?", - "info: implicit call to & during elaboration?$?", - Ent); - - else - Elab_Warning - ("call to & may raise Program_Error?l?", - "info: call to & during elaboration?$?", - Ent); - end if; + Elab_Warning + ("call to & may raise Program_Error?l?", + "info: call to & during elaboration?$?", + Ent); end if; + end if; - Error_Msg_Qual_Level := Nat'Last; + Error_Msg_Qual_Level := Nat'Last; - if Nkind (N) in N_Subprogram_Instantiation then - Elab_Warning - ("\missing pragma Elaborate for&?l?", - "\implicit pragma Elaborate for& generated?$?", - W_Scope); + if Nkind (N) in N_Subprogram_Instantiation then + Elab_Warning + ("\missing pragma Elaborate for&?l?", + "\implicit pragma Elaborate for& generated?$?", + W_Scope); - else - Elab_Warning - ("\missing pragma Elaborate_All for&?l?", - "\implicit pragma Elaborate_All for & generated?$?", - W_Scope); - end if; - end Generate_Elab_Warnings; + else + Elab_Warning + ("\missing pragma Elaborate_All for&?l?", + "\implicit pragma Elaborate_All for & generated?$?", + W_Scope); + end if; Error_Msg_Qual_Level := 0; - Output_Calls (N); + + -- Take into account the flags related to elaboration warning + -- messages when enumerating the various calls involved. This + -- ensures the proper pairing of the main warning and the + -- clarification messages generated by Output_Calls. + + Output_Calls (N, Check_Elab_Flag => True); -- Set flag to prevent further warnings for same unit unless in -- All_Errors_Mode. @@ -2316,7 +2324,12 @@ package body Sem_Elab is Error_Msg_N ("\Program_Error ] False); end if; end if; @@ -3053,8 +3066,13 @@ package body Sem_Elab is -- Output_Calls -- ------------------ - procedure Output_Calls (N : Node_Id) is - Ent : Entity_Id; + procedure Output_Calls + (N : Node_Id; + Check_Elab_Flag : Boolean) + is + function Emit (Flag : Boolean) return Boolean; + -- Determine whether to emit an error message based on the combination + -- of flags Check_Elab_Flag and Flag. function Is_Printable_Error_Name (Nm : Name_Id) return Boolean; -- An internal function, used to determine if a name, Nm, is either @@ -3062,6 +3080,19 @@ package body Sem_Elab is -- by the error message circuits (i.e. it has a single upper -- case letter at the end). + ---------- + -- Emit -- + ---------- + + function Emit (Flag : Boolean) return Boolean is + begin + if Check_Elab_Flag then + return Flag; + else + return True; + end if; + end Emit; + ----------------------------- -- Is_Printable_Error_Name -- ----------------------------- @@ -3080,6 +3111,10 @@ package body Sem_Elab is end if; end Is_Printable_Error_Name; + -- Local variables + + Ent : Entity_Id; + -- Start of processing for Output_Calls begin @@ -3091,27 +3126,31 @@ package body Sem_Elab is -- Dynamic elaboration model, warnings controlled by -gnatwl if Dynamic_Elaboration_Checks then - if Is_Generic_Unit (Ent) then - Error_Msg_NE ("\\?l?& instantiated #", N, Ent); - elsif Is_Init_Proc (Ent) then - Error_Msg_N ("\\?l?initialization procedure called #", N); - elsif Is_Printable_Error_Name (Chars (Ent)) then - Error_Msg_NE ("\\?l?& called #", N, Ent); - else - Error_Msg_N ("\\?l?called #", N); + if Emit (Elab_Warnings) then + if Is_Generic_Unit (Ent) then + Error_Msg_NE ("\\?l?& instantiated #", N, Ent); + elsif Is_Init_Proc (Ent) then + Error_Msg_N ("\\?l?initialization procedure called #", N); + elsif Is_Printable_Error_Name (Chars (Ent)) then + Error_Msg_NE ("\\?l?& called #", N, Ent); + else + Error_Msg_N ("\\?l?called #", N); + end if; end if; -- Static elaboration model, info messages controlled by -gnatel else - if Is_Generic_Unit (Ent) then - Error_Msg_NE ("\\?$?& instantiated #", N, Ent); - elsif Is_Init_Proc (Ent) then - Error_Msg_N ("\\?$?initialization procedure called #", N); - elsif Is_Printable_Error_Name (Chars (Ent)) then - Error_Msg_NE ("\\?$?& called #", N, Ent); - else - Error_Msg_N ("\\?$?called #", N); + if Emit (Elab_Info_Messages) then + if Is_Generic_Unit (Ent) then + Error_Msg_NE ("\\?$?& instantiated #", N, Ent); + elsif Is_Init_Proc (Ent) then + Error_Msg_N ("\\?$?initialization procedure called #", N); + elsif Is_Printable_Error_Name (Chars (Ent)) then + Error_Msg_NE ("\\?$?& called #", N, Ent); + else + Error_Msg_N ("\\?$?called #", N); + end if; end if; end if; end loop; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index bc3468d..16b93ab 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -11022,7 +11022,9 @@ package body Sem_Prag is -- If Allow_Integer_Address is already set do nothing, otherwise -- calling RTE on RE_Address would cause a crash when loading - -- system.ads. + -- system.ads. ??? same will happen if Allow_Integer_Address is + -- not set actually, to be fixed and then the guard on + -- not Opt.Allow_Integer_Address should be removed. if not Opt.Allow_Integer_Address and then Is_Private_Type (RTE (RE_Address))