This isn't a regression either, but the fix shouldn't change the generated
code. It's a crash on code involving a complicated mix of limited with and
generics. As usual with limited with, we have an underlying circularity and
we should break it on the pointer whose designated type is a limited view.
Except that, in this case, this goes through a static dispatch table: the
pointer is a function pointer so the existing mechanism doesn't apply.
As devising a more general mechanism seems overkill to me at this point, I came
up with the attached patch which deals with dispatch tables specially.
Tested on i586-suse-linux, applied on the mainline.
2012-01-27 Eric Botcazou <ebotca...@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 <ebotca...@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.
--
Eric Botcazou
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 183606)
+++ gcc-interface/decl.c (working copy)
@@ -3769,7 +3769,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
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_ent
}
gcc_assert (Present (gnat_equiv) || type_annotate_only);
+
return gnat_equiv;
}
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h (revision 183606)
+++ gcc-interface/gigi.h (working copy)
@@ -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
/* 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
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 183606)
+++ gcc-interface/trans.c (working copy)
@@ -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_type = TREE_TYPE (gnu_prefix);
- tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
+ tree gnu_prefix, gnu_type, gnu_expr;
+ tree 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)
{
-- { dg-do compile }
with Limited_With3_Pkg3;
package body Limited_With3 is
procedure Dummy is begin null; end;
end Limited_With3;
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;
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;
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;
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;
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;
