From f715a5bd3fb6bb70c11b29dc2b54f2459ed36bfb Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 16 Mar 2020 19:28:47 +0100 Subject: [PATCH] [Ada] Consolidate handling of implicit dereferences into semantic analysis 2020-06-11 Eric Botcazou gcc/ada/ * checks.adb (Build_Discriminant_Checks): Build an explicit dereference when the type is an access type. * exp_atag.adb (Build_CW_Membership): Add explicit dereferences. (Build_Get_Access_Level): Likewise. (Build_Get_Alignment): Likewise. (Build_Inherit_Prims): Likewise. (Build_Get_Transportable): Likewise. (Build_Set_Size_Function): Likewise. * exp_ch3.adb (Build_Offset_To_Top_Function): Likewise. * exp_ch4.adb (Expand_Allocator_Expression): Likewise. (Expand_N_Indexed_Component ): Remove code dealing with implicit dereferences. (Expand_N_Selected_Component): Likewise. (Expand_N_Slice): Likewise. * exp_ch9.adb (Add_Formal_Renamings): Add explicit dereference. (Expand_Accept_Declarations): Likewise. (Build_Simple_Entry_Call): Remove code dealing with implicit dereferences. (Expand_N_Requeue_Statement): Likewise. * exp_disp.adb (Expand_Dispatching_Call): Build an explicit dereference when the controlling type is an access type. * exp_spark.adb (Expand_SPARK_N_Selected_Component): Delete. (Expand_SPARK_N_Slice_Or_Indexed_Component): Likewise. (Expand_SPARK): Do not call them. * sem_ch4.adb (Process_Implicit_Dereference_Prefix): Delete. (Process_Indexed_Component): Call Implicitly_Designated_Type to get the designated type for an implicit dereference. (Analyze_Overloaded_Selected_Component): Do not insert an explicit dereference here. (Analyze_Selected_Component): Likewise. (Analyze_Slice): Call Implicitly_Designated_Type to get the designated type for an implicit dereference. * sem_ch8.adb (Has_Components): New predicate extracted from... (Is_Appropriate_For_Record): ...this. Delete. (Is_Appropriate_For_Entry_Prefix): Likewise. (Analyze_Renamed_Entry): Deal with implicit dereferences. (Find_Selected_Component): Do not insert an explicit dereference here. Call Implicitly_Designated_Type to get the designated type for an implicit dereference. Call Has_Components, Is_Task_Type and Is_Protected_Type directly. Adjust test for error. * sem_res.adb (Resolve_Implicit_Dereference): New procedure. (Resolve_Call): Call Resolve_Indexed_Component last. (Resolve_Entry): Call Resolve_Implicit_Dereference on the prefix. (Resolve_Indexed_Component): Call Implicitly_Designated_Type to get the designated type for an implicit dereference and Resolve_Implicit_Dereference on the prefix at the end. (Resolve_Selected_Component): Likewise. (Resolve_Slice): Likewise. Do not apply access checks here. * sem_util.ads (Implicitly_Designated_Type): Declare. * sem_util.adb (Copy_And_Maybe_Dereference): Simplify. (Implicitly_Designated_Type): New function. (Object_Access_Level): Fix typo. * sem_warn.adb (Check_Unset_Reference): Test Comes_From_Source on the original node. --- gcc/ada/checks.adb | 9 +++ gcc/ada/exp_atag.adb | 39 ++++++++---- gcc/ada/exp_ch3.adb | 5 +- gcc/ada/exp_ch4.adb | 53 ++-------------- gcc/ada/exp_ch9.adb | 28 +++------ gcc/ada/exp_disp.adb | 8 +++ gcc/ada/exp_spark.adb | 50 --------------- gcc/ada/sem_ch4.adb | 111 +++------------------------------ gcc/ada/sem_ch8.adb | 140 ++++++++---------------------------------- gcc/ada/sem_res.adb | 52 ++++++++++++---- gcc/ada/sem_util.adb | 38 +++++++++--- gcc/ada/sem_util.ads | 5 ++ gcc/ada/sem_warn.adb | 2 +- 13 files changed, 174 insertions(+), 366 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index ae62a9d6aae..641a5b28174 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -3964,6 +3964,15 @@ package body Checks is Duplicate_Subexpr_No_Checks (Aggregate_Discriminant_Val (Disc_Ent)); + elsif Is_Access_Type (Etype (N)) then + Dref := + Make_Selected_Component (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Duplicate_Subexpr_No_Checks (N, Name_Req => True)), + Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent))); + + Set_Is_In_Discriminant_Check (Dref); else Dref := Make_Selected_Component (Loc, diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index b7bbc206548..bdd3f055f81 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -229,14 +229,18 @@ package body Exp_Atag is Make_Op_Subtract (Loc, Left_Opnd => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj_TSD, Loc), + Prefix => + Make_Explicit_Dereference (Loc, + New_Occurrence_Of (Obj_TSD, Loc)), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)), Right_Opnd => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Typ_TSD, Loc), + Prefix => + Make_Explicit_Dereference (Loc, + New_Occurrence_Of (Typ_TSD, Loc)), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)))), @@ -255,7 +259,9 @@ package body Exp_Atag is Make_Indexed_Component (Loc, Prefix => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj_TSD, Loc), + Prefix => + Make_Explicit_Dereference (Loc, + New_Occurrence_Of (Obj_TSD, Loc)), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Tags_Table), Loc)), @@ -293,8 +299,9 @@ package body Exp_Atag is return Make_Selected_Component (Loc, Prefix => - Build_TSD (Loc, - Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Make_Explicit_Dereference (Loc, + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node))), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)); @@ -311,8 +318,10 @@ package body Exp_Atag is begin return Make_Selected_Component (Loc, - Prefix => - Build_TSD (Loc, Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Prefix => + Make_Explicit_Dereference (Loc, + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node))), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Alignment), Loc)); end Build_Get_Alignment; @@ -639,7 +648,8 @@ package body Exp_Atag is Prefix => Make_Selected_Component (Loc, Prefix => - Build_DT (Loc, New_Tag_Node), + Make_Explicit_Dereference (Loc, + Build_DT (Loc, New_Tag_Node)), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), @@ -651,7 +661,8 @@ package body Exp_Atag is Prefix => Make_Selected_Component (Loc, Prefix => - Build_DT (Loc, Old_Tag_Node), + Make_Explicit_Dereference (Loc, + Build_DT (Loc, Old_Tag_Node)), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Prims_Ptr), Loc)), @@ -728,8 +739,9 @@ package body Exp_Atag is return Make_Selected_Component (Loc, Prefix => - Build_TSD (Loc, - Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Make_Explicit_Dereference (Loc, + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node))), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Transportable), Loc)); @@ -884,8 +896,9 @@ package body Exp_Atag is Name => Make_Selected_Component (Loc, Prefix => - Build_TSD (Loc, - Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Make_Explicit_Dereference (Loc, + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node))), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Size_Func), Loc)), diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f412debb65c..7d13cd6cd2b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2257,8 +2257,9 @@ package body Exp_Ch3 is Prefix => Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To (Acc_Type, - Make_Identifier (Loc, Name_uO)), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Acc_Type, + Make_Identifier (Loc, Name_uO))), Selector_Name => New_Occurrence_Of (Iface_Comp, Loc)), Attribute_Name => Name_Position)))))); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d416c06a8fe..7a84215366f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1073,7 +1073,9 @@ package body Exp_Ch4 is elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then TagT := T; - TagR := New_Occurrence_Of (Temp, Loc); + TagR := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc)); elsif Is_Private_Type (T) and then Is_Tagged_Type (Underlying_Type (T)) @@ -6868,7 +6870,6 @@ package body Exp_Ch4 is Typ : constant Entity_Id := Etype (N); P : constant Node_Id := Prefix (N); T : constant Entity_Id := Etype (P); - Atp : Entity_Id; begin -- A special optimization, if we have an indexed component that is @@ -6917,20 +6918,6 @@ package body Exp_Ch4 is Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P); end if; - -- If the prefix is an access type, then we unconditionally rewrite if - -- as an explicit dereference. This simplifies processing for several - -- cases, including packed array cases and certain cases in which checks - -- must be generated. We used to try to do this only when it was - -- necessary, but it cleans up the code to do it all the time. - - if Is_Access_Type (T) then - Insert_Explicit_Dereference (P); - Analyze_And_Resolve (P, Designated_Type (T)); - Atp := Designated_Type (T); - else - Atp := T; - end if; - -- Generate index and validity checks Generate_Index_Checks (N); @@ -6942,8 +6929,8 @@ package body Exp_Ch4 is -- If selecting from an array with atomic components, and atomic sync -- is not suppressed for this array type, set atomic sync flag. - if (Has_Atomic_Components (Atp) - and then not Atomic_Synchronization_Disabled (Atp)) + if (Has_Atomic_Components (T) + and then not Atomic_Synchronization_Disabled (T)) or else (Is_Atomic (Typ) and then not Atomic_Synchronization_Disabled (Typ)) or else (Is_Entity_Name (P) @@ -10580,7 +10567,7 @@ package body Exp_Ch4 is Par : constant Node_Id := Parent (N); P : constant Node_Id := Prefix (N); S : constant Node_Id := Selector_Name (N); - Ptyp : Entity_Id := Underlying_Type (Etype (P)); + Ptyp : constant Entity_Id := Underlying_Type (Etype (P)); Disc : Entity_Id; New_N : Node_Id; Dcon : Elmt_Id; @@ -10631,21 +10618,6 @@ package body Exp_Ch4 is -- Start of processing for Expand_N_Selected_Component begin - -- Insert explicit dereference if required - - if Is_Access_Type (Ptyp) then - - -- First set prefix type to proper access type, in case it currently - -- has a private (non-access) view of this type. - - Set_Etype (P, Ptyp); - - Insert_Explicit_Dereference (P); - Analyze_And_Resolve (P, Designated_Type (Ptyp)); - - Ptyp := Etype (P); - end if; - -- Deal with discriminant check required if Do_Discriminant_Check (N) then @@ -11018,23 +10990,10 @@ package body Exp_Ch4 is -- Local variables Pref : constant Node_Id := Prefix (N); - Pref_Typ : Entity_Id := Etype (Pref); -- Start of processing for Expand_N_Slice begin - -- Special handling for access types - - if Is_Access_Type (Pref_Typ) then - Pref_Typ := Designated_Type (Pref_Typ); - - Rewrite (Pref, - Make_Explicit_Dereference (Sloc (N), - Prefix => Relocate_Node (Pref))); - - Analyze_And_Resolve (Pref, Pref_Typ); - end if; - -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place -- function, then additional actuals must be passed. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 49d3c1f324b..3d417ff995c 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -737,8 +737,9 @@ package body Exp_Ch9 is Renamed_Formal := Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To (Entry_Parameters_Type (Ent), - Make_Identifier (Loc, Chars (Ptr))), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Entry_Parameters_Type (Ent), + Make_Identifier (Loc, Chars (Ptr)))), Selector_Name => New_Occurrence_Of (Comp, Loc)); Decl := @@ -4523,12 +4524,6 @@ package body Exp_Ch9 is Ent_Acc := Entry_Parameters_Type (Ent); Conctyp := Etype (Concval); - -- If prefix is an access type, dereference to obtain the task type - - if Is_Access_Type (Conctyp) then - Conctyp := Designated_Type (Conctyp); - end if; - -- Special case for protected subprogram calls if Is_Protected_Type (Conctyp) @@ -6015,9 +6010,10 @@ package body Exp_Ch9 is Renamed_Formal := Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To ( - Entry_Parameters_Type (Ent), - New_Occurrence_Of (Ann, Loc)), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To ( + Entry_Parameters_Type (Ent), + New_Occurrence_Of (Ann, Loc))), Selector_Name => New_Occurrence_Of (Comp, Loc)); @@ -10533,16 +10529,6 @@ package body Exp_Ch9 is Extract_Entry (N, Concval, Ename, Index); Conc_Typ := Etype (Concval); - -- If the prefix is an access to class-wide type, dereference to get - -- object and entry type. - - if Is_Access_Type (Conc_Typ) then - Conc_Typ := Designated_Type (Conc_Typ); - Rewrite (Concval, - Make_Explicit_Dereference (Loc, Relocate_Node (Concval))); - Analyze_And_Resolve (Concval, Conc_Typ); - end if; - -- Examine the scope stack in order to find nearest enclosing protected -- or task type. This will constitute our invocation source. diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b8cbd4a2275..b57ba586062 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1114,6 +1114,14 @@ package body Exp_Disp is then Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg); + elsif Is_Access_Type (Ctrl_Typ) then + Controlling_Tag := + Make_Selected_Component (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Duplicate_Subexpr_Move_Checks (Ctrl_Arg)), + Selector_Name => New_Occurrence_Of (DTC_Entity (Subp), Loc)); + else Controlling_Tag := Make_Selected_Component (Loc, diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 0e6c745270a..b8b303c1f3a 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -69,12 +69,6 @@ package body Exp_SPARK is procedure Expand_SPARK_N_Op_Ne (N : Node_Id); -- Rewrite operator /= based on operator = when defined explicitly - procedure Expand_SPARK_N_Selected_Component (N : Node_Id); - -- Insert explicit dereference if required - - procedure Expand_SPARK_N_Slice_Or_Indexed_Component (N : Node_Id); - -- Insert explicit dereference if required - ------------------ -- Expand_SPARK -- ------------------ @@ -136,14 +130,6 @@ package body Exp_SPARK is Expand_SPARK_N_Freeze_Type (Entity (N)); end if; - when N_Indexed_Component - | N_Slice - => - Expand_SPARK_N_Slice_Or_Indexed_Component (N); - - when N_Selected_Component => - Expand_SPARK_N_Selected_Component (N); - -- In SPARK mode, no other constructs require expansion when others => @@ -481,40 +467,4 @@ package body Exp_SPARK is end if; end Expand_SPARK_Potential_Renaming; - --------------------------------------- - -- Expand_SPARK_N_Selected_Component -- - --------------------------------------- - - procedure Expand_SPARK_N_Selected_Component (N : Node_Id) is - Pref : constant Node_Id := Prefix (N); - Typ : constant Entity_Id := Underlying_Type (Etype (Pref)); - - begin - if Present (Typ) and then Is_Access_Type (Typ) then - - -- First set prefix type to proper access type, in case it currently - -- has a private (non-access) view of this type. - - Set_Etype (Pref, Typ); - - Insert_Explicit_Dereference (Pref); - Analyze_And_Resolve (Pref, Designated_Type (Typ)); - end if; - end Expand_SPARK_N_Selected_Component; - - ----------------------------------------------- - -- Expand_SPARK_N_Slice_Or_Indexed_Component -- - ----------------------------------------------- - - procedure Expand_SPARK_N_Slice_Or_Indexed_Component (N : Node_Id) is - Pref : constant Node_Id := Prefix (N); - Typ : constant Entity_Id := Etype (Pref); - - begin - if Is_Access_Type (Typ) then - Insert_Explicit_Dereference (Pref); - Analyze_And_Resolve (Pref, Designated_Type (Typ)); - end if; - end Expand_SPARK_N_Slice_Or_Indexed_Component; - end Exp_SPARK; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 3d3e2c7c122..a710ba23f6d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -171,6 +171,7 @@ package body Sem_Ch4 is -- being called. The caller will have verified that the object is legal -- for the call. If the remaining parameters match, the first parameter -- will rewritten as a dereference if needed, prior to completing analysis. + procedure Check_Misspelled_Selector (Prefix : Entity_Id; Sel : Node_Id); @@ -276,20 +277,6 @@ package body Sem_Ch4 is -- type is not directly visible. The routine uses this type to emit a more -- informative message. - function Process_Implicit_Dereference_Prefix - (E : Entity_Id; - P : Node_Id) return Entity_Id; - -- Called when P is the prefix of an implicit dereference, denoting an - -- object E. The function returns the designated type of the prefix, taking - -- into account that the designated type of an anonymous access type may be - -- a limited view, when the nonlimited view is visible. - -- - -- If in semantics only mode (-gnatc or generic), the function also records - -- that the prefix is a reference to E, if any. Normally, such a reference - -- is generated only when the implicit dereference is expanded into an - -- explicit one, but for consistency we must generate the reference when - -- expansion is disabled as well. - procedure Remove_Abstract_Operations (N : Node_Id); -- Ada 2005: implementation of AI-310. An abstract non-dispatching -- operation is not a candidate interpretation. @@ -2351,7 +2338,10 @@ package body Sem_Ch4 is procedure Process_Function_Call; -- Prefix in indexed component form is an overloadable entity, so the - -- node is a function call. Reformat it as such. + -- node is very likely a function call; reformat it as such. The only + -- exception is a call to a parameterless function that returns an + -- array type, or an access type thereof, in which case this will be + -- undone later by Resolve_Call or Resolve_Entry_Call. procedure Process_Indexed_Component; -- Prefix in indexed component form is actually an indexed component. @@ -2462,7 +2452,7 @@ package body Sem_Ch4 is if Is_Access_Type (Array_Type) then Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); - Array_Type := Process_Implicit_Dereference_Prefix (Pent, P); + Array_Type := Implicitly_Designated_Type (Array_Type); end if; if Is_Array_Type (Array_Type) then @@ -3898,18 +3888,6 @@ package body Sem_Ch4 is Set_Etype (Sel, Etype (Comp)); Set_Etype (N, Etype (Comp)); Set_Etype (Nam, It.Typ); - - -- For access type case, introduce explicit dereference for - -- more uniform treatment of entry calls. Do this only once - -- if several interpretations yield an access type. - - if Is_Access_Type (Etype (Nam)) - and then Nkind (Nam) /= N_Explicit_Dereference - then - Insert_Explicit_Dereference (Nam); - Error_Msg_NW - (Warn_On_Dereference, "?d?implicit dereference", N); - end if; end if; Next_Entity (Comp); @@ -4379,7 +4357,6 @@ package body Sem_Ch4 is In_Scope : Boolean; Is_Private_Op : Boolean; Parent_N : Node_Id; - Pent : Entity_Id := Empty; Prefix_Type : Entity_Id; Type_To_Use : Entity_Id; @@ -4408,7 +4385,8 @@ package body Sem_Ch4 is -- indexed component rather than a function call. function Has_Dereference (Nod : Node_Id) return Boolean; - -- Check whether prefix includes a dereference at any level. + -- Check whether prefix includes a dereference, explicit or implicit, + -- at any recursive level. -------------------------------- -- Find_Component_In_Instance -- @@ -4520,10 +4498,6 @@ package body Sem_Ch4 is if Nkind (Nod) = N_Explicit_Dereference then return True; - -- When expansion is disabled an explicit dereference may not have - -- been inserted, but if this is an access type the indirection makes - -- the call safe. - elsif Is_Access_Type (Etype (Nod)) then return True; @@ -4576,16 +4550,7 @@ package body Sem_Ch4 is else Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); - - if Is_Entity_Name (Name) then - Pent := Entity (Name); - elsif Nkind (Name) = N_Selected_Component - and then Is_Entity_Name (Selector_Name (Name)) - then - Pent := Entity (Selector_Name (Name)); - end if; - - Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name); + Prefix_Type := Implicitly_Designated_Type (Prefix_Type); end if; -- If we have an explicit dereference of a remote access-to-class-wide @@ -4673,11 +4638,6 @@ package body Sem_Ch4 is Set_Etype (N, Etype (Comp)); Check_Implicit_Dereference (N, Etype (Comp)); - if Is_Access_Type (Etype (Name)) then - Insert_Explicit_Dereference (Name); - Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); - end if; - elsif Is_Record_Type (Prefix_Type) then -- Find component with given name. In an instance, if the node is @@ -4978,15 +4938,6 @@ package body Sem_Ch4 is if Ekind (Comp) = E_Discriminant then Set_Original_Discriminant (Sel, Comp); end if; - - -- For access type case, introduce explicit dereference for - -- more uniform treatment of entry calls. - - if Is_Access_Type (Etype (Name)) then - Insert_Explicit_Dereference (Name); - Error_Msg_NW - (Warn_On_Dereference, "?d?implicit dereference", N); - end if; end if; <> @@ -5455,8 +5406,8 @@ package body Sem_Ch4 is Set_Etype (N, Any_Type); if Is_Access_Type (Array_Type) then - Array_Type := Designated_Type (Array_Type); Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); + Array_Type := Implicitly_Designated_Type (Array_Type); end if; if not Is_Array_Type (Array_Type) then @@ -7401,48 +7352,6 @@ package body Sem_Ch4 is end if; end Operator_Check; - ----------------------------------------- - -- Process_Implicit_Dereference_Prefix -- - ----------------------------------------- - - function Process_Implicit_Dereference_Prefix - (E : Entity_Id; - P : Entity_Id) return Entity_Id - is - Ref : Node_Id; - Typ : constant Entity_Id := Designated_Type (Etype (P)); - - begin - if Present (E) - and then (Operating_Mode = Check_Semantics or else not Expander_Active) - then - -- We create a dummy reference to E to ensure that the reference is - -- not considered as part of an assignment (an implicit dereference - -- can never assign to its prefix). The Comes_From_Source attribute - -- needs to be propagated for accurate warnings. - - Ref := New_Occurrence_Of (E, Sloc (P)); - Set_Comes_From_Source (Ref, Comes_From_Source (P)); - Generate_Reference (E, Ref); - end if; - - -- An implicit dereference is a legal occurrence of an incomplete type - -- imported through a limited_with clause, if the full view is visible. - - if From_Limited_With (Typ) - and then not From_Limited_With (Scope (Typ)) - and then - (Is_Immediately_Visible (Scope (Typ)) - or else - (Is_Child_Unit (Scope (Typ)) - and then Is_Visible_Lib_Unit (Scope (Typ)))) - then - return Available_View (Typ); - else - return Typ; - end if; - end Process_Implicit_Dereference_Prefix; - -------------------------------- -- Remove_Abstract_Operations -- -------------------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 555862b76f0..e8d5a90c23e 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -501,6 +501,10 @@ package body Sem_Ch8 is -- Ada 2005 (AI-262): Determines if the current compilation unit has a -- private with on E. + function Has_Components (Typ : Entity_Id) return Boolean; + -- Determine if given type has components, i.e. is either a record type or + -- type or a type that has discriminants. + function Has_Implicit_Operator (N : Node_Id) return Boolean; -- N is an expanded name whose selector is an operator name (e.g. P."+"). -- declarative part contains an implicit declaration of an operator if it @@ -515,14 +519,6 @@ package body Sem_Ch8 is -- specification are discarded and replaced with those of the renamed -- subprogram, which are then used to recheck the default values. - function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean; - -- True if it is of a task type, a protected type, or else an access to one - -- of these types. - - function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; - -- Prefix is appropriate for record if it is of a record type, or an access - -- to such. - function Most_Descendant_Use_Clause (Clause1 : Entity_Id; Clause2 : Entity_Id) return Entity_Id; @@ -1736,6 +1732,9 @@ package body Sem_Ch8 is -- The prefix can be an arbitrary expression that yields a task or -- protected object, so it must be resolved. + if Is_Access_Type (Etype (Prefix (Nam))) then + Insert_Explicit_Dereference (Prefix (Nam)); + end if; Resolve (Prefix (Nam), Scope (Old_S)); end if; @@ -7333,23 +7332,6 @@ package body Sem_Ch8 is Set_Etype (N, C_Etype); end; - -- If this is the name of an entry or protected operation, and - -- the prefix is an access type, insert an explicit dereference, - -- so that entry calls are treated uniformly. - - if Is_Access_Type (Etype (P)) - and then Is_Concurrent_Type (Designated_Type (Etype (P))) - then - declare - New_P : constant Node_Id := - Make_Explicit_Dereference (Sloc (P), - Prefix => Relocate_Node (P)); - begin - Rewrite (P, New_P); - Set_Etype (P, Designated_Type (Etype (Prefix (P)))); - end; - end if; - -- If the selected component appears within a default expression -- and it has an actual subtype, the preanalysis has not yet -- completed its analysis, because Insert_Actions is disabled in @@ -7393,37 +7375,16 @@ package body Sem_Ch8 is Write_Entity_Info (P_Type, " "); Write_Eol; end if; - -- The designated type may be a limited view with no components. - -- Check whether the non-limited view is available, because in some - -- cases this will not be set when installing the context. Rewrite - -- the node by introducing an explicit dereference at once, and - -- setting the type of the rewritten prefix to the non-limited view - -- of the original designated type. + -- If the prefix's type is an access type, get to the record type if Is_Access_Type (P_Type) then - declare - Desig_Typ : constant Entity_Id := - Directly_Designated_Type (P_Type); - - begin - if Is_Incomplete_Type (Desig_Typ) - and then From_Limited_With (Desig_Typ) - and then Present (Non_Limited_View (Desig_Typ)) - then - Rewrite (P, - Make_Explicit_Dereference (Sloc (P), - Prefix => Relocate_Node (P))); - - Set_Etype (P, Get_Full_View (Non_Limited_View (Desig_Typ))); - P_Type := Etype (P); - end if; - end; + P_Type := Implicitly_Designated_Type (P_Type); end if; -- First check for components of a record object (not the -- result of a call, which is handled below). - if Is_Appropriate_For_Record (P_Type) + if Has_Components (P_Type) and then not Is_Overloadable (P_Name) and then not Is_Type (P_Name) then @@ -7437,7 +7398,7 @@ package body Sem_Ch8 is -- Reference to type name in predicate/invariant expression - elsif Is_Appropriate_For_Entry_Prefix (P_Type) + elsif (Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type)) and then not In_Open_Scopes (P_Name) and then (not Is_Concurrent_Type (Etype (P_Name)) or else not In_Open_Scopes (Etype (P_Name))) @@ -7616,16 +7577,6 @@ package body Sem_Ch8 is else -- Format node as expanded name, to avoid cascaded errors - -- If the limited_with transformation was applied earlier, restore - -- source for proper error reporting. - - if not Comes_From_Source (P) - and then Nkind (P) = N_Explicit_Dereference - then - Rewrite (P, Prefix (P)); - P_Type := Etype (P); - end if; - Change_Selected_Component_To_Expanded_Name (N); Set_Entity (N, Any_Id); Set_Etype (N, Any_Type); @@ -7687,8 +7638,8 @@ package body Sem_Ch8 is Error_Msg_N ("invalid prefix in selected component&", P); - if Is_Access_Type (P_Type) - and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type + if Is_Incomplete_Type (P_Type) + and then Is_Access_Type (Etype (P)) then Error_Msg_N ("\dereference must not be of an incomplete type " @@ -8042,6 +7993,20 @@ package body Sem_Ch8 is end if; end Find_Type; + -------------------- + -- Has_Components -- + -------------------- + + function Has_Components (Typ : Entity_Id) return Boolean is + begin + return Is_Record_Type (Typ) + or else (Is_Private_Type (Typ) and then Has_Discriminants (Typ)) + or else (Is_Task_Type (Typ) and then Has_Discriminants (Typ)) + or else (Is_Incomplete_Type (Typ) + and then From_Limited_With (Typ) + and then Is_Record_Type (Available_View (Typ))); + end Has_Components; + ------------------------------------ -- Has_Implicit_Character_Literal -- ------------------------------------ @@ -8485,57 +8450,6 @@ package body Sem_Ch8 is end loop; end Install_Use_Clauses; - ------------------------------------- - -- Is_Appropriate_For_Entry_Prefix -- - ------------------------------------- - - function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is - P_Type : Entity_Id := T; - - begin - if Is_Access_Type (P_Type) then - P_Type := Designated_Type (P_Type); - end if; - - return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type); - end Is_Appropriate_For_Entry_Prefix; - - ------------------------------- - -- Is_Appropriate_For_Record -- - ------------------------------- - - function Is_Appropriate_For_Record (T : Entity_Id) return Boolean is - - function Has_Components (T1 : Entity_Id) return Boolean; - -- Determine if given type has components (i.e. is either a record - -- type or a type that has discriminants). - - -------------------- - -- Has_Components -- - -------------------- - - function Has_Components (T1 : Entity_Id) return Boolean is - begin - return Is_Record_Type (T1) - or else (Is_Private_Type (T1) and then Has_Discriminants (T1)) - or else (Is_Task_Type (T1) and then Has_Discriminants (T1)) - or else (Is_Incomplete_Type (T1) - and then From_Limited_With (T1) - and then Present (Non_Limited_View (T1)) - and then Is_Record_Type - (Get_Full_View (Non_Limited_View (T1)))); - end Has_Components; - - -- Start of processing for Is_Appropriate_For_Record - - begin - return - Present (T) - and then (Has_Components (T) - or else (Is_Access_Type (T) - and then Has_Components (Designated_Type (T)))); - end Is_Appropriate_For_Record; - ---------------------- -- Mark_Use_Clauses -- ---------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index d17231102a1..6c244dbbfe4 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -226,6 +226,12 @@ package body Sem_Res is -- is the context type, which is used when the operation is a protected -- function with no arguments, and the return value is indexed. + procedure Resolve_Implicit_Dereference (P : Node_Id); + -- Called when P is the prefix of an indexed component, or of a selected + -- component, or of a slice. If P is of an access type, we unconditionally + -- rewrite it as an explicit dereference. This ensures that the expander + -- and the code generator have a fully explicit tree to work with. + procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); -- A call to a user-defined intrinsic operator is rewritten as a call to -- the corresponding predefined operator, with suitable conversions. Note @@ -6369,7 +6375,6 @@ package body Sem_Res is Set_Etype (Prefix (N), Ret_Type); Set_Etype (N, Typ); - Resolve_Indexed_Component (N, Typ); if Legacy_Elaboration_Checks then Check_Elab_Call (Prefix (N)); @@ -6381,6 +6386,8 @@ package body Sem_Res is -- the ABE Processing phase. Build_Call_Marker (Prefix (N)); + + Resolve_Indexed_Component (N, Typ); end if; end if; @@ -7783,10 +7790,12 @@ package body Sem_Res is if Nkind (Entry_Name) = N_Selected_Component then Resolve (Prefix (Entry_Name)); + Resolve_Implicit_Dereference (Prefix (Entry_Name)); else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); Nam := Entity (Selector_Name (Prefix (Entry_Name))); Resolve (Prefix (Prefix (Entry_Name))); + Resolve_Implicit_Dereference (Prefix (Prefix (Entry_Name))); Index := First (Expressions (Entry_Name)); Resolve (Index, Entry_Index_Type (Nam)); @@ -8723,6 +8732,21 @@ package body Sem_Res is Analyze_Dimension (N); end Resolve_If_Expression; + ---------------------------------- + -- Resolve_Implicit_Dereference -- + ---------------------------------- + + procedure Resolve_Implicit_Dereference (P : Node_Id) is + Desig_Typ : Entity_Id; + + begin + if Is_Access_Type (Etype (P)) then + Desig_Typ := Implicitly_Designated_Type (Etype (P)); + Insert_Explicit_Dereference (P); + Analyze_And_Resolve (P, Desig_Typ); + end if; + end Resolve_Implicit_Dereference; + ------------------------------- -- Resolve_Indexed_Component -- ------------------------------- @@ -8795,12 +8819,12 @@ package body Sem_Res is Resolve (Name, Array_Type); Array_Type := Get_Actual_Subtype_If_Available (Name); - -- If prefix is access type, dereference to get real array type. - -- Note: we do not apply an access check because the expander always - -- introduces an explicit dereference, and the check will happen there. + -- If the prefix's type is an access type, get to the real array type. + -- Note: we do not apply an access check because an explicit dereference + -- will be introduced later, and the check will happen there. if Is_Access_Type (Array_Type) then - Array_Type := Designated_Type (Array_Type); + Array_Type := Implicitly_Designated_Type (Array_Type); end if; -- If name was overloaded, set component type correctly now @@ -8840,6 +8864,7 @@ package body Sem_Res is end loop; end if; + Resolve_Implicit_Dereference (Prefix (N)); Analyze_Dimension (N); -- Do not generate the warning on suspicious index if we are analyzing @@ -10402,12 +10427,12 @@ package body Sem_Res is Generate_Reference (Entity (S), S, 'r'); end if; - -- If prefix is an access type, the node will be transformed into an - -- explicit dereference during expansion. The type of the node is the - -- designated type of that of the prefix. + -- If the prefix's type is an access type, get to the real record type. + -- Note: we do not apply an access check because an explicit dereference + -- will be introduced later, and the check will happen there. if Is_Access_Type (Etype (P)) then - T := Designated_Type (Etype (P)); + T := Implicitly_Designated_Type (Etype (P)); Check_Fully_Declared_Prefix (T, P); else @@ -10482,6 +10507,7 @@ package body Sem_Res is Prefix (N)); end if; + Resolve_Implicit_Dereference (Prefix (N)); Analyze_Dimension (N); end Resolve_Selected_Component; @@ -10712,9 +10738,12 @@ package body Sem_Res is Resolve (Name, Array_Type); + -- If the prefix's type is an access type, get to the real array type. + -- Note: we do not apply an access check because an explicit dereference + -- will be introduced later, and the check will happen there. + if Is_Access_Type (Array_Type) then - Apply_Access_Check (N); - Array_Type := Designated_Type (Array_Type); + Array_Type := Implicitly_Designated_Type (Array_Type); -- If the prefix is an access to an unconstrained array, we must use -- the actual subtype of the object to perform the index checks. The @@ -10858,6 +10887,7 @@ package body Sem_Res is Warn_On_Suspicious_Index (Name, High_Bound (Drange)); end if; + Resolve_Implicit_Dereference (Prefix (N)); Analyze_Dimension (N); Eval_Slice (N); end Resolve_Slice; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index cce55a6c58a..c6c8d10c796 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1354,14 +1354,12 @@ package body Sem_Util is New_N : constant Node_Id := New_Copy_Tree (N); begin - if Is_Access_Type (Etype (New_N)) then - -- Copy the parent to have a proper Sloc on the dereference + if Is_Access_Type (Etype (N)) then + return Make_Explicit_Dereference (Sloc (Parent (N)), New_N); - Set_Parent (New_N, Parent (N)); - Insert_Explicit_Dereference (New_N); + else + return New_N; end if; - - return New_N; end Copy_And_Maybe_Dereference; -- Start of processing for Build_Actual_Subtype_Of_Component @@ -12515,6 +12513,32 @@ package body Sem_Util is return False; end Implements_Interface; + -------------------------------- + -- Implicitly_Designated_Type -- + -------------------------------- + + function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is + Desig : constant Entity_Id := Designated_Type (Typ); + + begin + -- An implicit dereference is a legal occurrence of an incomplete type + -- imported through a limited_with clause, if the full view is visible. + + if Is_Incomplete_Type (Desig) + and then From_Limited_With (Desig) + and then not From_Limited_With (Scope (Desig)) + and then + (Is_Immediately_Visible (Scope (Desig)) + or else + (Is_Child_Unit (Scope (Desig)) + and then Is_Visible_Lib_Unit (Scope (Desig)))) + then + return Available_View (Desig); + else + return Desig; + end if; + end Implicitly_Designated_Type; + ------------------------------------ -- In_Assertion_Expression_Pragma -- ------------------------------------ @@ -23402,7 +23426,7 @@ package body Sem_Util is Orig_Pre := Original_Node (Prefix (Orig_Obj)); if Is_Access_Type (Etype (Orig_Pre)) then - return Type_Access_Level (Etype (Prefix (Orig_Obj))); + return Type_Access_Level (Etype (Orig_Pre)); else return Object_Access_Level (Prefix (Orig_Obj)); end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b794e809822..25318441270 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1391,6 +1391,11 @@ package Sem_Util is Exclude_Parents : Boolean := False) return Boolean; -- Returns true if the Typ_Ent implements interface Iface_Ent + function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id; + -- Called when Typ is the type of the prefix of an implicit dereference. + -- Return the designated type of Typ, taking into account that this type + -- may be a limited view, when the nonlimited view is visible. + function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean; -- Returns True if node N appears within a pragma that acts as an assertion -- expression. See Sem_Prag for the list of qualifying pragmas. diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index ca019ef9d31..3fe77b077bc 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1872,7 +1872,7 @@ package body Sem_Warn is -- have a reference from generated code, it is bogus (e.g. calls to init -- procs to set default discriminant values). - if not Comes_From_Source (N) then + if not Comes_From_Source (Original_Node (N)) then return; end if; -- 2.30.2