[Ada] Fix spurious aliasing warning for subtype of private type

[Eric Botcazou <ebotcazou at adacore dot com>]

Although the Ada type system provides strong enough guarantees to make a safe 
and effective usage of -fstrict-aliasing, there is an explicit "unsafe" 
construct (Unchecked_Conversion) for which these guarantees aren't valid any 
more.  That's why GNAT also provides the No_Strict_Aliasing pragma (mapped to 
TYPE_REF_CAN_ALIAS_ALL in the GCC IL) and issues a warning when it runs into 
such a problematic Unchecked_Conversion.

The attached testcase exhibits a false positive case for this warning, stemming 
from gigi trying to second-guess the front-end instead of computing the exact 
predicate, because it cannot compute it in all cases by the time it encounters 
the N_Validate_Unchecked_Conversion node.

Fixed by waiting until the very end of the translation to issue the warning.

Tested on i586-suse-linux, applied on the mainline.


2012-04-30  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/gigi.h (mark_out_of_scope): Delete.
	(destroy_gnat_to_gnu): Declare.
	(destroy_dummy_type): Likewise.
	* gcc-interface/decl.c (mark_out_of_scope): Delete.
	* gcc-interface/utils.c (destroy_gnat_to_gnu): New function.
	(destroy_dummy_type): Likewise.
	* gcc-interface/trans.c (gnat_validate_uc_list): New variable.
	(gigi): Call validate_unchecked_conversion on gnat_validate_uc_list
	after the translation is completed.  Call destroy_gnat_to_gnu and
	destroy_dummy_type at the end.
	(Subprogram_Body_to_gnu): Do not call mark_out_of_scope.
	(gnat_to_gnu) <N_Block_Statement>: Likewise.
	<N_Validate_Unchecked_Conversion>: Do not process the node, only push
	it onto gnat_validate_uc_list.
	(validate_unchecked_conversion): New function.


2012-04-30  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/warn6.ad[sb]: New test.


-- 
Eric Botcazou

Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c	(revision 186945)
+++ gcc-interface/utils.c	(working copy)
@@ -231,6 +231,15 @@ init_gnat_to_gnu (void)
   associate_gnat_to_gnu = ggc_alloc_cleared_vec_tree (max_gnat_nodes);
 }
 
+/* Destroy the association of GNAT nodes to GCC trees.  */
+
+void
+destroy_gnat_to_gnu (void)
+{
+  ggc_free (associate_gnat_to_gnu);
+  associate_gnat_to_gnu = NULL;
+}
+
 /* GNAT_ENTITY is a GNAT tree node for an entity.  Associate GNU_DECL, a GCC
    tree node, with GNAT_ENTITY.  If GNU_DECL is not a ..._DECL node, abort.
    If NO_CHECK is true, the latter check is suppressed.
@@ -280,6 +289,15 @@ init_dummy_type (void)
   dummy_node_table = ggc_alloc_cleared_vec_tree (max_gnat_nodes);
 }
 
+/* Destroy the association of GNAT nodes to GCC trees as dummies.  */
+
+void
+destroy_dummy_type (void)
+{
+  ggc_free (dummy_node_table);
+  dummy_node_table = NULL;
+}
+
 /* Make a dummy type corresponding to GNAT_TYPE.  */
 
 tree
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 186945)
+++ gcc-interface/decl.c	(working copy)
@@ -5838,44 +5838,6 @@ elaborate_entity (Entity_Id gnat_entity)
     }
 }
 
-/* Mark GNAT_ENTITY as going out of scope at this point.  Recursively mark
-   any entities on its entity chain similarly.  */
-
-void
-mark_out_of_scope (Entity_Id gnat_entity)
-{
-  Entity_Id gnat_sub_entity;
-  unsigned int kind = Ekind (gnat_entity);
-
-  /* If this has an entity list, process all in the list.  */
-  if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
-      || IN (kind, Private_Kind)
-      || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
-      || kind == E_Function || kind == E_Generic_Function
-      || kind == E_Generic_Package || kind == E_Generic_Procedure
-      || kind == E_Loop || kind == E_Operator || kind == E_Package
-      || kind == E_Package_Body || kind == E_Procedure
-      || kind == E_Record_Type || kind == E_Record_Subtype
-      || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
-    for (gnat_sub_entity = First_Entity (gnat_entity);
-	 Present (gnat_sub_entity);
-	 gnat_sub_entity = Next_Entity (gnat_sub_entity))
-      if (Scope (gnat_sub_entity) == gnat_entity
-	  && gnat_sub_entity != gnat_entity)
-	mark_out_of_scope (gnat_sub_entity);
-
-  /* Now clear this if it has been defined, but only do so if it isn't
-     a subprogram or parameter.  We could refine this, but it isn't
-     worth it.  If this is statically allocated, it is supposed to
-     hang around out of cope.  */
-  if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
-      && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
-    {
-      save_gnu_tree (gnat_entity, NULL_TREE, true);
-      save_gnu_tree (gnat_entity, error_mark_node, true);
-    }
-}
-
 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
    If this is a multi-dimensional array type, do this recursively.
 
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h	(revision 186945)
+++ gcc-interface/gigi.h	(working copy)
@@ -108,10 +108,6 @@ extern Entity_Id Gigi_Equivalent_Type (E
    be elaborated at the point of its definition, but do nothing else.  */
 extern void elaborate_entity (Entity_Id gnat_entity);
 
-/* Mark GNAT_ENTITY as going out of scope at this point.  Recursively mark
-   any entities on its entity chain similarly.  */
-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);
 
@@ -504,6 +500,9 @@ extern tree convert_to_index_type (tree
 /* Initialize the association of GNAT nodes to GCC trees.  */
 extern void init_gnat_to_gnu (void);
 
+/* Destroy the association of GNAT nodes to GCC trees.  */
+extern void destroy_gnat_to_gnu (void);
+
 /* GNAT_ENTITY is a GNAT tree node for a defining identifier.
    GNU_DECL is the GCC tree which is to be associated with
    GNAT_ENTITY. Such gnu tree node is always an ..._DECL node.
@@ -523,6 +522,9 @@ extern bool present_gnu_tree (Entity_Id
 /* Initialize the association of GNAT nodes to GCC trees as dummies.  */
 extern void init_dummy_type (void);
 
+/* Destroy the association of GNAT nodes to GCC trees as dummies.  */
+extern void destroy_dummy_type (void);
+
 /* Make a dummy type corresponding to GNAT_TYPE.  */
 extern tree make_dummy_type (Entity_Id gnat_type);
 
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c	(revision 186945)
+++ gcc-interface/trans.c	(working copy)
@@ -109,6 +109,12 @@ bool type_annotate_only;
 /* Current filename without path.  */
 const char *ref_filename;
 
+DEF_VEC_I(Node_Id);
+DEF_VEC_ALLOC_I(Node_Id,heap);
+
+/* List of N_Validate_Unchecked_Conversion nodes in the unit.  */
+static VEC(Node_Id,heap) *gnat_validate_uc_list;
+
 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
    of unconstrained array IN parameters to avoid emitting a great deal of
    redundant instructions to recompute them each time.  */
@@ -251,6 +257,7 @@ static bool addressable_p (tree, tree);
 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
 static tree extract_values (tree, tree);
 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
+static void validate_unchecked_conversion (Node_Id);
 static tree maybe_implicit_deref (tree);
 static void set_expr_location_from_node (tree, Node_Id);
 static bool set_end_locus_from_node (tree, Node_Id);
@@ -278,6 +285,7 @@ gigi (Node_Id gnat_root, int max_gnat_no
       Entity_Id standard_character, Entity_Id standard_long_long_float,
       Entity_Id standard_exception_type, Int gigi_operating_mode)
 {
+  Node_Id gnat_iter;
   Entity_Id gnat_literal;
   tree long_long_float_type, exception_type, t, ftype;
   tree int64_type = gnat_type_for_size (64, 0);
@@ -648,6 +656,13 @@ gigi (Node_Id gnat_root, int max_gnat_no
   /* Now translate the compilation unit proper.  */
   Compilation_Unit_to_gnu (gnat_root);
 
+  /* Then process the N_Validate_Unchecked_Conversion nodes.  We do this at
+     the very end to avoid having to second-guess the front-end when we run
+     into dummy nodes during the regular processing.  */
+  for (i = 0; VEC_iterate (Node_Id, gnat_validate_uc_list, i, gnat_iter); i++)
+    validate_unchecked_conversion (gnat_iter);
+  VEC_free (Node_Id, heap, gnat_validate_uc_list);
+
   /* Finally see if we have any elaboration procedures to deal with.  */
   for (info = elab_info_list; info; info = info->next)
     {
@@ -669,6 +684,10 @@ gigi (Node_Id gnat_root, int max_gnat_no
 	}
     }
 
+  /* Destroy ourselves.  */
+  destroy_gnat_to_gnu ();
+  destroy_dummy_type ();
+
   /* We cannot track the location of errors past this point.  */
   error_gnat_node = Empty;
 }
@@ -3480,8 +3499,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
   /* If there is a stub associated with the function, build it now.  */
   if (DECL_FUNCTION_STUB (gnu_subprog_decl))
     build_function_stub (gnu_subprog_decl, gnat_subprog_id);
-
-  mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
 }
 
 /* Return true if GNAT_NODE requires atomic synchronization.  */
@@ -6036,9 +6053,6 @@ gnat_to_gnu (Node_Id gnat_node)
       add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
       gnat_poplevel ();
       gnu_result = end_stmt_group ();
-
-      if (Present (Identifier (gnat_node)))
-	mark_out_of_scope (Entity (Identifier (gnat_node)));
       break;
 
     case N_Exit_Statement:
@@ -6760,83 +6774,10 @@ gnat_to_gnu (Node_Id gnat_node)
       break;
 
     case N_Validate_Unchecked_Conversion:
-      {
-	Entity_Id gnat_target_type = Target_Type (gnat_node);
-	tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
-	tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
-
-	/* No need for any warning in this case.  */
-	if (!flag_strict_aliasing)
-	  ;
-
-	/* 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 is defined in the same
-	   unit as this unchecked conversion, we can allow this because we
-	   can know to make the pointer type behave properly.  */
-	else if (POINTER_TYPE_P (gnu_target_type)
-		 && !In_Same_Source_Unit (gnat_target_type, gnat_node)
-		 && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
-	  {
-	    tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
-					 ? TREE_TYPE (gnu_source_type)
-					 : NULL_TREE;
-	    tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
-
-	    if ((TYPE_IS_DUMMY_P (gnu_target_desig_type)
-		 || get_alias_set (gnu_target_desig_type) != 0)
-		&& (!POINTER_TYPE_P (gnu_source_type)
-		    || (TYPE_IS_DUMMY_P (gnu_source_desig_type)
-			!= TYPE_IS_DUMMY_P (gnu_target_desig_type))
-		    || (TYPE_IS_DUMMY_P (gnu_source_desig_type)
-			&& gnu_source_desig_type != gnu_target_desig_type)
-		    || !alias_sets_conflict_p
-			(get_alias_set (gnu_source_desig_type),
-			 get_alias_set (gnu_target_desig_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);
-		post_error_ne
-		  ("\\?or use `pragma No_Strict_Aliasing (&);`",
-		   gnat_node, Target_Type (gnat_node));
-	      }
-	  }
-
-	/* But if the result is a fat pointer type, we have no mechanism to
-	   do that, so we unconditionally warn in problematic cases.  */
-	else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
-	  {
-	    tree gnu_source_array_type
-	      = TYPE_IS_FAT_POINTER_P (gnu_source_type)
-		? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
-		: NULL_TREE;
-	    tree gnu_target_array_type
-	      = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
-
-	    if ((TYPE_IS_DUMMY_P (gnu_target_array_type)
-		 || get_alias_set (gnu_target_array_type) != 0)
-		&& (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
-		    || (TYPE_IS_DUMMY_P (gnu_source_array_type)
-			!= TYPE_IS_DUMMY_P (gnu_target_array_type))
-		    || (TYPE_IS_DUMMY_P (gnu_source_array_type)
-			&& gnu_source_array_type != gnu_target_array_type)
-		    || !alias_sets_conflict_p
-			(get_alias_set (gnu_source_array_type),
-			 get_alias_set (gnu_target_array_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);
-	      }
-	  }
-      }
+      /* The only validation we currently do on an unchecked conversion is
+	 that of aliasing assumptions.  */
+      if (flag_strict_aliasing)
+	VEC_safe_push (Node_Id, heap, gnat_validate_uc_list, gnat_node);
       gnu_result = alloc_stmt_list ();
       break;
 
@@ -8723,6 +8664,65 @@ extract_values (tree values, tree record
   return gnat_build_constructor (record_type, v);
 }
 
+/* Process a N_Validate_Unchecked_Conversion node.  */
+
+static void
+validate_unchecked_conversion (Node_Id 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 the target 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, unless the pointer has been marked to alias everything.  */
+  if (POINTER_TYPE_P (gnu_target_type)
+      && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
+    {
+      tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
+				   ? TREE_TYPE (gnu_source_type)
+				   : NULL_TREE;
+      tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
+      alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
+
+      if (target_alias_set != 0
+	  && (!POINTER_TYPE_P (gnu_source_type)
+	      || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
+					 target_alias_set)))
+	{
+	  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);
+	  post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
+			 gnat_node, Target_Type (gnat_node));
+	}
+    }
+
+  /* Likewise if the target is a fat pointer type, but we have no mechanism to
+     mitigate the problem in this case, so we unconditionally warn.  */
+  else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
+    {
+      tree gnu_source_desig_type
+	= TYPE_IS_FAT_POINTER_P (gnu_source_type)
+	  ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
+	  : NULL_TREE;
+      tree gnu_target_desig_type
+	= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
+      alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
+
+      if (target_alias_set != 0
+	  && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
+	      || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
+					 target_alias_set)))
+	{
+	  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);
+	}
+    }
+}
+
 /* EXP is to be treated as an array or record.  Handle the cases when it is
    an access object and perform the required dereferences.  */
 

-- { dg-do compile }
-- { dg-options "-O2" }

with Unchecked_Conversion;
with System;

package body Warn6 is

  function Conv is new Unchecked_Conversion (System.Address, Q_T);

  procedure Dummy is begin null; end;

end Warn6;

package Warn6 is

  package Q is
    type T is private; -- this is the trigger
  private
    type T is access Integer;
    pragma No_Strict_Aliasing (T);

  end Q;

  subtype Q_T is Q.T;

  procedure Dummy;

end Warn6;