sem_type.adb (Has_Compatible_Type): Complete support for synchronized types when...

2008-07-31  Javier Miranda  <miranda@adacore.com>

	* sem_type.adb (Has_Compatible_Type): Complete support for synchronized
	types when the candidate type is a synchronized type.
	
	* sem_res.adb (Resolve_Actuals): Reorganize code handling synchronized
	types, and complete management of synchronized types adding missing
	code to handle formal that is a synchronized type.
	
	* sem_ch4.adb (Try_Primitive_Operation): Avoid testing attributes that
	are not available and cause the compiler to blowup. Found compiling
	test with switch -gnatc
	
	* sem_ch6.adb (Check_Synchronized_Overriding): Remove local subprogram
	Has_Correct_Formal_Mode plus code cleanup.

From-SVN: r138400

4 files changed, 100 insertions, 93 deletions

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index e14fb43..4994ac8 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -6414,6 +6414,10 @@ package body Sem_Ch4 is
          --  corresponding record (base) type.
 
          if Is_Concurrent_Type (Obj_Type) then
+            if not Present (Corresponding_Record_Type (Obj_Type)) then
+               return False;
+            end if;
+
             Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
             Elmt := First_Elmt (Primitive_Operations (Corr_Type));
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index b378be4..33cb73d 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6599,12 +6599,6 @@ package body Sem_Ch6 is
          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;
@@ -6613,39 +6607,6 @@ package body Sem_Ch6 is
          --  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 --
          -----------------------------------
@@ -6723,15 +6684,15 @@ package body Sem_Ch6 is
                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);
+               if Ekind (Iface_Typ) = E_Anonymous_Access_Type
+                 and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
+                 and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
+               then
+                  Iface_Typ := Designated_Type (Iface_Typ);
+                  Prim_Typ := Designated_Type (Prim_Typ);
                end if;
 
                --  Case of multiple interface types inside a parameter profile
@@ -6864,60 +6825,63 @@ package body Sem_Ch6 is
             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)))
+               if Subp = Def_Id
+                 or else not Is_Overloadable (Subp)
+                 or else not Is_Primitive (Subp)
+                 or else not Is_Dispatching_Operation (Subp)
+                 or else not Is_Interface (Find_Dispatching_Type (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;
-
-                     --  Absolute match
-
-                     if Has_Correct_Formal_Mode (Typ, Candidate) then
-                        Overridden_Subp := Candidate;
-                        return;
-                     end if;
-                  end if;
+                  null;
 
-               --  Procedures can override abstract or null interface
-               --  procedures
+               --  Entries and procedures can override abstract or null
+               --  interface procedures
 
-               elsif Ekind (Def_Id) = E_Procedure
+               elsif (Ekind (Def_Id) = E_Procedure
+                        or else 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)))
                  and then Matches_Prefixed_View_Profile
                             (Parameter_Specifications (Parent (Def_Id)),
                              Parameter_Specifications (Parent (Subp)))
                then
                   Candidate := Subp;
 
-                  --  Absolute match
+                  --  For an overridden subprogram Subp, check whether the mode
+                  --  of its first parameter is correct depending on the kind
+                  --  of synchronized type.
 
-                  if Has_Correct_Formal_Mode (Typ, Candidate) then
-                     Overridden_Subp := Candidate;
-                     return;
-                  end if;
+                  declare
+                     Formal : constant Node_Id := First_Formal (Candidate);
+
+                  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 (Candidate) = E_Entry
+                         or else Ekind (Candidate) = E_Procedure)
+                       and then Is_Protected_Type (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
+                        null;
+
+                     --  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.
+
+                     else
+                        Overridden_Subp := Candidate;
+                        return;
+                     end if;
+                  end;
 
                --  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)))
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index a6d42f7..e011868 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3218,16 +3218,48 @@ package body Sem_Res is
                --   or because it is a generic actual, so use base type to
                --   locate concurrent type.
 
-               if Is_Concurrent_Type (Etype (A))
-                 and then Etype (F) =
-                            Corresponding_Record_Type (Base_Type (Etype (A)))
-               then
-                  Rewrite (A,
-                    Unchecked_Convert_To
-                      (Corresponding_Record_Type (Etype (A)), A));
-               end if;
+               A_Typ := Base_Type (Etype (A));
+               F_Typ := Base_Type (Etype (F));
+
+               declare
+                  Full_A_Typ : Entity_Id;
+
+               begin
+                  if Present (Full_View (A_Typ)) then
+                     Full_A_Typ := Base_Type (Full_View (A_Typ));
+                  else
+                     Full_A_Typ := A_Typ;
+                  end if;
 
-               Resolve (A, Etype (F));
+                  --  Tagged synchronized type (case 1): the actual is a
+                  --  concurrent type
+
+                  if Is_Concurrent_Type (A_Typ)
+                    and then Corresponding_Record_Type (A_Typ) = F_Typ
+                  then
+                     Rewrite (A,
+                       Unchecked_Convert_To
+                         (Corresponding_Record_Type (A_Typ), A));
+                     Resolve (A, Etype (F));
+
+                  --  Tagged synchronized type (case 2): the formal is a
+                  --  concurrent type
+
+                  elsif Ekind (Full_A_Typ) = E_Record_Type
+                    and then Present
+                               (Corresponding_Concurrent_Type (Full_A_Typ))
+                    and then Is_Concurrent_Type (F_Typ)
+                    and then Present (Corresponding_Record_Type (F_Typ))
+                    and then Full_A_Typ = Corresponding_Record_Type (F_Typ)
+                  then
+                     Resolve (A, Corresponding_Record_Type (F_Typ));
+
+                  --  Common case
+
+                  else
+                     Resolve (A, Etype (F));
+                  end if;
+               end;
             end if;
 
             A_Typ := Etype (A);
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 4a170d8..aae54d1 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -2106,11 +2106,18 @@ package body Sem_Type is
             --  to check whether it is a proper descendant.
 
            or else
-             (Is_Concurrent_Type (Etype (N))
+             (Is_Record_Type (Typ)
+                and then Is_Concurrent_Type (Etype (N))
                 and then Present (Corresponding_Record_Type (Etype (N)))
                 and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
 
            or else
+             (Is_Concurrent_Type (Typ)
+                and then Is_Record_Type (Etype (N))
+                and then Present (Corresponding_Record_Type (Typ))
+                and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
+
+           or else
              (not Is_Tagged_Type (Typ)
                 and then Ekind (Typ) /= E_Anonymous_Access_Type
                 and then Covers (Etype (N), Typ));