sem_res.adb (Resolve_Actuals): Use base type to determine whether an access subtype...

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Actuals): Use base type to determine whether an
	access subtype is access_to_subprogram, when applying checks for
	RM 3.10.2 (27).

From-SVN: r178185

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 608b8c03f3bb66932ada9b99442bc930c2f42345..bae5e1ba533a6e4521eea1ce697ea5a080a4ec03 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2011-08-29  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_res.adb (Resolve_Actuals): Use base type to determine whether an
+       access subtype is access_to_subprogram, when applying checks for
+       RM 3.10.2 (27).
+
 2011-08-29  Matthew Heaney  <heaney@adacore.com>
 
        * a-comutr.adb, a-cimutr.adb, a-cbmutr.adb (Splice_Subtree): Only check

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 4de5c3d6a684bbf9490f59e53e1096702b2276ce..51e4f4319c2add134313e188aa190aae015b3a01 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3987,14 +3987,17 @@ package body Sem_Res is
                     ("& is not a dispatching operation of &!", A, Nam);
                end if;
 
+            --  Apply the checks described in 3.10.2(27): if the context is a
+            --  specific access-to-object, the actual cannot be class-wide.
+            --  Use base type to exclude access_to_subprogram cases.
+
             elsif Is_Access_Type (A_Typ)
               and then Is_Access_Type (F_Typ)
-              and then Ekind (F_Typ) /= E_Access_Subprogram_Type
-              and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type
+              and then not Is_Access_Subprogram_Type (Base_Type (F_Typ))
               and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
                          or else (Nkind (A) = N_Attribute_Reference
                                    and then
-                                     Is_Class_Wide_Type (Etype (Prefix (A)))))
+                                  Is_Class_Wide_Type (Etype (Prefix (A)))))
               and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
               and then not Is_Controlling_Formal (F)
 
@@ -4008,9 +4011,7 @@ package body Sem_Res is
                Error_Msg_N
                  ("access to class-wide argument not allowed here!", A);
 
-               if Is_Subprogram (Nam)
-                 and then Comes_From_Source (Nam)
-               then
+               if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then
                   Error_Msg_Node_2 := Designated_Type (F_Typ);
                   Error_Msg_NE
                     ("& is not a dispatching operation of &!", A, Nam);