gigi.h (get_minimal_subprog_decl): Declare.

* gcc-interface/gigi.h (get_minimal_subprog_decl): Declare.
	* gcc-interface/decl.c (get_minimal_subprog_decl): New function.
	* gcc-interface/trans.c (Attribute_to_gnu): Use it for the prefix of an
	Access-like attribute in a dispatch table if the subprogram is public.

From-SVN: r183607

gcc/ada/ChangeLog

@@ -1,3 +1,10 @@
+2012-01-27  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/gigi.h (get_minimal_subprog_decl): Declare.
+	* gcc-interface/decl.c (get_minimal_subprog_decl): New function.
+	* gcc-interface/trans.c (Attribute_to_gnu): Use it for the prefix of an
+	Access-like attribute in a dispatch table if the subprogram is public.
+
 2012-01-27  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc-interface/gigi.h (create_label_decl): Adjust.

gcc/ada/gcc-interface/decl.c

@@ -3769,7 +3769,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    break;
 	  }
 
-	/* If we have not done it yet, build the pointer type the usual way.  */
+	/* If we haven't done it yet, build the pointer type the usual way.  */
 	if (!gnu_type)
 	  {
 	    /* Modify the designated type if we are pointing only to constant
@@ -5229,6 +5229,42 @@ get_unpadded_type (Entity_Id gnat_entity)
 
   return type;
 }
+
+/* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
+   type has been changed to that of the parameterless procedure, except if an
+   alias is already present, in which case it is returned instead.  */
+
+tree
+get_minimal_subprog_decl (Entity_Id gnat_entity)
+{
+  tree gnu_entity_name, gnu_ext_name;
+  struct attrib *attr_list = NULL;
+
+  /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
+     of the handling applied here.  */
+
+  while (Present (Alias (gnat_entity)))
+    {
+      gnat_entity = Alias (gnat_entity);
+      if (present_gnu_tree (gnat_entity))
+	return get_gnu_tree (gnat_entity);
+    }
+
+  gnu_entity_name = get_entity_name (gnat_entity);
+  gnu_ext_name = create_concat_name (gnat_entity, NULL);
+
+  if (Has_Stdcall_Convention (gnat_entity))
+    prepend_one_attribute_to (&attr_list, ATTR_MACHINE_ATTRIBUTE,
+			      get_identifier ("stdcall"), NULL_TREE,
+			      gnat_entity);
+
+  if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
+    gnu_ext_name = NULL_TREE;
+
+  return
+    create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE,
+			 false, true, true, true, attr_list, gnat_entity);
+}
 
 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
    Every TYPE_DECL generated for a type definition must be passed
@@ -5333,6 +5369,7 @@ Gigi_Equivalent_Type (Entity_Id gnat_entity)
     }
 
   gcc_assert (Present (gnat_equiv) || type_annotate_only);
+
   return gnat_equiv;
 }
 

gcc/ada/gcc-interface/gigi.h

@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2011, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2012, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -118,6 +118,11 @@ extern void mark_out_of_scope (Entity_Id gnat_entity);
 /* Get the unpadded version of a GNAT type.  */
 extern tree get_unpadded_type (Entity_Id gnat_entity);
 
+/* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
+   type has been changed to that of the parameterless procedure, except if an
+   alias is already present, in which case it is returned instead.  */
+extern tree get_minimal_subprog_decl (Entity_Id gnat_entity);
+
 /* Create a record type that contains a SIZE bytes long field of TYPE with a
     starting bit position so that it is aligned to ALIGN bits, and leaving at
     least ROOM bytes free before the field.  BASE_ALIGN is the alignment the

gcc/ada/gcc-interface/trans.c

@@ -1232,11 +1232,24 @@ Pragma_to_gnu (Node_Id gnat_node)
 static tree
 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 {
-  tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
+  tree gnu_prefix, gnu_type, gnu_expr;
-  tree gnu_type = TREE_TYPE (gnu_prefix);
+  tree gnu_result_type, gnu_result = error_mark_node;
-  tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
   bool prefix_unused = false;
 
+  /* ??? If this is an access attribute for a public subprogram to be used in
+     a dispatch table, do not translate its type as it's useless there and the
+     parameter types might be incomplete types coming from a limited with.  */
+  if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
+      && Is_Dispatch_Table_Entity (Etype (gnat_node))
+      && Nkind (Prefix (gnat_node)) == N_Identifier
+      && Is_Subprogram (Entity (Prefix (gnat_node)))
+      && Is_Public (Entity (Prefix (gnat_node)))
+      && !present_gnu_tree (Entity (Prefix (gnat_node))))
+    gnu_prefix = get_minimal_subprog_decl (Entity (Prefix (gnat_node)));
+  else
+    gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
+  gnu_type = TREE_TYPE (gnu_prefix);
+
   /* If the input is a NULL_EXPR, make a new one.  */
   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
     {

gcc/testsuite/ChangeLog

@@ -1,3 +1,10 @@
+2012-01-27  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/limited_with3.ad[sb): New test.
+	* gnat.dg/limited_with3_pkg1.ad[sb]: New helper.
+	* gnat.dg/limited_with3_pkg2.ads: Likewise.
+	* gnat.dg/limited_with3_pkg3.ads: Likewise.
+
 2012-01-27  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/stack_usage1.adb: New test.

gcc/testsuite/gnat.dg/limited_with3.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+
+with Limited_With3_Pkg3;
+
+package body Limited_With3 is
+
+  procedure Dummy is begin null; end;
+
+end Limited_With3;

gcc/testsuite/gnat.dg/limited_with3.ads

@@ -0,0 +1,17 @@
+with Limited_With3_Pkg1;
+with Limited_With3_Pkg2;
+limited with Limited_With3_Pkg3;
+
+package Limited_With3 is
+
+     procedure Dummy;
+
+     type T is tagged private;
+
+private
+
+     package My_Q is new Limited_With3_Pkg1 (Limited_With3_Pkg2.T);
+
+     type T is tagged null record;
+
+end Limited_With3;

gcc/testsuite/gnat.dg/limited_with3_pkg1.adb

@@ -0,0 +1,20 @@
+with Ada.Strings.Fixed.Hash;
+
+package body Limited_With3_Pkg1 is
+
+     function Equal ( Left, Right : Element_Access) return Boolean is
+     begin
+        return True;
+     end;
+
+     function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
+     begin
+        return True;
+     end;
+
+     function Hash (Key : Key_Type) return Ada.Containers.Hash_Type is
+     begin
+         return Ada.Strings.Fixed.Hash (Key.all);
+     end Hash;
+
+end Limited_With3_Pkg1;

gcc/testsuite/gnat.dg/limited_with3_pkg1.ads

@@ -0,0 +1,28 @@
+with Ada.Containers.Hashed_Maps;
+
+generic
+
+     type Object_Type is tagged private;
+
+package Limited_With3_Pkg1 is
+
+     type Key_Type is access all String;
+
+     type Element_Type is new Object_Type with null record;
+
+     type Element_Access is access all Element_Type;
+
+     function Equal (Left, Right : Element_Access) return Boolean;
+
+     function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+
+     function Hash (Key : Key_Type) return Ada.Containers.Hash_Type;
+
+     package Table_Package is new Ada.Containers.Hashed_Maps (
+         Key_Type            => Key_Type,
+         Element_Type        => Element_Access,
+         Hash                => Hash,
+         Equivalent_Keys     => Equivalent_Keys,
+         "="                 => Equal);
+
+end Limited_With3_Pkg1;

gcc/testsuite/gnat.dg/limited_with3_pkg2.ads

@@ -0,0 +1,10 @@
+limited with Limited_With3_Pkg3;
+
+package Limited_With3_Pkg2 is
+
+    type T is tagged null record;
+
+    procedure Proc (X : Limited_With3_Pkg3.TT; Y : T);
+
+end Limited_With3_Pkg2;
+

gcc/testsuite/gnat.dg/limited_with3_pkg3.ads

@@ -0,0 +1,12 @@
+with Limited_With3;
+with Limited_With3_Pkg1;
+
+package Limited_With3_Pkg3 is
+
+    package My_Q is new Limited_With3_Pkg1 (Limited_With3.T);
+
+    type TT is tagged record
+       State : My_Q.Element_Access;
+    end record;
+
+end Limited_With3_Pkg3;