From ea985d95427f210e627541b70dd56bb4b21ed838 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Fri, 9 Dec 2005 18:19:33 +0100 Subject: [PATCH] exp_util.ads, [...] (Is_Ref_To_Bit_Packed_Slice): Handle case of type conversion. 2005-12-05 Robert Dewar Javier Miranda Ed Schonberg * exp_util.ads, exp_util.adb (Is_Ref_To_Bit_Packed_Slice): Handle case of type conversion. (Find_Interface): New subprogram that given a tagged type and one of its component associated with the secondary table of an abstract interface type, return the entity associated with such abstract interface type. (Make_Subtype_From_Expr): If type has unknown discriminants, always use base type to create anonymous subtype, because entity may be a locally declared subtype or generic actual. (Find_Interface): New subprogram that given a tagged type and one of its component associated with the secondary table of an abstract interface type, return the entity associated with such abstract interface type. * sem_res.adb (Resolve_Type_Conversion): Handle the case in which the conversion cannot be handled at compile time. In this case we pass this information to the expander to generate the appropriate code. From-SVN: r108294 --- gcc/ada/exp_util.adb | 118 +++++++++++++++++++++++++++++++++++++++---- gcc/ada/exp_util.ads | 7 +++ gcc/ada/sem_res.adb | 92 +++++++++++++++++++-------------- 3 files changed, 168 insertions(+), 49 deletions(-) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c6924e97cb6..997fc7b7b90 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1447,7 +1447,7 @@ package body Exp_Util is Iface : Entity_Id) return Entity_Id is ADT : Elmt_Id; - Found : Boolean := False; + Found : Boolean := False; Typ : Entity_Id := T; procedure Find_Secondary_Table (Typ : Entity_Id); @@ -1544,9 +1544,9 @@ package body Exp_Util is procedure Find_Tag (Typ : in Entity_Id); -- Internal subprogram used to recursively climb to the ancestors - ----------------- - -- Find_AI_Tag -- - ----------------- + -------------- + -- Find_Tag -- + -------------- procedure Find_Tag (Typ : in Entity_Id) is AI_Elmt : Elmt_Id; @@ -1642,6 +1642,101 @@ package body Exp_Util is return AI_Tag; end Find_Interface_Tag; + -------------------- + -- Find_Interface -- + -------------------- + + function Find_Interface + (T : Entity_Id; + Comp : Entity_Id) return Entity_Id + is + AI_Tag : Entity_Id; + Found : Boolean := False; + Iface : Entity_Id; + Typ : Entity_Id := T; + + procedure Find_Iface (Typ : in Entity_Id); + -- Internal subprogram used to recursively climb to the ancestors + + ---------------- + -- Find_Iface -- + ---------------- + + procedure Find_Iface (Typ : in Entity_Id) is + AI_Elmt : Elmt_Id; + + begin + -- Climb to the root type + + if Etype (Typ) /= Typ then + Find_Iface (Etype (Typ)); + end if; + + -- Traverse the list of interfaces implemented by the type + + if not Found + and then Present (Abstract_Interfaces (Typ)) + and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) + then + -- Skip the tag associated with the primary table + + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); + pragma Assert (Present (AI_Tag)); + + AI_Elmt := First_Elmt (Abstract_Interfaces (Typ)); + while Present (AI_Elmt) loop + if AI_Tag = Comp then + Iface := Node (AI_Elmt); + Found := True; + return; + end if; + + AI_Tag := Next_Tag_Component (AI_Tag); + Next_Elmt (AI_Elmt); + end loop; + end if; + end Find_Iface; + + -- Start of processing for Find_Interface + + begin + -- Handle private types + + if Has_Private_Declaration (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle access types + + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); + end if; + + -- Handle task and protected types implementing interfaces + + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); + end if; + + if Is_Class_Wide_Type (Typ) then + Typ := Etype (Typ); + end if; + + -- Handle entities from the limited view + + if Ekind (Typ) = E_Incomplete_Type then + pragma Assert (Present (Non_Limited_View (Typ))); + Typ := Non_Limited_View (Typ); + end if; + + Find_Iface (Typ); + pragma Assert (Found); + return Iface; + end Find_Interface; + ------------------ -- Find_Prim_Op -- ------------------ @@ -3050,14 +3145,16 @@ package body Exp_Util is function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is begin - if Is_Entity_Name (N) + if Nkind (N) = N_Type_Conversion then + return Is_Ref_To_Bit_Packed_Slice (Expression (N)); + + elsif Is_Entity_Name (N) and then Is_Object (Entity (N)) and then Present (Renamed_Object (Entity (N))) then return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N))); - end if; - if Nkind (N) = N_Slice + elsif Nkind (N) = N_Slice and then Is_Bit_Packed_Array (Etype (Prefix (N))) then return True; @@ -3500,7 +3597,8 @@ package body Exp_Util is and then Has_Unknown_Discriminants (Unc_Typ) then -- Prepare the subtype completion, Go to base type to - -- find underlying type. + -- find underlying type, because the type may be a generic + -- actual or an explicit subtype. Utyp := Underlying_Type (Base_Type (Unc_Typ)); Full_Subtyp := Make_Defining_Identifier (Loc, @@ -3521,7 +3619,7 @@ package body Exp_Util is -- Define the dummy private subtype Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ))); - Set_Etype (Priv_Subtyp, Unc_Typ); + Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ)); Set_Scope (Priv_Subtyp, Full_Subtyp); Set_Is_Constrained (Priv_Subtyp); Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ)); @@ -3585,7 +3683,7 @@ package body Exp_Util is return New_Occurrence_Of (CW_Subtype, Loc); end; - -- Indefinite record type with discriminants. + -- Indefinite record type with discriminants else D := First_Discriminant (Unc_Typ); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 2afb88f8ca6..fad07ccafe5 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -339,6 +339,13 @@ package Exp_Util is -- declarations and/or allocations when the type is indefinite (including -- class-wide). + function Find_Interface + (T : Entity_Id; + Comp : Entity_Id) return Entity_Id; + -- Ada 2005 (AI-251): Given a tagged type and one of its components + -- associated with the secondary dispatch table of an abstract interface + -- type, return the associated abstract interface type. + function Find_Interface_ADT (T : Entity_Id; Iface : Entity_Id) return Entity_Id; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f9093455fbb..45e902bccff 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1559,8 +1559,8 @@ package body Sem_Res is if Nkind (N) = N_Attribute_Reference and then (Attribute_Name (N) = Name_Access - or else Attribute_Name (N) = Name_Unrestricted_Access - or else Attribute_Name (N) = Name_Unchecked_Access) + or else Attribute_Name (N) = Name_Unrestricted_Access + or else Attribute_Name (N) = Name_Unchecked_Access) and then Comes_From_Source (N) and then Is_Entity_Name (Prefix (N)) and then Is_Subprogram (Entity (Prefix (N))) @@ -2091,11 +2091,9 @@ package body Sem_Res is Get_First_Interp (Name (N), Index, It); while Present (It.Nam) loop - Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_Node_2 := It.Typ; - Error_Msg_NE ("\& declared#, type&", - N, It.Nam); - + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_Node_2 := It.Typ; + Error_Msg_NE ("\& declared#, type&", N, It.Nam); Get_Next_Interp (Index, It); end loop; end; @@ -2591,15 +2589,15 @@ package body Sem_Res is -- If the formal is Out or In_Out, do not resolve and expand the -- conversion, because it is subsequently expanded into explicit -- temporaries and assignments. However, the object of the - -- conversion can be resolved. An exception is the case of a - -- tagged type conversion with a class-wide actual. In that case - -- we want the tag check to occur and no temporary will be needed - -- (no representation change can occur) and the parameter is - -- passed by reference, so we go ahead and resolve the type - -- conversion. Another excpetion is the case of reference to a - -- component or subcomponent of a bit-packed array, in which case - -- we want to defer expansion to the point the in and out - -- assignments are performed. + -- conversion can be resolved. An exception is the case of tagged + -- type conversion with a class-wide actual. In that case we want + -- the tag check to occur and no temporary will be needed (no + -- representation change can occur) and the parameter is passed by + -- reference, so we go ahead and resolve the type conversion. + -- Another excpetion is the case of reference to component or + -- subcomponent of a bit-packed array, in which case we want to + -- defer expansion to the point the in and out assignments are + -- performed. if Ekind (F) /= E_In_Parameter and then Nkind (A) = N_Type_Conversion @@ -6660,34 +6658,50 @@ package body Sem_Res is Opnd_Type := Directly_Designated_Type (Opnd_Type); end if; - if Is_Class_Wide_Type (Opnd_Type) then - Opnd_Type := Etype (Opnd_Type); - end if; + declare + Save_Typ : constant Entity_Id := Opnd_Type; - if not Interface_Present_In_Ancestor - (Typ => Opnd_Type, - Iface => Target_Type) - then - Error_Msg_NE - ("(Ada 2005) does not implement interface }", - Operand, Target_Type); + begin + if Is_Class_Wide_Type (Opnd_Type) then + Opnd_Type := Etype (Opnd_Type); + end if; - else - -- If a conversion to an interface type appears as an actual in - -- a source call, it will be expanded when the enclosing call - -- itself is examined in Expand_Interface_Formals. Otherwise, - -- generate the proper conversion code now, using the tag of - -- the interface. - - if (Nkind (Parent (N)) = N_Procedure_Call_Statement - or else Nkind (Parent (N)) = N_Function_Call) - and then Comes_From_Source (N) + if not Interface_Present_In_Ancestor + (Typ => Opnd_Type, + Iface => Target_Type) then - null; + -- The static analysis is not enough to know if the + -- interface is implemented or not. Hence we must pass the + -- work to the expander to generate the required code to + -- evaluate the conversion at run-time. + + if Is_Class_Wide_Type (Save_Typ) + and then Is_Interface (Save_Typ) + then + Expand_Interface_Conversion (N, Is_Static => False); + else + Error_Msg_NE + ("(Ada 2005) does not implement interface }", + Operand, Target_Type); + end if; + else - Expand_Interface_Conversion (N); + -- If a conversion to an interface type appears as an actual + -- in a source call, it will be expanded when the enclosing + -- call itself is examined in Expand_Interface_Formals. + -- Otherwise, generate the proper conversion code now, using + -- the tag of the interface. + + if (Nkind (Parent (N)) = N_Procedure_Call_Statement + or else Nkind (Parent (N)) = N_Function_Call) + and then Comes_From_Source (N) + then + null; + else + Expand_Interface_Conversion (N); + end if; end if; - end if; + end; end if; end if; end Resolve_Type_Conversion; -- 2.30.2