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);
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;
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 --
------------------
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;
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,
-- 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));
return New_Occurrence_Of (CW_Subtype, Loc);
end;
- -- Indefinite record type with discriminants.
+ -- Indefinite record type with discriminants
else
D := First_Discriminant (Unc_Typ);
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)))
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;
-- 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
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;
projects / platform / upstream / linaro-gcc.git / commitdiff