From 1228a6a69b9fddc0aaa2b462db44d3d2bef4f22f Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 27 Jan 2012 09:22:36 +0000 Subject: [PATCH] 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 | 7 ++++ gcc/ada/gcc-interface/decl.c | 39 +++++++++++++++++++- gcc/ada/gcc-interface/gigi.h | 7 +++- gcc/ada/gcc-interface/trans.c | 19 ++++++++-- gcc/testsuite/ChangeLog | 7 ++++ gcc/testsuite/gnat.dg/limited_with3.adb | 9 +++++ gcc/testsuite/gnat.dg/limited_with3.ads | 17 +++++++++ gcc/testsuite/gnat.dg/limited_with3_pkg1.adb | 20 ++++++++++ gcc/testsuite/gnat.dg/limited_with3_pkg1.ads | 28 ++++++++++++++ gcc/testsuite/gnat.dg/limited_with3_pkg2.ads | 10 +++++ gcc/testsuite/gnat.dg/limited_with3_pkg3.ads | 12 ++++++ 11 files changed, 170 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/limited_with3.adb create mode 100644 gcc/testsuite/gnat.dg/limited_with3.ads create mode 100644 gcc/testsuite/gnat.dg/limited_with3_pkg1.adb create mode 100644 gcc/testsuite/gnat.dg/limited_with3_pkg1.ads create mode 100644 gcc/testsuite/gnat.dg/limited_with3_pkg2.ads create mode 100644 gcc/testsuite/gnat.dg/limited_with3_pkg3.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d11bb8e7d79..82ec65b1ca0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2012-01-27 Eric Botcazou + + * 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 * gcc-interface/gigi.h (create_label_decl): Adjust. diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index dbacaefa6bd..b0bf5865833 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/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; } diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 9b147439c86..00f64651de1 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/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 diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 4ba6fb39394..077d4a64769 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/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_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) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 572378b0316..7d4a19955be 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2012-01-27 Eric Botcazou + + * 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 * gnat.dg/stack_usage1.adb: New test. diff --git a/gcc/testsuite/gnat.dg/limited_with3.adb b/gcc/testsuite/gnat.dg/limited_with3.adb new file mode 100644 index 00000000000..36419246f78 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/limited_with3.ads b/gcc/testsuite/gnat.dg/limited_with3.ads new file mode 100644 index 00000000000..c348d90444c --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/limited_with3_pkg1.adb b/gcc/testsuite/gnat.dg/limited_with3_pkg1.adb new file mode 100644 index 00000000000..6a7d92b41e0 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/limited_with3_pkg1.ads b/gcc/testsuite/gnat.dg/limited_with3_pkg1.ads new file mode 100644 index 00000000000..622b4fe49a8 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/limited_with3_pkg2.ads b/gcc/testsuite/gnat.dg/limited_with3_pkg2.ads new file mode 100644 index 00000000000..f81bb7e0d59 --- /dev/null +++ b/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; + diff --git a/gcc/testsuite/gnat.dg/limited_with3_pkg3.ads b/gcc/testsuite/gnat.dg/limited_with3_pkg3.ads new file mode 100644 index 00000000000..e408182c681 --- /dev/null +++ b/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; -- 2.30.2