sem_disp.adb (Check_Dispatching_Operation): Do not flag subprograms inherited from an interface ancestor by another...

2006-10-31  Hristian Kirtchev  <kirtchev@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* sem_disp.adb (Check_Dispatching_Operation): Do not flag subprograms
	inherited from an interface ancestor by another interface in the
	context of an instance as 'late'.
	(Is_Tag_Indeterminate, Propagate_Tag): Handle properly the dereference
	of a call to a function that dispatches on access result.
	(Check_Dispatching_Operation): In case of late overriding of a primitive
	that covers abstract interface subprograms we register it in all the
	secondary dispatch tables associated with abstract interfaces.
	(Check_Dispatching_Call): Add check that a dispatching call is not made
	to a function with a controlling result of a limited type. This is a
	current implementation restriction.
	(Check_Controlling_Formal): Remove bogus checks for E.2.2(14).
	(Check_Dispatching_Operation): Do no emit a warning if the controlling
	argument is an interface type that is a generic formal.
	(Is_Interface_Subprogram): Removed.
	(Check_Dispatching_Operation): If the subprogram is not a dispatching
	operation, check the formals to handle the case in which it is
	associated with an abstract interface type.

From-SVN: r118308

1 files changed, 166 insertions, 122 deletions

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 73737de..9ccbff7 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -29,9 +29,9 @@ with Debug;    use Debug;
 with Elists;   use Elists;
 with Einfo;    use Einfo;
 with Exp_Disp; use Exp_Disp;
+with Exp_Ch6;  use Exp_Ch6;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Tss;  use Exp_Tss;
-with Exp_Util; use Exp_Util;
 with Errout;   use Errout;
 with Hostparm; use Hostparm;
 with Nlists;   use Nlists;
@@ -94,10 +94,6 @@ package body Sem_Disp is
    is
       Formal    : Entity_Id;
       Ctrl_Type : Entity_Id;
-      Remote    : constant Boolean :=
-                    Is_Remote_Types (Current_Scope)
-                      and then Comes_From_Source (Subp)
-                      and then Scope (Typ) = Current_Scope;
 
    begin
       Formal := First_Formal (Subp);
@@ -109,9 +105,9 @@ package body Sem_Disp is
             if Ctrl_Type = Typ then
                Set_Is_Controlling_Formal (Formal);
 
-               --  Ada 2005 (AI-231):Anonymous access types used in controlling
-               --  parameters exclude null because it is necessary to read the
-               --  tag to dispatch, and null has no tag.
+               --  Ada 2005 (AI-231): Anonymous access types used in
+               --  controlling parameters exclude null because it is necessary
+               --  to read the tag to dispatch, and null has no tag.
 
                if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then
                   Set_Can_Never_Be_Null (Etype (Formal));
@@ -153,16 +149,6 @@ package body Sem_Disp is
                Error_Msg_N
                  ("operation can be dispatching in only one type", Subp);
             end if;
-
-         --  Verify that the restriction in E.2.2 (14) is obeyed
-
-         elsif Remote
-           and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
-         then
-            Error_Msg_N
-              ("access parameter of remote object primitive"
-               & " must be controlling",
-                Formal);
          end if;
 
          Next_Formal (Formal);
@@ -175,8 +161,7 @@ package body Sem_Disp is
             if Ctrl_Type = Typ then
                Set_Has_Controlling_Result (Subp);
 
-               --  Check that the result subtype statically matches
-               --  the first subtype.
+               --  Check that result subtype statically matches first subtype
 
                if not Subtypes_Statically_Match (Typ, Etype (Subp)) then
                   Error_Msg_N
@@ -187,18 +172,6 @@ package body Sem_Disp is
                Error_Msg_N
                  ("operation can be dispatching in only one type", Subp);
             end if;
-
-         --  The following check is clearly required, although the RM says
-         --  nothing about return types. If the return type is a limited
-         --  class-wide type declared in the current scope, there is no way
-         --  to declare stream procedures for it, so the return cannot be
-         --  marshalled.
-
-         elsif Remote
-           and then Is_Limited_Type (Typ)
-           and then Etype (Subp) = Class_Wide_Type (Typ)
-         then
-            Error_Msg_N ("return type has no stream attributes", Subp);
          end if;
       end if;
    end Check_Controlling_Formals;
@@ -456,6 +429,25 @@ package body Sem_Disp is
 
             Set_Controlling_Argument (N, Control);
 
+            --  Ada 2005 (AI-318-02): Check current implementation restriction
+            --  that a dispatching call cannot be made to a primitive function
+            --  with a limited result type. This restriction can be removed
+            --  once calls to limited functions with class-wide results are
+            --  supported. ???
+
+            if Ada_Version = Ada_05
+              and then Nkind (N) = N_Function_Call
+            then
+               Func := Entity (Name (N));
+
+               if Has_Controlling_Result (Func)
+                 and then Is_Limited_Type (Etype (Func))
+               then
+                  Error_Msg_N ("(Ada 2005) limited function call in this" &
+                    " context is not yet implemented", N);
+               end if;
+            end if;
+
          else
             --  The call is not dispatching, so check that there aren't any
             --  tag-indeterminate abstract calls left.
@@ -574,6 +566,61 @@ package body Sem_Disp is
            and then Is_Dispatching_Operation (Alias (Subp));
 
       if No (Tagged_Type) then
+
+         --  Ada 2005 (AI-251): Check that Subp is not a primitive associated
+         --  with an abstract interface type unless the interface acts as a
+         --  parent type in a derivation. If the interface type is a formal
+         --  type then the operation is not primitive and therefore legal.
+
+         declare
+            E   : Entity_Id;
+            Typ : Entity_Id;
+
+         begin
+            E := First_Entity (Subp);
+            while Present (E) loop
+               if Is_Access_Type (Etype (E)) then
+                  Typ := Designated_Type (Etype (E));
+               else
+                  Typ := Etype (E);
+               end if;
+
+               if not Is_Class_Wide_Type (Typ)
+                 and then Is_Interface (Typ)
+                 and then not Is_Derived_Type (Typ)
+                 and then not Is_Generic_Type (Typ)
+               then
+                  Error_Msg_N ("?declaration of& is too late!", Subp);
+                  Error_Msg_NE
+                    ("\spec should appear immediately after declaration of &!",
+                     Subp, Typ);
+                  exit;
+               end if;
+
+               Next_Entity (E);
+            end loop;
+
+            --  In case of functions check also the result type
+
+            if Ekind (Subp) = E_Function then
+               if Is_Access_Type (Etype (Subp)) then
+                  Typ := Designated_Type (Etype (Subp));
+               else
+                  Typ := Etype (Subp);
+               end if;
+
+               if not Is_Class_Wide_Type (Typ)
+                 and then Is_Interface (Typ)
+                 and then not Is_Derived_Type (Typ)
+               then
+                  Error_Msg_N ("?declaration of& is too late!", Subp);
+                  Error_Msg_NE
+                    ("\spec should appear immediately after declaration of &!",
+                     Subp, Typ);
+               end if;
+            end if;
+         end;
+
          return;
 
       --  The subprograms build internally after the freezing point (such as
@@ -744,6 +791,41 @@ package body Sem_Disp is
          else
             Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
             Set_Is_Overriding_Operation (Subp);
+
+            --  Ada 2005 (AI-251): In case of late overriding of a primitive
+            --  that covers abstract interface subprograms we must register it
+            --  in all the secondary dispatch tables associated with abstract
+            --  interfaces.
+
+            if Body_Is_Last_Primitive then
+               declare
+                  Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
+                  Elmt      : Elmt_Id;
+                  Prim      : Node_Id;
+
+               begin
+                  Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+                  while Present (Elmt) loop
+                     Prim := Node (Elmt);
+
+                     if Present (Alias (Prim))
+                       and then Present (Abstract_Interface_Alias (Prim))
+                       and then Alias (Prim) = Subp
+                     then
+                        Register_Interface_DT_Entry (Subp_Body, Prim);
+                     end if;
+
+                     Next_Elmt (Elmt);
+                  end loop;
+
+                  --  Redisplay the contents of the updated dispatch table.
+
+                  if Debug_Flag_ZZ then
+                     Write_Str ("Late overriding: ");
+                     Write_DT (Tagged_Type);
+                  end if;
+               end;
+            end if;
          end if;
 
       --  If no old subprogram, then we add this as a dispatching operation,
@@ -815,7 +897,7 @@ package body Sem_Disp is
 
             --  The new operation is added to the actions of the freeze
             --  node for the type, but this node has already been analyzed,
-            --  so we must retrieve and analyze explicitly the one new body,
+            --  so we must retrieve and analyze explicitly the new body.
 
             if Present (F_Node)
               and then Present (Actions (F_Node))
@@ -1176,6 +1258,16 @@ package body Sem_Disp is
           Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
       then
          return True;
+
+      --  In Ada 2005 a function that returns an anonymous access type can
+      --  dispatching, and the dereference of a call to such a function
+      --  is also tag-indeterminate.
+
+      elsif Nkind (Orig_Node) = N_Explicit_Dereference
+        and then Ada_Version >= Ada_05
+      then
+         return Is_Tag_Indeterminate (Prefix (Orig_Node));
+
       else
          return False;
       end if;
@@ -1190,38 +1282,8 @@ package body Sem_Disp is
       Prev_Op     : Entity_Id;
       New_Op      : Entity_Id)
    is
-      Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
-      Elmt    : Elmt_Id;
-      Found   : Boolean;
-      E       : Entity_Id;
-
-      function Is_Interface_Subprogram (Op : Entity_Id) return Boolean;
-      --  Traverse the list of aliased entities to check if the overriden
-      --  entity corresponds with a primitive operation of an abstract
-      --  interface type.
-
-      -----------------------------
-      -- Is_Interface_Subprogram --
-      -----------------------------
-
-      function Is_Interface_Subprogram (Op : Entity_Id) return Boolean is
-         Aux : Entity_Id;
-
-      begin
-         Aux := Op;
-         while Present (Alias (Aux))
-            and then Present (DTC_Entity (Alias (Aux)))
-         loop
-            if Is_Interface (Scope (DTC_Entity (Alias (Aux)))) then
-               return True;
-            end if;
-            Aux := Alias (Aux);
-         end loop;
-
-         return False;
-      end Is_Interface_Subprogram;
-
-   --  Start of processing for Override_Dispatching_Operation
+      Elmt : Elmt_Id;
+      Prim : Node_Id;
 
    begin
       --  Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
@@ -1232,79 +1294,52 @@ package body Sem_Disp is
          Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
       end if;
 
-      --  Patch the primitive operation list
+      --  If there is no previous operation to override, the type declaration
+      --  was malformed, and an error must have been emitted already.
 
-      while Present (Op_Elmt)
-        and then Node (Op_Elmt) /= Prev_Op
+      Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+      while Present (Elmt)
+        and then Node (Elmt) /= Prev_Op
       loop
-         Next_Elmt (Op_Elmt);
+         Next_Elmt (Elmt);
       end loop;
 
-      --  If there is no previous operation to override, the type declaration
-      --  was malformed, and an error must have been emitted already.
-
-      if No (Op_Elmt) then
+      if No (Elmt) then
          return;
       end if;
 
-      --  Ada 2005 (AI-251): Do not replace subprograms inherited from
-      --  abstract interfaces. They will be used later to generate the
-      --  corresponding thunks to initialize the Vtable (see subprogram
-      --  Freeze_Subprogram). The inherited operation itself must also
-      --  become hidden, to avoid spurious ambiguities;  name resolution
-      --  must pick up only the operation that implements it,
-
-      if Is_Interface_Subprogram (Prev_Op) then
-         Set_DT_Position              (Prev_Op, DT_Position (Alias (Prev_Op)));
-         Set_Is_Abstract              (Prev_Op, Is_Abstract (New_Op));
-         Set_Is_Overriding_Operation  (Prev_Op);
-
-         --  Traverse the list of aliased entities to look for the overriden
-         --  abstract interface subprogram.
-
-         E := Alias (Prev_Op);
-         while Present (Alias (E))
-           and then Present (DTC_Entity (E))
-           and then not (Is_Abstract (E))
-           and then not Is_Interface (Scope (DTC_Entity (E)))
-         loop
-            E := Alias (E);
-         end loop;
+      Replace_Elmt (Elmt, New_Op);
 
-         Set_Abstract_Interface_Alias (Prev_Op, E);
-         Set_Alias                    (Prev_Op, New_Op);
-         Set_Is_Internal              (Prev_Op);
-         Set_Is_Hidden                (Prev_Op);
+      if Ada_Version >= Ada_05
+        and then Has_Abstract_Interfaces (Tagged_Type)
+      then
+         --  Ada 2005 (AI-251): Update the attribute alias of all the aliased
+         --  entities of the overriden primitive to reference New_Op, and also
+         --  propagate them the new value of the attribute Is_Abstract.
 
-         --  Override predefined primitive operations
+         Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+         while Present (Elmt) loop
+            Prim := Node (Elmt);
 
-         if Is_Predefined_Dispatching_Operation (Prev_Op) then
-            Replace_Elmt (Op_Elmt, New_Op);
-            return;
-         end if;
+            if Prim = New_Op then
+               null;
 
-         --  Check if this primitive operation was previously added for another
-         --  interface.
+            elsif Present (Abstract_Interface_Alias (Prim))
+              and then Alias (Prim) = Prev_Op
+            then
+               Set_Alias (Prim, New_Op);
+               Set_Is_Abstract (Prim, Is_Abstract (New_Op));
 
-         Elmt  := First_Elmt (Primitive_Operations (Tagged_Type));
-         Found := False;
-         while Present (Elmt) loop
-            if Node (Elmt) = New_Op then
-               Found := True;
-               exit;
+               --  Ensure that this entity will be expanded to fill the
+               --  corresponding entry in its dispatch table.
+
+               if not Is_Abstract (Prim) then
+                  Set_Has_Delayed_Freeze (Prim);
+               end if;
             end if;
 
             Next_Elmt (Elmt);
          end loop;
-
-         if not Found then
-            Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
-         end if;
-
-         return;
-
-      else
-         Replace_Elmt (Op_Elmt, New_Op);
       end if;
 
       if (not Is_Package_Or_Generic_Package (Current_Scope))
@@ -1350,6 +1385,15 @@ package body Sem_Disp is
 
          Call_Node := Expression (Parent (Entity (Actual)));
 
+      --  Ada 2005: If this is a dereference of a call to a function with a
+      --  dispatching access-result, the tag is propagated when the dereference
+      --  itself is expanded (see exp_ch6.adb) and there is nothing else to do.
+
+      elsif Nkind (Actual) = N_Explicit_Dereference
+        and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
+      then
+         return;
+
       --  Only other possibilities are parenthesized or qualified expression,
       --  or an expander-generated unchecked conversion of a function call to
       --  a stream Input attribute.