re PR ada/34366 (Legal program rejected, various anonymous access-to-subprogram types, Ada 2005)

    gcc/ada/
	PR ada/34366
	* sem_ch3.adb (Designates_T): New function.
	(Mentions_T): Factor reusable part of the logic into Designates_T.
	Consider non-access parameters and access and non-access result.
	(Check_Anonymous_Access_Components): Set ekind of anonymous access to
	E_Subprogram_Type to E_Anonymous_Access_Subprogram_Type.

	* einfo.ads: Update comment for E_Anonymous_Access_Subprogram_Type.

    gcc/testsuite/
	PR ada/34366
	* gnat.dg/enclosing_record_reference.ads,
	gnat.dg/enclosing_record_reference.adb: New test.

From-SVN: r130720

gcc/ada/ChangeLog

+2007-12-09  Samuel Tardieu  <sam@rfc1149.net>
+
+	PR ada/34366
+	* sem_ch3.adb (Designates_T): New function.
+	(Mentions_T): Factor reusable part of the logic into Designates_T.
+	Consider non-access parameters and access and non-access result.
+	(Check_Anonymous_Access_Components): Set ekind of anonymous access to
+	E_Subprogram_Type to E_Anonymous_Access_Subprogram_Type.
+
+	* einfo.ads: Update comment for E_Anonymous_Access_Subprogram_Type.
+
 2007-12-07  Ludovic Brenta  <ludovic@ludovic-brenta.org>
 
 	PR ada/34361

gcc/ada/einfo.ads

@@ -3786,7 +3786,9 @@ package Einfo is
 
       E_Anonymous_Access_Subprogram_Type,
       --  An anonymous access to subprogram type, created by an access to
-      --  subprogram declaration.
+      --  subprogram declaration, or generated for a current instance of
+      --  a type name appearing within a component definition that has an
+      --  anonymous access to subprogram type.
 
       E_Access_Protected_Subprogram_Type,
       --  An access to a protected subprogram, created by the corresponding

gcc/ada/sem_ch3.adb

@@ -15983,12 +15983,15 @@ package body Sem_Ch3 is
       --  This is done only once, and only if there is no previous partial
       --  view of the type.
 
+      function Designates_T (Subt : Node_Id) return Boolean;
+      --  Check whether a node designates the enclosing record type
+
       function Mentions_T (Acc_Def : Node_Id) return Boolean;
       --  Check whether an access definition includes a reference to
-      --  the enclosing record type. The reference can be a subtype
-      --  mark in the access definition itself, or a 'Class attribute
-      --  reference, or recursively a reference appearing in a parameter
-      --  type in an access_to_subprogram definition.
+      --  the enclosing record type. The reference can be a subtype mark
+      --  in the access definition itself, a 'Class attribute reference, or
+      --  recursively a reference appearing in a parameter specification
+      --  or result definition of an access_to_subprogram definition.
 
       --------------------------------------
       -- Build_Incomplete_Type_Declaration --
@@ -16071,12 +16074,12 @@ package body Sem_Ch3 is
          end if;
       end Build_Incomplete_Type_Declaration;
 
-      ----------------
-      -- Mentions_T --
-      ----------------
+      ------------------
+      -- Designates_T --
+      ------------------
+
+      function Designates_T (Subt : Node_Id) return Boolean is
 
-      function Mentions_T (Acc_Def : Node_Id) return Boolean is
-         Subt : Node_Id;
          Type_Id : constant Name_Id := Chars (Typ);
 
          function Names_T (Nam : Node_Id) return Boolean;
@@ -16113,75 +16116,94 @@ package body Sem_Ch3 is
             end if;
          end Names_T;
 
-      --  Start of processing for Mentions_T
+      --  Start of processing for Designates_T
 
       begin
-         if No (Access_To_Subprogram_Definition (Acc_Def)) then
-            Subt := Subtype_Mark (Acc_Def);
-
-            if Nkind (Subt) = N_Identifier then
-               return Chars (Subt) = Type_Id;
+         if Nkind (Subt) = N_Identifier then
+            return Chars (Subt) = Type_Id;
 
             --  Reference can be through an expanded name which has not been
             --  analyzed yet, and which designates enclosing scopes.
 
-            elsif Nkind (Subt) = N_Selected_Component then
-               if Names_T (Subt) then
-                  return True;
-
-               --  Otherwise it must denote an entity that is already visible.
-               --  The access definition may name a subtype of the enclosing
-               --  type, if there is a previous incomplete declaration for it.
-
-               else
-                  Find_Selected_Component (Subt);
-                  return
-                    Is_Entity_Name (Subt)
-                      and then Scope (Entity (Subt)) = Current_Scope
-                      and then (Chars (Base_Type (Entity (Subt))) = Type_Id
-                        or else
-                          (Is_Class_Wide_Type (Entity (Subt))
-                            and then
-                              Chars (Etype (Base_Type (Entity (Subt))))
-                                = Type_Id));
-               end if;
+         elsif Nkind (Subt) = N_Selected_Component then
+            if Names_T (Subt) then
+               return True;
 
-            --  A reference to the current type may appear as the prefix of
-            --  a 'Class attribute.
+            --  Otherwise it must denote an entity that is already visible.
+            --  The access definition may name a subtype of the enclosing
+            --  type, if there is a previous incomplete declaration for it.
 
-            elsif Nkind (Subt) = N_Attribute_Reference
-              and then Attribute_Name (Subt) = Name_Class
-            then
-               return Names_T (Prefix (Subt));
             else
-               return False;
+               Find_Selected_Component (Subt);
+               return
+                 Is_Entity_Name (Subt)
+                   and then Scope (Entity (Subt)) = Current_Scope
+                   and then
+                     (Chars (Base_Type (Entity (Subt))) = Type_Id
+                       or else
+                         (Is_Class_Wide_Type (Entity (Subt))
+                           and then
+                           Chars (Etype (Base_Type (Entity (Subt))))
+                             = Type_Id));
             end if;
 
+         --  A reference to the current type may appear as the prefix of
+         --  a 'Class attribute.
+
+         elsif Nkind (Subt) = N_Attribute_Reference
+           and then Attribute_Name (Subt) = Name_Class
+         then
+            return Names_T (Prefix (Subt));
+
          else
-            --  Component is an access_to_subprogram: examine its formals
+            return False;
+         end if;
+      end Designates_T;
 
-            declare
-               Param_Spec : Node_Id;
+      ----------------
+      -- Mentions_T --
+      ----------------
 
-            begin
-               Param_Spec :=
-                 First
-                   (Parameter_Specifications
-                     (Access_To_Subprogram_Definition (Acc_Def)));
-               while Present (Param_Spec) loop
-                  if Nkind (Parameter_Type (Param_Spec))
-                       = N_Access_Definition
-                    and then Mentions_T (Parameter_Type (Param_Spec))
-                  then
-                     return True;
-                  end if;
+      function Mentions_T (Acc_Def : Node_Id) return Boolean is
+         Param_Spec : Node_Id;
 
-                  Next (Param_Spec);
-               end loop;
+         Acc_Subprg : constant Node_Id :=
+           Access_To_Subprogram_Definition (Acc_Def);
 
-               return False;
-            end;
+      begin
+         if No (Acc_Subprg) then
+            return Designates_T (Subtype_Mark (Acc_Def));
          end if;
+
+         --  Component is an access_to_subprogram: examine its formals,
+         --  and result definition in the case of an access_to_function.
+
+         Param_Spec := First (Parameter_Specifications (Acc_Subprg));
+         while Present (Param_Spec) loop
+            if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
+              and then Mentions_T (Parameter_Type (Param_Spec))
+            then
+               return True;
+
+            elsif Designates_T (Parameter_Type (Param_Spec)) then
+               return True;
+            end if;
+
+            Next (Param_Spec);
+         end loop;
+
+         if Nkind (Acc_Subprg) = N_Access_Function_Definition then
+            if Nkind (Result_Definition (Acc_Subprg)) =
+                 N_Access_Definition
+            then
+               return Mentions_T (Result_Definition (Acc_Subprg));
+            else
+               return Designates_T (Result_Definition (Acc_Subprg));
+            end if;
+         end if;
+
+         return False;
+
       end Mentions_T;
 
    --  Start of processing for Check_Anonymous_Access_Components
@@ -16279,7 +16301,13 @@ package body Sem_Ch3 is
               Make_Component_Definition (Loc,
                 Subtype_Indication =>
                New_Occurrence_Of (Anon_Access, Loc)));
-            Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
+
+            if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
+               Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
+            else
+               Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
+            end if;
+
             Set_Is_Local_Anonymous_Access (Anon_Access);
          end if;
 

gcc/testsuite/ChangeLog

+2007-12-09  Samuel Tardieu  <sam@rfc1149.net>
+
+	PR ada/34366
+	* gnat.dg/enclosing_record_reference.ads,
+	gnat.dg/enclosing_record_reference.adb: New test.
+
 2007-12-09  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/32129

gcc/testsuite/gnat.dg/enclosing_record_reference.adb

+-- { dg-do compile }
+package body Enclosing_Record_Reference is
+
+    R: aliased T;
+
+    function F1 (x: integer) return T         is begin return R; end;
+    function F2 (x: T) return integer         is begin return 0; end;
+    function F3 (x: T) return T               is begin return R; end;
+    function F4 (x: integer) return access T  is begin return R'access; end;
+    function F5 (x: access T) return integer  is begin return 0; end;
+    function F6 (x: access T) return access T is begin return R'access; end;
+    function F7 (x: T) return access T        is begin return R'access; end;
+    function F8 (x: access T) return T        is begin return R; end;
+
+begin
+    R.F1 := F1'Access;
+    R.F2 := F2'Access;
+    R.F3 := F3'Access;
+    R.F4 := F4'Access;
+    R.F5 := F5'Access;
+    R.F6 := F6'Access;
+    R.F7 := F7'Access;
+    R.F8 := F8'Access;
+end Enclosing_Record_Reference;

gcc/testsuite/gnat.dg/enclosing_record_reference.ads

+package Enclosing_Record_Reference is
+  pragma elaborate_body;
+
+    type T is record
+        F1: access function(x: integer) return T;
+        F2: access function(x: T) return integer;             --??
+        F3: access function(x: T) return T;                   --??
+        F4: access function(x: integer) return access T;      --??
+        F5: access function(x: access T) return integer;
+        F6: access function(x: access T) return access T;
+        F7: access function(x: T) return access T;            --??
+        F8: access function(x: access T) return T;
+    end record;
+
+end Enclosing_Record_Reference;