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-interface/utils.c (create_label_decl): Add GNAT_NODE parameter
and invoke gnat_pushdecl on it. Remove obsolete settings.
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
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);
+}
\f
/* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
Every TYPE_DECL generated for a type definition must be passed
}
gcc_assert (Present (gnat_equiv) || type_annotate_only);
+
return gnat_equiv;
}
* *
* 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- *
/* 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
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)
{
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.
* gnat.dg/stack_usage1_pkg.ad[sb]: New helper.
--- /dev/null
+-- { dg-do compile }
+
+with Limited_With3_Pkg3;
+
+package body Limited_With3 is
+
+ procedure Dummy is begin null; end;
+
+end Limited_With3;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
+
--- /dev/null
+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;
OSDN Git Service
