OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_util.ads, [...] (Is_Ref_To_Bit_Packed_Slice): Handle case of type conversion.

Browse Source 
2005-12-05  Robert Dewar  <dewar@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* 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
This commit is contained in:
Robert Dewar 2005-12-09 18:19:33 +01:00 committed by Arnaud Charlet
parent e6d9df3c65
commit ea985d9542
3 changed files with 171 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
gcc/ada/exp_util.adb
View File

@ -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);

7
gcc/ada/exp_util.ads
View File

@ -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;

98
gcc/ada/sem_res.adb
View File

@ -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);
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)
then
null;
else
Expand_Interface_Conversion (N);
begin
if Is_Class_Wide_Type (Opnd_Type) then
Opnd_Type := Etype (Opnd_Type);
end if;
end if;
if not Interface_Present_In_Ancestor
(Typ => Opnd_Type,
Iface => Target_Type)
then
-- 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
-- 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;
end if;
end if;
end Resolve_Type_Conversion;