From: Arnaud Charlet Date: Fri, 1 Aug 2014 13:47:34 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=bf0b0e5ee1c756b593f8e8d0456504575ac63218;p=gcc.git [multiple changes] 2014-08-01 Hristian Kirtchev * sem_attr.adb (Analyze_Attribute): Preanalyze and resolve the prefix of attribute Loop_Entry. * sem_prag.adb (Analyze_Pragma): Verify the placement of pragma Loop_Variant with respect to an enclosing loop (if any). (Contains_Loop_Entry): Update the parameter profile and all calls to this routine. * sem_res.adb (Resolve_Call): Code reformatting. Do not ask for the corresponding body before determining the nature of the ultimate alias's declarative node. 2014-08-01 Robert Dewar * gnat1drv.adb, sem_ch4.adb: Minor reformatting. 2014-08-01 Robert Dewar * sem_eval.adb (Rewrite_In_Raise_CE): Don't try to reuse inner constraint error node since it is a list member. 2014-08-01 Robert Dewar * sem_warn.adb: Minor reformatting. 2014-08-01 Eric Botcazou * einfo.adb (Underlying_Type): Return the underlying full view of a private type if present. * freeze.adb (Freeze_Entity): Build a single freeze node for partial, full and underlying full views, if any. * gcc-interface/decl.c (gnat_to_gnu_entity) : Add a missing guard before the access to the Underlying_Full_View. * gcc-interface/trans.c (process_freeze_entity): Deal with underlying full view if present. * gcc-interface/utils.c (make_dummy_type): Avoid superfluous work. From-SVN: r213463 --- diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 84e7763721b..6afc37ceb3a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -8118,7 +8118,7 @@ package body Einfo is elsif Ekind (Id) in Incomplete_Or_Private_Kind then -- If we have an incomplete or private type with a full view, - -- then we return the Underlying_Type of this full view + -- then we return the Underlying_Type of this full view. if Present (Full_View (Id)) then if Id = Full_View (Id) then @@ -8131,6 +8131,14 @@ package body Einfo is return Underlying_Type (Full_View (Id)); end if; + -- If we have a private type with an underlying full view, then we + -- return the Underlying_Type of this underlying full view. + + elsif Ekind (Id) in Private_Kind + and then Present (Underlying_Full_View (Id)) + then + return Underlying_Type (Underlying_Full_View (Id)); + -- If we have an incomplete entity that comes from the limited -- view then we return the Underlying_Type of its non-limited -- view. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index b59e6ec29ea..9af48a8622e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4977,7 +4977,7 @@ package body Freeze is -- view, we can retrieve the full view, but not the reverse). -- However, in order to freeze correctly, we need to freeze the full -- view. If we are freezing at the end of a scope (or within the - -- scope of the private type), the partial and full views will have + -- scope) of the private type, the partial and full views will have -- been swapped, the full view appears first in the entity chain and -- the swapping mechanism ensures that the pointers are properly set -- (on scope exit). @@ -4987,6 +4987,11 @@ package body Freeze is -- set the pointers appropriately since we cannot rely on swapping to -- fix things up (subtypes in an outer scope might not get swapped). + -- If the full view is itself private, the above requirements apply + -- to the underlying full view instead of the full view. But there is + -- no swapping mechanism for the underlying full view so we need to + -- set the pointers appropriately in both cases. + elsif Is_Incomplete_Or_Private_Type (E) and then not Is_Generic_Type (E) then @@ -5025,28 +5030,44 @@ package body Freeze is if Is_Frozen (Full_View (E)) then Set_Has_Delayed_Freeze (E, False); Set_Freeze_Node (E, Empty); - Check_Debug_Info_Needed (E); -- Otherwise freeze full view and patch the pointers so that - -- the freeze node will elaborate both views in the back-end. + -- the freeze node will elaborate both views in the back end. + -- However, if full view is itself private, freeze underlying + -- full view instead and patch the pointer so that the freeze + -- node will elaborate the three views in the back end. else declare - Full : constant Entity_Id := Full_View (E); + Full : Entity_Id := Full_View (E); begin if Is_Private_Type (Full) and then Present (Underlying_Full_View (Full)) then - Freeze_And_Append - (Underlying_Full_View (Full), N, Result); + Full := Underlying_Full_View (Full); end if; Freeze_And_Append (Full, N, Result); - if Has_Delayed_Freeze (E) then + if Full /= Full_View (E) + and then Has_Delayed_Freeze (Full_View (E)) + then 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)); + + else + Set_Has_Delayed_Freeze (Full_View (E), False); + Set_Freeze_Node (Full_View (E), Empty); + end if; + end if; + + if Has_Delayed_Freeze (E) then + F_Node := Freeze_Node (Full_View (E)); + if Present (F_Node) then Set_Freeze_Node (E, F_Node); Set_Entity (F_Node, E); @@ -5060,10 +5081,10 @@ package body Freeze is end if; end if; end; - - Check_Debug_Info_Needed (E); end if; + Check_Debug_Info_Needed (E); + -- AI-117 requires that the convention of a partial view be the -- same as the convention of the full view. Note that this is a -- recognized breach of privacy, but it's essential for logical @@ -5090,6 +5111,35 @@ package body Freeze is return Result; + -- Case of underlying full view present + + elsif Is_Private_Type (E) + and then Present (Underlying_Full_View (E)) + then + if not Is_Frozen (Underlying_Full_View (E)) then + Freeze_And_Append (Underlying_Full_View (E), N, Result); + end if; + + -- Patch the pointers so that the freeze node will elaborate + -- both views in the back end. + + if Has_Delayed_Freeze (E) then + F_Node := Freeze_Node (Underlying_Full_View (E)); + + if Present (F_Node) then + Set_Freeze_Node (E, F_Node); + Set_Entity (F_Node, E); + + else + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + end if; + end if; + + Check_Debug_Info_Needed (E); + + return Result; + -- Case of no full view present. If entity is derived or subtype, -- it is safe to freeze, correctness depends on the frozen status -- of parent. Otherwise it is either premature usage, or a Taft diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 2145a477606..bf70486a823 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -4654,7 +4654,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) ? Non_Limited_View (gnat_entity) : Present (Full_View (gnat_entity)) ? Full_View (gnat_entity) - : Underlying_Full_View (gnat_entity); + : IN (kind, Private_Kind) + ? Underlying_Full_View (gnat_entity) + : Empty; /* If this is an incomplete type with no full view, it must be a Taft Amendment type, in which case we return a dummy type. Otherwise, diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 1b7d86100fe..64e428a5e33 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -7893,10 +7893,20 @@ process_freeze_entity (Node_Id gnat_node) if (gnu_old) { save_gnu_tree (gnat_entity, NULL_TREE, false); + if (IN (kind, Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity)) - && present_gnu_tree (Full_View (gnat_entity))) - save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false); + && Present (Full_View (gnat_entity))) + { + Entity_Id full_view = Full_View (gnat_entity); + + if (IN (Ekind (full_view), Private_Kind) + && Present (Underlying_Full_View (full_view))) + full_view = Underlying_Full_View (full_view); + + if (present_gnu_tree (full_view)) + save_gnu_tree (full_view, NULL_TREE, false); + } + if (IN (kind, Type_Kind) && Present (Class_Wide_Type (gnat_entity)) && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity) @@ -7906,17 +7916,23 @@ process_freeze_entity (Node_Id gnat_node) if (IN (kind, Incomplete_Or_Private_Kind) && Present (Full_View (gnat_entity))) { - gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1); + Entity_Id full_view = Full_View (gnat_entity); + + if (IN (Ekind (full_view), Private_Kind) + && Present (Underlying_Full_View (full_view))) + full_view = Underlying_Full_View (full_view); + + gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, 1); /* Propagate back-annotations from full view to partial view. */ if (Unknown_Alignment (gnat_entity)) - Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity))); + Set_Alignment (gnat_entity, Alignment (full_view)); if (Unknown_Esize (gnat_entity)) - Set_Esize (gnat_entity, Esize (Full_View (gnat_entity))); + Set_Esize (gnat_entity, Esize (full_view)); if (Unknown_RM_Size (gnat_entity)) - Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity))); + Set_RM_Size (gnat_entity, RM_Size (full_view)); /* The above call may have defined this entity (the simplest example of this is when we have a private enumeral type since the bounds diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index f450f24ed9d..f44bda335d2 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -328,35 +328,31 @@ present_gnu_tree (Entity_Id gnat_entity) tree make_dummy_type (Entity_Id gnat_type) { - Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type); + Entity_Id gnat_equiv = Gigi_Equivalent_Type (Underlying_Type (gnat_type)); tree gnu_type; - /* If there is an equivalent type, get its underlying type. */ - if (Present (gnat_underlying)) - gnat_underlying = Gigi_Equivalent_Type (Underlying_Type (gnat_underlying)); - /* If there was no equivalent type (can only happen when just annotating types) or underlying type, go back to the original type. */ - if (No (gnat_underlying)) - gnat_underlying = gnat_type; + if (No (gnat_equiv)) + gnat_equiv = gnat_type; /* If it there already a dummy type, use that one. Else make one. */ - if (PRESENT_DUMMY_NODE (gnat_underlying)) - return GET_DUMMY_NODE (gnat_underlying); + if (PRESENT_DUMMY_NODE (gnat_equiv)) + return GET_DUMMY_NODE (gnat_equiv); /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make an ENUMERAL_TYPE. */ - gnu_type = make_node (Is_Record_Type (gnat_underlying) - ? tree_code_for_record_type (gnat_underlying) + gnu_type = make_node (Is_Record_Type (gnat_equiv) + ? tree_code_for_record_type (gnat_equiv) : ENUMERAL_TYPE); TYPE_NAME (gnu_type) = get_entity_name (gnat_type); TYPE_DUMMY_P (gnu_type) = 1; TYPE_STUB_DECL (gnu_type) = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type); - if (Is_By_Reference_Type (gnat_underlying)) + if (Is_By_Reference_Type (gnat_equiv)) TYPE_BY_REFERENCE_P (gnu_type) = 1; - SET_DUMMY_NODE (gnat_underlying, gnu_type); + SET_DUMMY_NODE (gnat_equiv, gnu_type); return gnu_type; } diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 4650548b5f0..2ed77553418 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -872,7 +872,6 @@ begin if Operating_Mode /= Check_Syntax then -- Acquire target parameters from system.ads (package System source) - -- System). Targparm_Acquire : declare use Sinput; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 904595e2fbd..e3e9f5aaa49 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4027,24 +4027,24 @@ package body Sem_Attr is and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id then Error_Attr_P - ("prefix of attribute % that applies to " - & "outer loop must denote an entity"); + ("prefix of attribute % that applies to outer loop must denote " + & "an entity"); elsif Is_Potentially_Unevaluated (P) then Uneval_Old_Msg; end if; - -- Finally, if the Loop_Entry attribute appears within a pragma - -- that is ignored, we replace P'Loop_Entity by P to avoid useless - -- generation of the loop entity variable. Note that in this case - -- the expression won't be executed anyway, and this substitution - -- keeps types happy! - - -- We should really do this in the expander, but it's easier here + -- Replace the Loop_Entry attribute reference by its prefix if the + -- related pragma is ignored. This transformation is OK with respect + -- to typing because Loop_Entry's type is that of its prefix. This + -- early transformation also avoids the generation of a useless loop + -- entry constant. if Is_Ignored (Enclosing_Pragma) then Rewrite (N, Relocate_Node (P)); end if; + + Preanalyze_And_Resolve (P); end Loop_Entry; ------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 26496dfbba9..332bd28be3c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1441,6 +1441,8 @@ package body Sem_Ch4 is if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then return; + -- Special casee message for character literal + elsif Exp_Btype = Any_Character then Error_Msg_N ("character literal as case expression is ambiguous", Expr); @@ -1448,8 +1450,9 @@ package body Sem_Ch4 is end if; if Etype (N) = Any_Type and then Present (Wrong_Alt) then - Error_Msg_N ("type incompatible with that of previous alternatives", - Expression (Wrong_Alt)); + Error_Msg_N + ("type incompatible with that of previous alternatives", + Expression (Wrong_Alt)); return; end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 640aaa67341..3e5458f2982 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -5465,13 +5465,6 @@ package body Sem_Eval is then Set_Condition (Parent (N), Empty); - -- If the expression raising CE is a N_Raise_CE node, we can use that - -- one. We just preserve the type of the context. - - elsif Nkind (Exp) = N_Raise_Constraint_Error then - Rewrite (N, Exp); - Set_Etype (N, Typ); - -- Else build an explicit N_Raise_CE else diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index da089301e41..5a3a255a441 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10926,20 +10926,17 @@ package body Sem_Prag is Pragma_Assume | Pragma_Loop_Invariant => Assert : declare - Expr : Node_Id; - Newa : List_Id; - - Has_Loop_Entry : Boolean; - -- Set True by - - function Contains_Loop_Entry return Boolean; - -- Tests if Expr contains a Loop_Entry attribute reference + function Contains_Loop_Entry (Expr : Node_Id) return Boolean; + -- Determine whether expression Expr contains a Loop_Entry + -- attribute reference. ------------------------- -- Contains_Loop_Entry -- ------------------------- - function Contains_Loop_Entry return Boolean is + function Contains_Loop_Entry (Expr : Node_Id) return Boolean is + Has_Loop_Entry : Boolean := False; + function Process (N : Node_Id) return Traverse_Result; -- Process function for traversal to look for Loop_Entry @@ -10964,11 +10961,15 @@ package body Sem_Prag is -- Start of processing for Contains_Loop_Entry begin - Has_Loop_Entry := False; Traverse (Expr); return Has_Loop_Entry; end Contains_Loop_Entry; + -- Local variables + + Expr : Node_Id; + Newa : List_Id; + -- Start of processing for Assert begin @@ -10989,17 +10990,19 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, Name_Check); Expr := Get_Pragma_Arg (Arg1); - -- Special processing for Loop_Invariant or for other cases if - -- a Loop_Entry attribute is present. + -- Special processing for Loop_Invariant, Loop_Variant or for + -- other cases where a Loop_Entry attribute is present. If the + -- assertion pragma contains attribute Loop_Entry, ensure that + -- the related pragma is within a loop. if Prag_Id = Pragma_Loop_Invariant - or else Contains_Loop_Entry + or else Prag_Id = Pragma_Loop_Variant + or else Contains_Loop_Entry (Expr) then - -- Check restricted placement, must be within a loop - Check_Loop_Pragma_Placement; - -- Do preanalyze to deal with embedded Loop_Entry attribute + -- Perform preanalysis to deal with embedded Loop_Entry + -- attributes. Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean); end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 92c8bfaa2ef..9509b230860 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5371,15 +5371,6 @@ package body Sem_Res is ------------------ procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Subp : constant Node_Id := Name (N); - Nam : Entity_Id; - I : Interp_Index; - It : Interp; - Norm_OK : Boolean; - Scop : Entity_Id; - Rtype : Entity_Id; - function Same_Or_Aliased_Subprograms (S : Entity_Id; E : Entity_Id) return Boolean; @@ -5399,6 +5390,20 @@ package body Sem_Res is return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); end Same_Or_Aliased_Subprograms; + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Subp : constant Node_Id := Name (N); + Body_Id : Entity_Id; + I : Interp_Index; + It : Interp; + Nam : Entity_Id; + Nam_Decl : Node_Id; + Nam_UA : Entity_Id; + Norm_OK : Boolean; + Rtype : Entity_Id; + Scop : Entity_Id; + -- Start of processing for Resolve_Call begin @@ -6218,21 +6223,16 @@ package body Sem_Res is and then Is_Overloadable (Nam) and then not Inside_A_Generic then - -- Retrieve the body to inline from the ultimate alias of Nam, if - -- there is one, otherwise calls that should be inlined end up not - -- being inlined. + Nam_UA := Ultimate_Alias (Nam); + Nam_Decl := Unit_Declaration_Node (Nam_UA); - declare - Nam_UA : constant Entity_Id := Ultimate_Alias (Nam); - Decl : constant Node_Id := Unit_Declaration_Node (Nam_UA); - Body_Id : constant Entity_Id := Corresponding_Body (Decl); + if Nkind (Nam_Decl) = N_Subprogram_Declaration then + Body_Id := Corresponding_Body (Nam_Decl); - begin - -- If the subprogram is not eligible for inlining in GNATprove - -- mode, do nothing. + -- Nothing to do if the subprogram is not eligible for inlining in + -- GNATprove mode. - if Nkind (Decl) /= N_Subprogram_Declaration - or else not Is_Inlined_Always (Nam_UA) + if not Is_Inlined_Always (Nam_UA) or else not Can_Be_Inlined_In_GNATprove_Mode (Nam_UA, Body_Id) then null; @@ -6262,7 +6262,7 @@ package body Sem_Res is -- the subprogram is not suitable for inlining in GNATprove -- mode. - elsif No (Body_To_Inline (Decl)) then + elsif No (Body_To_Inline (Nam_Decl)) then null; -- Calls cannot be inlined inside potentially unevaluated @@ -6281,7 +6281,7 @@ package body Sem_Res is Expand_Inlined_Call (N, Nam_UA, Nam); end if; end if; - end; + end if; end if; Warn_On_Overlapping_Actuals (Nam, N); diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 3971cccd836..d52e2d7d852 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -820,9 +820,9 @@ package body Sem_Warn is raise Program_Error; end Body_Formal; - ----------------------------------- - -- May_Need_Initialized_Actual -- - ----------------------------------- + --------------------------------- + -- May_Need_Initialized_Actual -- + --------------------------------- procedure May_Need_Initialized_Actual (Ent : Entity_Id) is T : constant Entity_Id := Etype (Ent);