We failed to use the padded type for the renaming as in the non-private case.
Tested on i586-suse-linux, applied on the mainline.
2012-05-06 Eric Botcazou <[email protected]>
* gcc-interface/decl.c (gnat_to_gnu_entity) <object>: In the renaming
case, use the padded type if the renamed object has an unconstrained
type with default discriminant.
2012-05-06 Eric Botcazou <[email protected]>
* gnat.dg/specs/renamings.ads: Rename to...
* gnat.dg/specs/renaming1.ads: ...this.
* gnat.dg/specs/renaming2.ads: New test.
* gnat.dg/specs/renaming2_pkg1.ads: New helper.
* gnat.dg/specs/renaming2_pkg2.ads: Likewise.
* gnat.dg/specs/renaming2_pkg3.ads: Likewise.
* gnat.dg/specs/renaming2_pkg4.ad[sb]: Likewise.
--
Eric Botcazou
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 187206)
+++ gcc-interface/decl.c (working copy)
@@ -938,6 +938,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
gnu_type = TREE_TYPE (gnu_expr);
}
+ /* Or else, if the renamed object has an unconstrained type with
+ default discriminant, use the padded type. */
+ else if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_expr))
+ && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_expr)))
+ == gnu_type
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
+ gnu_type = TREE_TYPE (gnu_expr);
+
/* Case 1: If this is a constant renaming stemming from a function
call, treat it as a normal object whose initial value is what
is being renamed. RM 3.3 says that the result of evaluating a
-- { dg-do compile }
with Renaming2_Pkg1;
package Renaming2 is
type T is null record;
package Iter is new Renaming2_Pkg1.GP.Inner (T);
end Renaming2;
-- { dg-excess-errors "no code generated" }
with Renaming2_Pkg2;
with Renaming2_Pkg3;
with Renaming2_Pkg4;
package Renaming2_Pkg1 is
package Impl is new
Renaming2_Pkg3 (Base_Index_T => Positive, Value_T => Renaming2_Pkg2.Root);
use Impl;
package GP is new
Renaming2_Pkg4 (Length_T => Impl.Length_T, Value_T => Renaming2_Pkg2.Root);
end Renaming2_Pkg1;
package Renaming2_Pkg2 is
type Root is private;
private
type Root (D : Boolean := False) is record
case D is
when True => N : Natural;
when False => null;
end case;
end record;
end Renaming2_Pkg2;
-- { dg-excess-errors "no code generated" }
generic
type Base_Index_T is range <>;
type Value_T is private;
package Renaming2_Pkg3 is
type T is private;
subtype Length_T is Base_Index_T range 0 .. Base_Index_T'Last;
function Value (L : Length_T) return Value_T;
function Next return Length_T;
private
type Obj_T is null record;
type T is access Obj_T;
end Renaming2_Pkg3;
package body Renaming2_Pkg4 is
package body Inner is
function Next_Value return Value_T is
Next_Value : Value_T renames Value (Next);
begin
return Next_Value;
end Next_Value;
end Inner;
end Renaming2_Pkg4;
-- { dg-excess-errors "no code generated" }
generic
type Length_T is range <>;
with function Next return Length_T is <>;
type Value_T is private;
with function Value (L : Length_T) return Value_T is <>;
package Renaming2_Pkg4 is
generic
type T is private;
package Inner is
type Slave_T is tagged null record;
function Next_Value return Value_T;
end Inner;
end Renaming2_Pkg4;
