ada-tree.h: (DECL_RENAMING_GLOBAL_P): New predicate.

2005-03-17  Eric Botcazou  <ebotcazou@adacore.com>

	* ada-tree.h: (DECL_RENAMING_GLOBAL_P): New predicate.
	(DECL_RENAMED_OBJECT): New accessor macro.
	(SET_DECL_RENAMED_OBJECT): New setter macro.

	* decl.c (gnat_to_gnu_entity) <E_Variable>: Stabilize the renamed
	object in all cases.  Attach the renamed object to the VAR_DECL.
	(gnat_to_gnu_field): Do not lift the record wrapper if the size of the
	field is not prescribed.

	* misc.c (gnat_handle_option): Handle -gnatO separately.
	(gnat_print_decl) <VAR_DECL>: New case.
	Print the DECL_RENAMED_OBJECT node.

	* lang.opt:  Declare separate -gnatO option.

	* trans.c (tree_transform) <N_Identifier>: If the object is a renaming
	pointer, replace it with the renamed object.
	<N_Validate_Unchecked_Conversion>: Warn for a conversion to a fat
	pointer type if the source is not a fat pointer type whose underlying
	array has the same non-zero alias set as that of the destination array.

From-SVN: r96660

gcc/ada/ada-tree.h

@@ -260,6 +260,9 @@ struct lang_type GTY(()) {tree t; };
 /* Nonzero in a PARM_DECL if we are to pass by descriptor.  */
 #define DECL_BY_DESCRIPTOR_P(NODE) DECL_LANG_FLAG_5 (PARM_DECL_CHECK (NODE))
 
+/* Nonzero in a VAR_DECL if it is a pointer renaming a global object.  */
+#define DECL_RENAMING_GLOBAL_P(NODE) DECL_LANG_FLAG_5 (VAR_DECL_CHECK (NODE))
+
 /* In a CONST_DECL, points to a VAR_DECL that is allocatable to
    memory.  Used when a scalar constant is aliased or has its
    address taken.  */
@@ -275,6 +278,14 @@ struct lang_type GTY(()) {tree t; };
 #define SET_DECL_ORIGINAL_FIELD(NODE, X) \
   SET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE), X)
 
+/* In a VAR_DECL, points to the object being renamed if the VAR_DECL is a
+   renaming pointer, otherwise 0.  Note that this object is guaranteed to
+   be protected against multiple evaluations.  */
+#define DECL_RENAMED_OBJECT(NODE) \
+  GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE))
+#define SET_DECL_RENAMED_OBJECT(NODE, X) \
+  SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X)
+
 /* In a FIELD_DECL corresponding to a discriminant, contains the
    discriminant number.  */
 #define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))

gcc/ada/decl.c

@@ -498,6 +498,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	bool inner_const_flag = const_flag;
 	bool static_p = Is_Statically_Allocated (gnat_entity);
 	tree gnu_ext_name = NULL_TREE;
+	tree renamed_obj = NULL_TREE;
 
 	if (Present (Renamed_Object (gnat_entity)) && !definition)
 	  {
@@ -777,30 +778,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    /* Otherwise, make this into a constant pointer to the object we
 	       are to rename.
 
-	       Stabilize it if we are not at the global level since in this
-	       case the renaming evaluation may directly dereference the
-	       initial value we make here instead of the pointer we will
-	       assign it to.  We don't want variables in the expression to be
-	       evaluated every time the renaming is used, since the value of
-	       these variables may change in between.
-
-	       If we are at the global level and the value is not constant,
-	       create_var_decl generates a mere elaboration assignment and
-	       does not attach the initial expression to the declaration.
-	       There is no possible direct initial-value dereference then.  */
+	       Stabilize it since in this case the renaming evaluation may
+	       directly dereference the initial value we make here instead
+	       of the pointer we will assign it to.  We don't want variables
+	       in the expression to be evaluated every time the renaming is
+	       used, since their value may change in between.  */
 	    else
 	      {
+		bool has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
 		inner_const_flag = TREE_READONLY (gnu_expr);
 		const_flag = true;
 		gnu_type = build_reference_type (gnu_type);
-		gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
+		renamed_obj = gnat_stabilize_reference (gnu_expr, true);
+		gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
 
 		if (!global_bindings_p ())
 		  {
-		    bool has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
-
-		    gnu_expr = gnat_stabilize_reference (gnu_expr, true);
-
 		    /* If the original expression had side effects, put a
 		       SAVE_EXPR around this whole thing.  */
 		    if (has_side_effects)
@@ -1063,6 +1056,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 				    static_p, attr_list, gnat_entity);
 	DECL_BY_REF_P (gnu_decl) = used_by_ref;
 	DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
+	if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
+	  {
+	    SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
+	    DECL_RENAMING_GLOBAL_P (gnu_decl) = global_bindings_p ();
+	  }
 
 	/* If we have an address clause and we've made this indirect, it's
 	   not enough to merely mark the type as volatile since volatile
@@ -5140,17 +5138,6 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
     gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
 			      gnat_field, FIELD_DECL, false, true);
 
-  /* If the field's type is justified modular and the size of the packed
-     array it wraps is the same as that of the field, we can make the field
-     the type of the inner object.  Note that we may need to do so if the
-     record is packed or the field has a component clause, but these cases
-     are handled later.  */
-  if (TREE_CODE (gnu_field_type) == RECORD_TYPE
-      && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
-      && tree_int_cst_equal (TYPE_SIZE (gnu_field_type),
-			     TYPE_ADA_SIZE (gnu_field_type)))
-    gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
-
   /* If we are packing this record, have a specified size that's smaller than
      that of the field type, or a position is specified, and the field type
      is also a record that's BLKmode and with a small constant size, see if

gcc/ada/lang.opt

@@ -65,6 +65,10 @@ gant
 Ada Joined Undocumented
 ; Catches typos
 
+gnatO
+Ada Separate
+; Sets name of output ALI file (internal switch)
+
 gnat
 Ada Joined
 -gnat<options>	Specify options to GNAT

gcc/ada/misc.c

@@ -259,7 +259,6 @@ gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
   const struct cl_option *option = &cl_options[scode];
   enum opt_code code = (enum opt_code) scode;
   char *q;
-  unsigned int i;
 
   if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
     {
@@ -314,17 +313,13 @@ gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
       gnat_argv[gnat_argc][0] = '-';
       strcpy (gnat_argv[gnat_argc] + 1, arg);
       gnat_argc++;
+      break;
 
-      if (arg[0] == 'O')
-	for (i = 1; i < save_argc - 1; i++)
-	  if (!strncmp (save_argv[i], "-gnatO", 6))
-	    if (save_argv[++i][0] != '-')
-	      {
-		/* Preserve output filename as GCC doesn't save it for GNAT. */
-		gnat_argv[gnat_argc] = xstrdup (save_argv[i]);
+    case OPT_gnatO:
+      gnat_argv[gnat_argc] = xstrdup ("-O");
+      gnat_argc++;
+      gnat_argv[gnat_argc] = xstrdup (arg);
       gnat_argc++;
-		break;
-	      }
       break;
     }
 
@@ -506,7 +501,12 @@ gnat_print_decl (FILE *file, tree node, int indent)
       break;
 
     case FIELD_DECL:
-      print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
+      print_node (file, "original_field", DECL_ORIGINAL_FIELD (node),
+		  indent + 4);
+      break;
+
+    case VAR_DECL:
+      print_node (file, "renamed_object", DECL_RENAMED_OBJECT (node),
 		  indent + 4);
       break;
 

gcc/ada/trans.c

@@ -393,7 +393,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 	      && DECL_BY_COMPONENT_PTR_P (gnu_result))))
     {
       bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
-      tree initial;
+      tree renamed_obj;
 
       if (TREE_CODE (gnu_result) == PARM_DECL
 	  && DECL_BY_COMPONENT_PTR_P (gnu_result))
@@ -402,34 +402,17 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 			    convert (build_pointer_type (gnu_result_type),
 				     gnu_result));
 
-      /* If the object is constant, we try to do the dereference directly
-	 through the DECL_INITIAL.  This is actually required in order to get
-	 correct aliasing information for renamed objects that are components
-	 of non-aliased aggregates, because the type of the renamed object and
-	 that of the aggregate don't alias.
-
-	 Note that we expect the initial value to have been stabilized.
-	 If it contains e.g. a variable reference, we certainly don't want
-	 to re-evaluate the variable each time the renaming is used.
-
-	 Stabilization is currently not performed at the global level but
-	 create_var_decl avoids setting DECL_INITIAL if the value is not
-	 constant then, and we get to the pointer dereference below.
-
-	 ??? Couldn't the aliasing issue show up again in this case ?
-	 There is no obvious reason why not.  */
-      else if (TREE_READONLY (gnu_result)
-	       && DECL_INITIAL (gnu_result)
-	       /* Strip possible conversion to reference type.  */
-	       && ((initial = TREE_CODE (DECL_INITIAL (gnu_result))
-		    == NOP_EXPR
-		    ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0)
-		    : DECL_INITIAL (gnu_result), 1))
-	       && TREE_CODE (initial) == ADDR_EXPR
-	       && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF
-		   || (TREE_CODE (TREE_OPERAND (initial, 0))
-		       == COMPONENT_REF)))
-	gnu_result = TREE_OPERAND (initial, 0);
+      /* If it's a renaming pointer and we are at the right binding level,
+	 we can reference the renamed object directly, since the renamed
+	 expression has been protected against multiple evaluations.  */
+      else if (TREE_CODE (gnu_result) == VAR_DECL
+	       && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0
+	       && (! DECL_RENAMING_GLOBAL_P (gnu_result)
+		   || global_bindings_p ())
+	       /* Make sure it's an lvalue like INDIRECT_REF.  */
+	       && (TREE_CODE_CLASS (TREE_CODE (renamed_obj)) == 'd'
+		   || TREE_CODE_CLASS (TREE_CODE (renamed_obj)) == 'r'))
+	gnu_result = renamed_obj;
       else
 	gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
 				     fold (gnu_result));
@@ -746,8 +729,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
       if (CONTAINS_PLACEHOLDER_P (gnu_result))
 	{
 	  if (TREE_CODE (gnu_prefix) != TYPE_DECL)
-	    gnu_result = substitute_placeholder_in_expr (gnu_result,
-							 gnu_expr);
+	    gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
 	  else
 	    gnu_result = max_size (gnu_result, true);
 	}
@@ -4012,6 +3994,27 @@ gnat_to_gnu (Node_Id 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
+	   fat pointers so unconditionally warn in problematic cases.  */
+	else if (TYPE_FAT_POINTER_P (gnu_target_type))
+	  {
+	    tree array_type
+	      = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
+
+	    if (get_alias_set (array_type) != 0
+		&& (!TYPE_FAT_POINTER_P (gnu_source_type)
+		    || (get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))))
+			!= get_alias_set (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);
+	      }
+	  }
       }
       gnu_result = alloc_stmt_list ();
       break;