2008-05-28 Javier Miranda <miranda@adacore.com>

	* sem_util.ads (Find_Overridden_Synchronized_Primitive): Removed.
	* sem_util.adb (Find_Overridden_Synchronized_Primitive): Removed.
	* sem_ch6.adb (Check_Synchronized_Overriding): Remove one formal.
	Add code that was previously located in
	Find_Overridden_Synchronized_Primitive because it is only used here.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@136105 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 332 insertions, 36 deletions

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index afd6451e7ea..f376e955b37 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6203,7 +6203,6 @@ package body Sem_Ch6 is
 
       procedure Check_Synchronized_Overriding
         (Def_Id          : Entity_Id;
-         First_Hom       : Entity_Id;
          Overridden_Subp : out Entity_Id);
       --  First determine if Def_Id is an entry or a subprogram either defined
       --  in the scope of a task or protected type, or is a primitive of such
@@ -6398,22 +6397,198 @@ package body Sem_Ch6 is
 
       procedure Check_Synchronized_Overriding
         (Def_Id          : Entity_Id;
-         First_Hom       : Entity_Id;
          Overridden_Subp : out Entity_Id)
       is
-         Formal_Typ  : Entity_Id;
          Ifaces_List : Elist_Id;
          In_Scope    : Boolean;
          Typ         : Entity_Id;
 
+         function Has_Correct_Formal_Mode
+           (Tag_Typ : Entity_Id;
+            Subp    : Entity_Id) return Boolean;
+         --  For an overridden subprogram Subp, check whether the mode of its
+         --  first parameter is correct depending on the kind of Tag_Typ.
+
+         function Matches_Prefixed_View_Profile
+           (Prim_Params  : List_Id;
+            Iface_Params : List_Id) return Boolean;
+         --  Determine whether a subprogram's parameter profile Prim_Params
+         --  matches that of a potentially overridden interface subprogram
+         --  Iface_Params. Also determine if the type of first parameter of
+         --  Iface_Params is an implemented interface.
+
+         -----------------------------
+         -- Has_Correct_Formal_Mode --
+         -----------------------------
+
+         function Has_Correct_Formal_Mode
+           (Tag_Typ : Entity_Id;
+            Subp    : Entity_Id) return Boolean
+         is
+            Formal : constant Node_Id := First_Formal (Subp);
+
+         begin
+            --  In order for an entry or a protected procedure to override, the
+            --  first parameter of the overridden routine must be of mode
+            --  "out", "in out" or access-to-variable.
+
+            if (Ekind (Subp) = E_Entry
+                  or else Ekind (Subp) = E_Procedure)
+              and then Is_Protected_Type (Tag_Typ)
+              and then Ekind (Formal) /= E_In_Out_Parameter
+              and then Ekind (Formal) /= E_Out_Parameter
+              and then Nkind (Parameter_Type (Parent (Formal))) /=
+                         N_Access_Definition
+            then
+               return False;
+            end if;
+
+            --  All other cases are OK since a task entry or routine does not
+            --  have a restriction on the mode of the first parameter of the
+            --  overridden interface routine.
+
+            return True;
+         end Has_Correct_Formal_Mode;
+
+         -----------------------------------
+         -- Matches_Prefixed_View_Profile --
+         -----------------------------------
+
+         function Matches_Prefixed_View_Profile
+           (Prim_Params  : List_Id;
+            Iface_Params : List_Id) return Boolean
+         is
+            Iface_Id     : Entity_Id;
+            Iface_Param  : Node_Id;
+            Iface_Typ    : Entity_Id;
+            Prim_Id      : Entity_Id;
+            Prim_Param   : Node_Id;
+            Prim_Typ     : Entity_Id;
+
+            function Is_Implemented
+              (Ifaces_List : Elist_Id;
+               Iface       : Entity_Id) return Boolean;
+            --  Determine if Iface is implemented by the current task or
+            --  protected type.
+
+            --------------------
+            -- Is_Implemented --
+            --------------------
+
+            function Is_Implemented
+              (Ifaces_List : Elist_Id;
+               Iface       : Entity_Id) return Boolean
+            is
+               Iface_Elmt : Elmt_Id;
+
+            begin
+               Iface_Elmt := First_Elmt (Ifaces_List);
+               while Present (Iface_Elmt) loop
+                  if Node (Iface_Elmt) = Iface then
+                     return True;
+                  end if;
+
+                  Next_Elmt (Iface_Elmt);
+               end loop;
+
+               return False;
+            end Is_Implemented;
+
+         --  Start of processing for Matches_Prefixed_View_Profile
+
+         begin
+            Iface_Param := First (Iface_Params);
+            Iface_Typ   := Etype (Defining_Identifier (Iface_Param));
+
+            if Is_Access_Type (Iface_Typ) then
+               Iface_Typ := Designated_Type (Iface_Typ);
+            end if;
+
+            Prim_Param := First (Prim_Params);
+
+            --  The first parameter of the potentially overridden subprogram
+            --  must be an interface implemented by Prim.
+
+            if not Is_Interface (Iface_Typ)
+              or else not Is_Implemented (Ifaces_List, Iface_Typ)
+            then
+               return False;
+            end if;
+
+            --  The checks on the object parameters are done, move onto the
+            --  rest of the parameters.
+
+            if not In_Scope then
+               Prim_Param := Next (Prim_Param);
+            end if;
+
+            Iface_Param := Next (Iface_Param);
+            while Present (Iface_Param) and then Present (Prim_Param) loop
+               Iface_Id  := Defining_Identifier (Iface_Param);
+               Iface_Typ := Find_Parameter_Type (Iface_Param);
+
+               if Is_Access_Type (Iface_Typ) then
+                  Iface_Typ := Directly_Designated_Type (Iface_Typ);
+               end if;
+
+               Prim_Id  := Defining_Identifier (Prim_Param);
+               Prim_Typ := Find_Parameter_Type (Prim_Param);
+
+               if Is_Access_Type (Prim_Typ) then
+                  Prim_Typ := Directly_Designated_Type (Prim_Typ);
+               end if;
+
+               --  Case of multiple interface types inside a parameter profile
+
+               --     (Obj_Param : in out Iface; ...; Param : Iface)
+
+               --  If the interface type is implemented, then the matching type
+               --  in the primitive should be the implementing record type.
+
+               if Ekind (Iface_Typ) = E_Record_Type
+                 and then Is_Interface (Iface_Typ)
+                 and then Is_Implemented (Ifaces_List, Iface_Typ)
+               then
+                  if Prim_Typ /= Typ then
+                     return False;
+                  end if;
+
+               --  The two parameters must be both mode and subtype conformant
+
+               elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
+                 or else not
+                   Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
+               then
+                  return False;
+               end if;
+
+               Next (Iface_Param);
+               Next (Prim_Param);
+            end loop;
+
+            --  One of the two lists contains more parameters than the other
+
+            if Present (Iface_Param) or else Present (Prim_Param) then
+               return False;
+            end if;
+
+            return True;
+         end Matches_Prefixed_View_Profile;
+
+      --  Start of processing for Check_Synchronized_Overriding
+
       begin
          Overridden_Subp := Empty;
 
-         --  Def_Id must be an entry or a subprogram
+         --  Def_Id must be an entry or a subprogram. We should skip predefined
+         --  primitives internally generated by the frontend; however at this
+         --  stage predefined primitives are still not fully decorated. As a
+         --  minor optimization we skip here internally generated subprograms.
 
-         if Ekind (Def_Id) /= E_Entry
-           and then Ekind (Def_Id) /= E_Function
-           and then Ekind (Def_Id) /= E_Procedure
+         if (Ekind (Def_Id) /= E_Entry
+              and then Ekind (Def_Id) /= E_Function
+              and then Ekind (Def_Id) /= E_Procedure)
+           or else not Comes_From_Source (Def_Id)
          then
             return;
          end if;
@@ -6429,19 +6604,25 @@ package body Sem_Ch6 is
             Typ := Scope (Def_Id);
             In_Scope := True;
 
-         --  The subprogram may be a primitive of a concurrent type
+         --  The enclosing scope is not a synchronized type and the subprogram
+         --  has no formals
 
-         elsif Present (First_Formal (Def_Id)) then
-            Formal_Typ := Etype (First_Formal (Def_Id));
+         elsif No (First_Formal (Def_Id)) then
+            return;
+
+         --  The subprogram has formals and hence it may be a primitive of a
+         --  concurrent type
+
+         else
+            Typ := Etype (First_Formal (Def_Id));
 
-            if Is_Access_Type (Formal_Typ) then
-               Formal_Typ := Directly_Designated_Type (Formal_Typ);
+            if Is_Access_Type (Typ) then
+               Typ := Directly_Designated_Type (Typ);
             end if;
 
-            if Is_Concurrent_Type (Formal_Typ)
-              and then not Is_Generic_Actual_Type (Formal_Typ)
+            if Is_Concurrent_Type (Typ)
+              and then not Is_Generic_Actual_Type (Typ)
             then
-               Typ := Formal_Typ;
                In_Scope := False;
 
             --  This case occurs when the concurrent type is declared within
@@ -6449,37 +6630,152 @@ package body Sem_Ch6 is
             --  built and used as the type of the first formal, we just have
             --  to retrieve the corresponding concurrent type.
 
-            elsif Is_Concurrent_Record_Type (Formal_Typ)
-              and then Present (Corresponding_Concurrent_Type (Formal_Typ))
+            elsif Is_Concurrent_Record_Type (Typ)
+              and then Present (Corresponding_Concurrent_Type (Typ))
             then
-               Typ := Corresponding_Concurrent_Type (Formal_Typ);
+               Typ := Corresponding_Concurrent_Type (Typ);
                In_Scope := False;
 
             else
                return;
             end if;
-         else
+         end if;
+
+         --  There is no overriding to check if is an inherited operation in a
+         --  type derivation on for a generic actual.
+
+         Collect_Interfaces (Typ, Ifaces_List);
+
+         if Is_Empty_Elmt_List (Ifaces_List) then
             return;
          end if;
 
-         --  Gather all limited, protected and task interfaces that Typ
-         --  implements. There is no overriding to check if is an inherited
-         --  operation in a type derivation on for a generic actual.
+         --  Determine whether entry or subprogram Def_Id overrides a primitive
+         --  operation that belongs to one of the interfaces in Ifaces_List.
 
-         if Nkind (Parent (Typ)) /= N_Full_Type_Declaration
-           and then
-             not Nkind_In (Parent (Def_Id), N_Subtype_Declaration,
-                                            N_Task_Type_Declaration,
-                                            N_Protected_Type_Declaration)
-         then
-            Collect_Interfaces (Typ, Ifaces_List);
+         declare
+            Candidate : Entity_Id := Empty;
+            Hom       : Entity_Id := Empty;
+            Iface_Typ : Entity_Id;
+            Subp      : Entity_Id := Empty;
+
+         begin
+            --  Traverse the homonym chain, looking at a potentially
+            --  overridden subprogram that belongs to an implemented
+            --  interface.
+
+            Hom := Current_Entity_In_Scope (Def_Id);
+            while Present (Hom) loop
+               Subp := Hom;
+
+               --  Entries can override abstract or null interface
+               --  procedures
+
+               if Ekind (Def_Id) = E_Entry
+                 and then Ekind (Subp) = E_Procedure
+                 and then Nkind (Parent (Subp)) = N_Procedure_Specification
+                 and then (Is_Abstract_Subprogram (Subp)
+                             or else Null_Present (Parent (Subp)))
+               then
+                  while Present (Alias (Subp)) loop
+                     Subp := Alias (Subp);
+                  end loop;
+
+                  if Matches_Prefixed_View_Profile
+                       (Parameter_Specifications (Parent (Def_Id)),
+                        Parameter_Specifications (Parent (Subp)))
+                  then
+                     Candidate := Subp;
 
-            if not Is_Empty_Elmt_List (Ifaces_List) then
-               Overridden_Subp :=
-                 Find_Overridden_Synchronized_Primitive
-                   (Def_Id, First_Hom, Ifaces_List, In_Scope);
+                     --  Absolute match
+
+                     if Has_Correct_Formal_Mode (Typ, Candidate) then
+                        Overridden_Subp := Candidate;
+                        return;
+                     end if;
+                  end if;
+
+               --  Procedures can override abstract or null interface
+               --  procedures
+
+               elsif Ekind (Def_Id) = E_Procedure
+                 and then Ekind (Subp) = E_Procedure
+                 and then Nkind (Parent (Subp)) = N_Procedure_Specification
+                 and then (Is_Abstract_Subprogram (Subp)
+                             or else Null_Present (Parent (Subp)))
+                 and then Matches_Prefixed_View_Profile
+                            (Parameter_Specifications (Parent (Def_Id)),
+                             Parameter_Specifications (Parent (Subp)))
+               then
+                  Candidate := Subp;
+
+                  --  Absolute match
+
+                  if Has_Correct_Formal_Mode (Typ, Candidate) then
+                     Overridden_Subp := Candidate;
+                     return;
+                  end if;
+
+               --  Functions can override abstract interface functions
+
+               elsif Ekind (Def_Id) = E_Function
+                 and then Ekind (Subp) = E_Function
+                 and then Nkind (Parent (Subp)) = N_Function_Specification
+                 and then Is_Abstract_Subprogram (Subp)
+                 and then Matches_Prefixed_View_Profile
+                            (Parameter_Specifications (Parent (Def_Id)),
+                             Parameter_Specifications (Parent (Subp)))
+                 and then Etype (Result_Definition (Parent (Def_Id))) =
+                          Etype (Result_Definition (Parent (Subp)))
+               then
+                  Overridden_Subp := Subp;
+                  return;
+               end if;
+
+               Hom := Homonym (Hom);
+            end loop;
+
+            --  After examining all candidates for overriding, we are
+            --  left with the best match which is a mode incompatible
+            --  interface routine. Do not emit an error if the Expander
+            --  is active since this error will be detected later on
+            --  after all concurrent types are expanded and all wrappers
+            --  are built. This check is meant for spec-only
+            --  compilations.
+
+            if Present (Candidate)
+              and then not Expander_Active
+            then
+               Iface_Typ :=
+                 Find_Parameter_Type (Parent (First_Formal (Candidate)));
+
+               --  Def_Id is primitive of a protected type, declared
+               --  inside the type, and the candidate is primitive of a
+               --  limited or synchronized interface.
+
+               if In_Scope
+                 and then Is_Protected_Type (Typ)
+                 and then
+                   (Is_Limited_Interface (Iface_Typ)
+                      or else Is_Protected_Interface (Iface_Typ)
+                      or else Is_Synchronized_Interface (Iface_Typ)
+                      or else Is_Task_Interface (Iface_Typ))
+               then
+                  --  Must reword this message, comma before to in -gnatj
+                  --  mode ???
+
+                  Error_Msg_NE
+                    ("first formal of & must be of mode `OUT`, `IN OUT`"
+                      & " or access-to-variable", Typ, Candidate);
+                  Error_Msg_N
+                    ("\to be overridden by protected procedure or entry "
+                      & "(RM 9.4(11.9/2))", Typ);
+               end if;
             end if;
-         end if;
+
+            Overridden_Subp := Candidate;
+            return;
+         end;
       end Check_Synchronized_Overriding;
 
       ----------------------------
@@ -6532,7 +6828,7 @@ package body Sem_Ch6 is
          --  has an overriding indicator.
 
          if Comes_From_Source (S) then
-            Check_Synchronized_Overriding (S, Homonym (S), Overridden_Subp);
+            Check_Synchronized_Overriding (S, Overridden_Subp);
             Check_Overriding_Indicator
               (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
          end if;
@@ -6609,7 +6905,7 @@ package body Sem_Ch6 is
             goto Add_New_Entity;
          end if;
 
-         Check_Synchronized_Overriding (S, E, Overridden_Subp);
+         Check_Synchronized_Overriding (S, Overridden_Subp);
 
          --  Loop through E and its homonyms to determine if any of them is
          --  the candidate for overriding by S.