From: Eric Botcazou Date: Thu, 15 May 2008 10:53:49 +0000 (+0000) Subject: trans.c (add_decl_expr): At toplevel, mark the TYPE_ADA_SIZE field of records and... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f730e42f04d17e187fa77e1b07eb5aaed554ad5e;p=gcc.git trans.c (add_decl_expr): At toplevel, mark the TYPE_ADA_SIZE field of records and unions. * trans.c (add_decl_expr): At toplevel, mark the TYPE_ADA_SIZE field of records and unions. (gnat_to_gnu) : Fix formatting. From-SVN: r135333 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b473b8e6fc2..83e9177af71 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2008-05-15 Eric Botcazou + + * trans.c (add_decl_expr): At toplevel, mark the TYPE_ADA_SIZE field + of records and unions. + (gnat_to_gnu) : Fix formatting. + 2008-05-14 Samuel Tardieu Robert Dewar diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 122857a9bbd..f7dd9b9aadf 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -4778,31 +4778,31 @@ gnat_to_gnu (Node_Id gnat_node) case N_Validate_Unchecked_Conversion: /* If the result is a pointer type, see if we are either converting - from a non-pointer or from a pointer to a type with a different - alias set and warn if so. If the result defined in the same unit as - this unchecked conversion, we can allow this because we can know to - make that type have alias set 0. */ + from a non-pointer or from a pointer to a type with a different + alias set and warn if so. If the result defined in the same unit as + this unchecked conversion, we can allow this because we can know to + make that type have alias set 0. */ { - tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node)); - tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node)); - - if (POINTER_TYPE_P (gnu_target_type) - && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node) - && get_alias_set (TREE_TYPE (gnu_target_type)) != 0 - && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node))) - && (!POINTER_TYPE_P (gnu_source_type) - || (get_alias_set (TREE_TYPE (gnu_source_type)) - != get_alias_set (TREE_TYPE (gnu_target_type))))) - { - post_error_ne - ("?possible aliasing problem for type&", - gnat_node, Target_Type (gnat_node)); + tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node)); + tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node)); + + if (POINTER_TYPE_P (gnu_target_type) + && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node) + && get_alias_set (TREE_TYPE (gnu_target_type)) != 0 + && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node))) + && (!POINTER_TYPE_P (gnu_source_type) + || (get_alias_set (TREE_TYPE (gnu_source_type)) + != get_alias_set (TREE_TYPE (gnu_target_type))))) + { + post_error_ne + ("?possible aliasing problem for type&", + gnat_node, Target_Type (gnat_node)); post_error - ("\\?use -fno-strict-aliasing switch for references", - gnat_node); + ("\\?use -fno-strict-aliasing switch for references", + gnat_node); post_error_ne - ("\\?or use `pragma No_Strict_Aliasing (&);`", - gnat_node, Target_Type (gnat_node)); + ("\\?or use `pragma No_Strict_Aliasing (&);`", + gnat_node, Target_Type (gnat_node)); } /* The No_Strict_Aliasing flag is not propagated to the back-end for @@ -5055,7 +5055,7 @@ void add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) { tree type = TREE_TYPE (gnu_decl); - tree gnu_stmt, gnu_init, gnu_lhs; + tree gnu_stmt, gnu_init, t; /* If this is a variable that Gigi is to ignore, we may have been given an ERROR_MARK. So test for it. We also might have been given a @@ -5074,7 +5074,7 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) if (global_bindings_p ()) { /* Mark everything as used to prevent node sharing with subprograms. - Note that walk_tree knows how to handle TYPE_DECL, but neither + Note that walk_tree knows how to deal with TYPE_DECL, but neither VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */ walk_tree (&gnu_stmt, mark_visited, NULL, NULL); if (TREE_CODE (gnu_decl) == VAR_DECL @@ -5084,6 +5084,13 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) walk_tree (&DECL_SIZE_UNIT (gnu_decl), mark_visited, NULL, NULL); walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL); } + /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */ + if (TREE_CODE (gnu_decl) == TYPE_DECL + && (TREE_CODE (type) == RECORD_TYPE + || TREE_CODE (type) == UNION_TYPE + || TREE_CODE (type) == QUAL_UNION_TYPE) + && (t = TYPE_ADA_SIZE (type))) + walk_tree (&t, mark_visited, NULL, NULL); } else add_stmt_with_node (gnu_stmt, gnat_entity); @@ -5100,11 +5107,11 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) /* If GNU_DECL has a padded type, convert it to the unpadded type so the assignment is done properly. */ if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) - gnu_lhs = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl); + t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl); else - gnu_lhs = gnu_decl; + t = gnu_decl; - gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_init); + gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, t, gnu_init); DECL_INITIAL (gnu_decl) = NULL_TREE; if (TREE_READONLY (gnu_decl)) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4c08485a0bd..10769c8b2c3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2008-05-15 Eric Botcazou + + * gnat.dg/discr8.ad[sb]: New test. + * gnat.dg/discr8_pkg[123].ads: New helpers. + 2008-05-15 H.J. Lu * gcc.target/i386/sse-set-ps-1.c: New. diff --git a/gcc/testsuite/gnat.dg/discr8.adb b/gcc/testsuite/gnat.dg/discr8.adb new file mode 100644 index 00000000000..cfb3d48e9d0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8.adb @@ -0,0 +1,38 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package body Discr8 is + + procedure Make (C : out Local_T) is + Tmp : Local_T (Tag_One); + begin + C := Tmp; + end; + + package Iteration is + + type Message_T is + record + S : Local_T; + end record; + + type Iterator_T is + record + S : Local_T; + end record; + + type Access_Iterator_T is access Iterator_T; + + end Iteration; + + package body Iteration is + + procedure Construct (Iterator : in out Access_Iterator_T; + Message : Message_T) is + begin + Iterator.S := Message.S; + end; + + end Iteration; + +end Discr8; diff --git a/gcc/testsuite/gnat.dg/discr8.ads b/gcc/testsuite/gnat.dg/discr8.ads new file mode 100644 index 00000000000..80dd2f652ce --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8.ads @@ -0,0 +1,20 @@ +with Discr8_Pkg1; use Discr8_Pkg1; + +package Discr8 is + + type Tag_T is (Tag_One, Tag_Two); + + type Local_T (Tag : Tag_T := Tag_One) is + record + case Tag is + when Tag_One => + A : T; + B : Integer; + when Tag_Two => + null; + end case; + end record; + + procedure Make (C : out Local_T); + +end Discr8; diff --git a/gcc/testsuite/gnat.dg/discr8_pkg1.ads b/gcc/testsuite/gnat.dg/discr8_pkg1.ads new file mode 100644 index 00000000000..ae93dc4d402 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8_pkg1.ads @@ -0,0 +1,11 @@ +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Discr8_Pkg2; use Discr8_Pkg2; + +package Discr8_Pkg1 is + + type T is record + A : Unbounded_String; + B : L; + end record; + +end Discr8_Pkg1; diff --git a/gcc/testsuite/gnat.dg/discr8_pkg2.ads b/gcc/testsuite/gnat.dg/discr8_pkg2.ads new file mode 100644 index 00000000000..f98318a5aca --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8_pkg2.ads @@ -0,0 +1,13 @@ +with Discr8_Pkg3; use Discr8_Pkg3; + +package Discr8_Pkg2 is + + Max : constant Natural := Value; + + type List_T is array (Natural range <>) of Integer; + + type L is record + List : List_T (1 .. Max); + end record; + +end Discr8_Pkg2; diff --git a/gcc/testsuite/gnat.dg/discr8_pkg3.ads b/gcc/testsuite/gnat.dg/discr8_pkg3.ads new file mode 100644 index 00000000000..576b40fab9d --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8_pkg3.ads @@ -0,0 +1,3 @@ +package Discr8_Pkg3 is + function Value return Natural; +end Discr8_Pkg3;