decl.c: Factor common code to build a storage type for an unconstrained object from a...

2005-11-14  Thomas Quinot  <quinot@adacore.com>
	    Olivier Hainque  <hainque@adacore.com>
	    Eric Botcazou  <ebotcazou@adacore.com>

	* decl.c:
	Factor common code to build a storage type for an unconstrained object
	from a fat or thin pointer type and a constrained object type.
	(annotate_value): Handle BIT_AND_EXPR.
	(annotate_rep): Don't restrict the back annotation of inherited
	components to the type_annotate_only case.
	(gnat_to_gnu_entity) <E_Array_Type>: Do not invoke create_type_decl if
	we are not defining the type.
	<E_Record_Type>: Likewise.
	(gnat_to_gnu_entity) <object, renaming>: Adjust comments and structure
	to get advantage of the new maybe_stabilize_reference interface, to
	ensure that what we reference is indeed stabilized instead of relying
	on assumptions on what the stabilizer does.
	(gnat_to_gnu_entity) <E_Incomplete_Type>: If the entity is an incomplete
	type imported through a limited_with clause, use its non-limited view.
	(Has_Stdcall_Convention): New macro, to centralize the Windows vs others
	differentiation.
	(gnat_to_gnu_entity): Use Has_Stdcall_Convention instead of a spread mix
	of #if sections + explicit comparisons of convention identifiers.
	(gnat_to_gnu_entity) <E_Variable>: Decrement force_global if necessary
	before early-returning for certain types when code generation is
	disabled.
	(gnat_to_gnu_entity) <object>: Adjust comment attached to the
	nullification of gnu_expr we do for objects with address clause and
	that we are not defining.
	(elaborate_expression_1): Do not create constants when creating
	variables needed by the debug info: the dwarf2 writer considers that
	CONST_DECLs is used only to represent enumeration constants, and emits
	nothing for them.
	(gnat_to_gnu_entity) <object>: When turning a non-definition of an
	object with an address clause into an indirect reference, drop the
	initializing expression.
	Include "expr.h".
	(STACK_CHECK_BUILTIN): Delete.
	(STACK_CHECK_PROBE_INTERVAL): Likewise.
	(STACK_CHECK_MAX_FRAME_SIZE): Likewise.
	(STACK_CHECK_MAX_VAR_SIZE): Likewise.
	(gnat_to_gnu_entity): If gnat_entity is a renaming, do not mark the tree
	corresponding to the renamed object as ignored for debugging purposes.

	* trans.c (tree_transform, case N_Attribute_Reference, case Attr_Size &
	related): For a prefix that is a dereference of a fat or thin pointer,
	if there is an actual subtype provided by the front-end, use that
	subtype to build an actual type with bounds template.
	(tree_transform, case N_Free_Statement): If an Actual_Designated_Subtype
	is provided by the front-end, use that subtype to compute the size of
	the deallocated object.
	(gnat_to_gnu): When adding a statement into an elaboration procedure,
	check for a potential violation of a No_Elaboration_Code restriction.
	(maybe_stabilize_reference): New function, like gnat_stabilize_reference
	with extra arguments to control whether to recurse through non-values
	and to let the caller know if the stabilization has succeeded.
	(gnat_stabilize_reference): Now a simple wrapper around
	maybe_stabilize, for common uses without restriction on lvalues and
	without need to check for the success indication.
	(gnat_to_gnu, call_to_gnu): Adjust calls to gnat_stabilize_reference, to
	pass false instead of 0 as the FORCE argument which is a bool.
	(Identifier_to_gnu): Remove checks ensuring that an renamed object
	attached to a renaming pointer has been properly stabilized, as no such
	object is attached otherwise.
	(call_to_gnu): Invoke create_var_decl to create the temporary when the
	function uses the "target pointer" return mechanism.
	Reinstate conversion of the actual to the type of the formal
	parameter before any other specific treatment based on the passing
	mechanism. This turns out to be necessary in order for PLACEHOLDER
	substitution to work properly when the latter type is unconstrained.

	* gigi.h (build_unc_object_type_from_ptr): New subprogram, factoring a
	common pattern.
	(maybe_stabilize_reference): New function, like gnat_stabilize_reference
	with extra arguments to control whether to recurse through non-values
	and to let the caller know if the stabilization has succeeded.

	* utils2.c (gnat_build_constructor): Only sort the fields for possible
	static output of record constructor if all the components are constant.
	(gnat_build_constructor): For a record type, sort the list of field
	initializers in increasing bit position order.
	Factor common code to build a storage type for an unconstrained object
	from a fat or thin pointer type and a constrained object type.
	(build_unary_op) <ADDR_EXPR>: Always recurse down conversions between
	types variants, and process special cases of VIEW_CONVERT expressions
	as their NOP_EXPR counterpart to ensure we get to the
	CORRESPONDING_VARs associated with CONST_DECls.
	(build_binary_op) <MODIFY_EXPR>: Do not strip VIEW_CONVERT_EXPRs
	on the right-hand side.

	* utils.c (build_unc_object_type_from_ptr): New subprogram, factoring
	a common pattern.
	(convert) <VIEW_CONVERT_EXPR>: Return the inner operand directly if we
	are converting back to its original type.
	(convert) <JM input>: Fallthrough regular conversion code instead of
	extracting the object if converting to a type variant.
	(create_var_decl): When a variable has an initializer requiring code
	generation and we are at the top level, check for a potential violation
	of a No_Elaboration_Code restriction.
	(create_var_decl): call expand_decl for CONST_DECLs, to set MODE, ALIGN
	SIZE and SIZE_UNIT which we need for later back-annotations.
	* utils.c: (convert) <STRING_CST>: Remove obsolete code.
	<VIEW_CONVERT_EXPR>: Do not lift the conversion if the target type
	is an unchecked union.
	(pushdecl): Set DECL_NO_STATIC_CHAIN on imported nested functions.
	(convert) <VIEW_CONVERT_EXPR>: When the types have the same
	main variant, just replace the VIEW_CONVERT_EXPR.
	<UNION_TYPE>: Revert 2005-03-02 change.

	* repinfo.h, repinfo.ads: Add tcode for BIT_AND_EXPR.

	* repinfo.adb (Print_Expr, Rep_Value): Handle Bit_And_Expressions.

From-SVN: r106961

1 files changed, 136 insertions, 50 deletions

diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c
index d685fb3..918f374 100644
--- a/gcc/ada/trans.c
+++ b/gcc/ada/trans.c
@@ -408,13 +408,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
       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.  */
-	       && (DECL_P (renamed_obj)
-		   || REFERENCE_CLASS_P (renamed_obj)
-		   || (TREE_CODE (renamed_obj) == VIEW_CONVERT_EXPR
-		       && (DECL_P (TREE_OPERAND (renamed_obj, 0))
-			   || REFERENCE_CLASS_P (TREE_OPERAND (renamed_obj,0))))))
+		   || global_bindings_p ()))
 	gnu_result = renamed_obj;
       else
 	gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
@@ -719,6 +713,21 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 		  = size_binop (MAX_EXPR, gnu_result,
 				DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
 	    }
+	  else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
+	    {
+	      Node_Id gnat_deref = Prefix (gnat_node);
+	      Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
+	      tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
+	      if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
+	  	&& Present (gnat_actual_subtype))
+	        {
+		  tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
+		  gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
+			       gnu_actual_obj_type, get_identifier ("SIZE"));
+	        }
+
+	      gnu_result = TYPE_SIZE (gnu_type);
+	    }
 	  else
 	    gnu_result = TYPE_SIZE (gnu_type);
 	}
@@ -1564,8 +1573,15 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
 			      0, Etype (Name (gnat_node)), "PAD", false,
 			      false, false);
 
-	  gnu_target = create_tmp_var_raw (gnu_obj_type, "LR");
-	  gnat_pushdecl (gnu_target, gnat_node);
+	  /* ??? We may be about to create a static temporary if we happen to
+	     be at the global binding level.  That's a regression from what
+	     the 3.x back-end would generate in the same situation, but we
+	     don't have a mechanism in Gigi for creating automatic variables
+	     in the elaboration routines.  */
+	  gnu_target
+	    = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
+			       NULL, false, false, false, false, NULL,
+			       gnat_node);
 	}
 
       gnu_actual_list
@@ -1602,6 +1618,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
       tree gnu_formal
 	= (present_gnu_tree (gnat_formal)
 	   ? get_gnu_tree (gnat_formal) : NULL_TREE);
+      tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
       /* We treat a conversion between aggregate types as if it is an
 	 unchecked conversion.  */
       bool unchecked_convert_p
@@ -1613,7 +1630,6 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
       tree gnu_name = gnat_to_gnu (gnat_name);
       tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
       tree gnu_actual;
-      tree gnu_formal_type;
 
       /* If it's possible we may need to use this expression twice, make sure
 	 than any side-effects are handled via SAVE_EXPRs. Likewise if we need
@@ -1626,6 +1642,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
       if (Ekind (gnat_formal) != E_In_Parameter)
 	{
 	  gnu_name = gnat_stabilize_reference (gnu_name, true);
+
 	  if (!addressable_p (gnu_name)
 	      && gnu_formal
 	      && (DECL_BY_REF_P (gnu_formal)
@@ -1741,6 +1758,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
 	gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
 			      gnu_actual);
 
+      if (TREE_CODE (gnu_actual) != SAVE_EXPR)
+	gnu_actual = convert (gnu_formal_type, gnu_actual);
+
       /* If we have not saved a GCC object for the formal, it means it is an
 	 OUT parameter not passed by reference and that does not need to be
 	 copied in. Otherwise, look at the PARM_DECL to see if it is passed by
@@ -1989,7 +2009,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
 		      && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
 		  gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
 	      }
-		
+
 	    gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
 					  gnu_actual, gnu_result);
 	    annotate_with_node (gnu_result, gnat_actual);
@@ -2497,25 +2517,40 @@ gnat_to_gnu (Node_Id gnat_node)
     return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
 		   build_call_raise (CE_Range_Check_Failed));
 
-  /* If this is a Statement and we are at top level, it must be part of
-     the elaboration procedure, so mark us as being in that procedure
-     and push our context.  */
-  if (!current_function_decl
-      && ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
-	   && Nkind (gnat_node) != N_Null_Statement)
-	  || Nkind (gnat_node) == N_Procedure_Call_Statement
-	  || Nkind (gnat_node) == N_Label
-	  || Nkind (gnat_node) == N_Implicit_Label_Declaration
-	  || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
-	  || ((Nkind (gnat_node) == N_Raise_Constraint_Error
-	       || Nkind (gnat_node) == N_Raise_Storage_Error
-	       || Nkind (gnat_node) == N_Raise_Program_Error)
-	      && (Ekind (Etype (gnat_node)) == E_Void))))
+  /* If this is a Statement and we are at top level, it must be part of the
+     elaboration procedure, so mark us as being in that procedure and push our
+     context.
+
+     If we are in the elaboration procedure, check if we are violating a a
+     No_Elaboration_Code restriction by having a statement there.  */
+  if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
+       && Nkind (gnat_node) != N_Null_Statement)
+      || Nkind (gnat_node) == N_Procedure_Call_Statement
+      || Nkind (gnat_node) == N_Label
+      || Nkind (gnat_node) == N_Implicit_Label_Declaration
+      || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
+      || ((Nkind (gnat_node) == N_Raise_Constraint_Error
+	   || Nkind (gnat_node) == N_Raise_Storage_Error
+	   || Nkind (gnat_node) == N_Raise_Program_Error)
+	  && (Ekind (Etype (gnat_node)) == E_Void)))
     {
-      current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
-      start_stmt_group ();
-      gnat_pushlevel ();
-      went_into_elab_proc = true;
+      if (!current_function_decl)
+	{
+	  current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
+	  start_stmt_group ();
+	  gnat_pushlevel ();
+	  went_into_elab_proc = true;
+	}
+
+      /* Don't check for a possible No_Elaboration_Code restriction violation
+	 on N_Handled_Sequence_Of_Statements, as we want to signal an error on
+	 every nested real statement instead.  This also avoids triggering
+	 spurious errors on dummy (empty) sequences created by the front-end
+	 for package bodies in some cases.  */
+
+      if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
+	  && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
+	Check_Elaboration_Code_Allowed (gnat_node);
     }
 
   switch (Nkind (gnat_node))
@@ -2982,7 +3017,7 @@ gnat_to_gnu (Node_Id gnat_node)
 				   ? Designated_Type (Etype
 						      (Prefix (gnat_node)))
 				   : Etype (Prefix (gnat_node))))
-	      gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
+	      gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
 
 	    gnu_result
 	      = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
@@ -3427,7 +3462,7 @@ gnat_to_gnu (Node_Id gnat_node)
       /* If the type has a size that overflows, convert this into raise of
 	 Storage_Error: execution shouldn't have gotten here anyway.  */
       if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
-	  && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
+	   && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
 	gnu_result = build_call_raise (SE_Object_Too_Large);
       else if (Nkind (Expression (gnat_node)) == N_Function_Call
 	       && !Do_Range_Check (Expression (gnat_node)))
@@ -3927,7 +3962,9 @@ gnat_to_gnu (Node_Id gnat_node)
       if (!type_annotate_only)
 	{
 	  tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
+	  tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
 	  tree gnu_obj_type;
+	  tree gnu_actual_obj_type = 0;
 	  tree gnu_obj_size;
 	  int align;
 
@@ -3952,7 +3989,21 @@ gnat_to_gnu (Node_Id gnat_node)
 			 gnu_ptr);
 
 	  gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
-	  gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
+
+	  if (Present (Actual_Designated_Subtype (gnat_node)))
+	    {
+	      gnu_actual_obj_type = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
+
+	      if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
+	        gnu_actual_obj_type
+	          = build_unc_object_type_from_ptr (gnu_ptr_type,
+		      gnu_actual_obj_type,
+		      get_identifier ("DEALLOC"));
+	    }
+	  else
+	    gnu_actual_obj_type = gnu_obj_type;
+
+	  gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
 	  align = TYPE_ALIGN (gnu_obj_type);
 
 	  if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
@@ -4106,7 +4157,7 @@ gnat_to_gnu (Node_Id gnat_node)
   if (TREE_SIDE_EFFECTS (gnu_result)
       && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
 	  || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
-    gnu_result = gnat_stabilize_reference (gnu_result, 0);
+    gnu_result = gnat_stabilize_reference (gnu_result, false);
 
   /* Now convert the result to the proper type.  If the type is void or if
      we have no result, return error_mark_node to show we have no result.
@@ -5709,17 +5760,26 @@ protect_multiple_eval (tree exp)
 						 exp)));
 }
 
-/* This is equivalent to stabilize_reference in GCC's tree.c, but we know
-   how to handle our new nodes and we take an extra argument that says
-   whether to force evaluation of everything.  */
+/* This is equivalent to stabilize_reference in GCC's tree.c, but we know how
+   to handle our new nodes and we take extra arguments:
+
+   FORCE says whether to force evaluation of everything,
+
+   SUCCESS we set to true unless we walk through something we don't know how
+   to stabilize, or through something which is not an lvalue and LVALUES_ONLY
+   is true, in which cases we set to false.  */
 
 tree
-gnat_stabilize_reference (tree ref, bool force)
+maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
+			   bool *success)
 {
   tree type = TREE_TYPE (ref);
   enum tree_code code = TREE_CODE (ref);
   tree result;
 
+  /* Assume we'll success unless proven otherwise.  */
+  *success = true;
+
   switch (code)
     {
     case VAR_DECL:
@@ -5728,6 +5788,15 @@ gnat_stabilize_reference (tree ref, bool force)
       /* No action is needed in this case.  */
       return ref;
 
+    case ADDR_EXPR:
+      /*  A standalone ADDR_EXPR is never an lvalue, and this one can't
+	  be nested inside an outer INDIRECT_REF, since INDIREC_REF goes
+	  straight to stabilize_1.  */
+      if (lvalues_only)
+	goto failure;
+
+      /* ... Fallthru ... */
+
     case NOP_EXPR:
     case CONVERT_EXPR:
     case FLOAT_EXPR:
@@ -5736,10 +5805,10 @@ gnat_stabilize_reference (tree ref, bool force)
     case FIX_ROUND_EXPR:
     case FIX_CEIL_EXPR:
     case VIEW_CONVERT_EXPR:
-    case ADDR_EXPR:
       result
 	= build1 (code, type,
-		  gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
+		  maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
+					     lvalues_only, success));
       break;
 
     case INDIRECT_REF:
@@ -5750,15 +5819,16 @@ gnat_stabilize_reference (tree ref, bool force)
       break;
 
     case COMPONENT_REF:
-      result = build3 (COMPONENT_REF, type,
-		       gnat_stabilize_reference (TREE_OPERAND (ref, 0),
-						 force),
-		       TREE_OPERAND (ref, 1), NULL_TREE);
+     result = build3 (COMPONENT_REF, type,
+		      maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
+						 lvalues_only, success),
+		      TREE_OPERAND (ref, 1), NULL_TREE);
       break;
 
     case BIT_FIELD_REF:
       result = build3 (BIT_FIELD_REF, type,
-		       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+		       maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
+						  lvalues_only, success),
 		       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
 						   force),
 		       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
@@ -5768,7 +5838,8 @@ gnat_stabilize_reference (tree ref, bool force)
     case ARRAY_REF:
     case ARRAY_RANGE_REF:
       result = build4 (code, type,
-		       gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+		       maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
+						  lvalues_only, success),
 		       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
 						   force),
 		       NULL_TREE, NULL_TREE);
@@ -5778,17 +5849,21 @@ gnat_stabilize_reference (tree ref, bool force)
       result = build2 (COMPOUND_EXPR, type,
 		       gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
 						   force),
-		       gnat_stabilize_reference (TREE_OPERAND (ref, 1),
-						 force));
+		       maybe_stabilize_reference (TREE_OPERAND (ref, 1), force,
+						  lvalues_only, success));
       break;
 
+    case ERROR_MARK:
+      ref = error_mark_node;
+
+      /* ...  Fallthru to failure ... */
+
       /* If arg isn't a kind of lvalue we recognize, make no change.
 	 Caller should recognize the error for an invalid lvalue.  */
     default:
+    failure:
+      *success = false;
       return ref;
-
-    case ERROR_MARK:
-      return error_mark_node;
     }
 
   TREE_READONLY (result) = TREE_READONLY (ref);
@@ -5808,6 +5883,17 @@ gnat_stabilize_reference (tree ref, bool force)
   return result;
 }
 
+/* Wrapper around maybe_stabilize_reference, for common uses without
+   lvalue restrictions and without need to examine the success
+   indication.  */
+
+tree
+gnat_stabilize_reference (tree ref, bool force)
+{
+  bool stabilized;
+  return maybe_stabilize_reference (ref, force, false, &stabilized);
+}
+
 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
    arg to force a SAVE_EXPR for everything.  */