[Ada] Legality checks on access-to-object types

[Arnaud Charlet]

Some checks on illegal uses of class-wide expressions do not apply to access_
to_subprograms. Use base type to determine whether an access subtype belongs
to the latter category.

The following must compile quietly in Ada205 mode:

package T is
   pragma Elaborate_Body;
end T;
---
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

package body T is
   type C is tagged null record;

   type Getter is access function return C'Class;
   package Getter_Maps is new Ada.Containers.Indefinite_Hashed_Maps
      (Key_Type        => String,
       Element_Type    => Getter,
       Hash            => Ada.Strings.Hash,
       Equivalent_Keys => "=");
   use Getter_Maps;

   M : Getter_Maps.Map := Getter_Maps.Empty_Map;
   G : Getter;

   function My_Get return C'Class is
      D : C;
   begin
      return D;
   end My_Get;

begin
   M.Insert ("foo", My_Get'Access);

   G := My_Get'Access;
   M.Insert ("foo", G);
end T;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-29  Ed Schonberg  <schonb...@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).


Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 178155)
+++ sem_res.adb (working copy)
@@ -3987,14 +3987,17 @@
                     ("& 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 @@
                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);