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

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

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

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;

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;