re PR ada/20515 ("stdcall" imports are not handled correctly)

2005-06-10  Eric Botcazou  <ebotcazou@adacore.com>
	    Olivier Hainque  <hainque@adacore.com>
	    Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>
	    Pascal Obry  <obry@adacore.com>

	* gigi.h: (build_allocator): Add arg IGNORE_INIT_TYPE.

	* trans.c (call_to_gnu): Issue a warning for users of Starlet when
	making a temporary around a procedure call because of non-addressable
	actual parameter.
	(process_freeze_entity): If entity is a private type, capture size
	information that may have been computed for the full view.
	(tree_transform, case N_Allocator): If have initializing expression,
	check type for Has_Constrained_Partial_View and pass that to
	build_allocator.
	(tree_transform, case N_Return_Statement): Pass extra arg to
	build_allocator.

	* decl.c (annotate_value): Remove early return if -gnatR is not
	specified.
	(gnat_to_gnu_field): Don't make a packable type for a component clause
	if the position is byte aligned, the field is aliased, and the clause
	size isn't a multiple of the packable alignment. It serves no useful
	purpose packing-wise and would be rejected later on.
	(gnat_to_gnu_entity, case object): Pass extra arg to build_allocator.

	PR ada/20515
	(gnat_to_gnu_entity): Remove use of macro _WIN32 which is wrong in the
	context of cross compilers. We use TARGET_DLLIMPORT_DECL_ATTRIBUTES
	instead.
	(create_concat_name): Idem.

From-SVN: r101070

gcc/ada/decl.c

@@ -958,8 +958,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		  post_error ("Storage_Error will be raised at run-time?",
 			      gnat_entity);
 
-		gnu_expr = build_allocator (gnu_alloc_type, gnu_expr,
-					    gnu_type, 0, 0, gnat_entity);
+		gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
+					    0, 0, gnat_entity, false);
 	      }
 	    else
 	      {
@@ -3630,7 +3630,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	if (list_length (gnu_return_list) == 1)
 	  gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
 
-#ifdef _WIN32
+#ifdef TARGET_DLLIMPORT_DECL_ATTRIBUTES
 	if (Convention (gnat_entity) == Convention_Stdcall)
 	  {
 	    struct attrib *attr
@@ -5111,7 +5111,6 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
 {
   tree gnu_field_id = get_entity_name (gnat_field);
   tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
-  tree gnu_orig_field_type = gnu_field_type;
   tree gnu_pos = 0;
   tree gnu_size = 0;
   tree gnu_field;
@@ -5138,25 +5137,48 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
 			      gnat_field, FIELD_DECL, false, true);
 
   /* 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
-     we can get a better form of the type that allows more packing.  If we
-     can, show a size was specified for it if there wasn't one so we know to
-     make this a bitfield and avoid making things wider.  */
+     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 we
+     can get a better form of the type that allows more packing.  If we can,
+     show a size was specified for it if there wasn't one so we know to make
+     this a bitfield and avoid making things wider.  */
   if (TREE_CODE (gnu_field_type) == RECORD_TYPE
       && TYPE_MODE (gnu_field_type) == BLKmode
       && host_integerp (TYPE_SIZE (gnu_field_type), 1)
       && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0
       && (packed == 1
-	  || (gnu_size && tree_int_cst_lt (gnu_size,
-					   TYPE_SIZE (gnu_field_type)))
+	  || (gnu_size
+	      && tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)))
 	  || Present (Component_Clause (gnat_field))))
     {
-      gnu_field_type = make_packable_type (gnu_field_type);
-
-      if (gnu_field_type != gnu_orig_field_type && !gnu_size)
+      /* See what the alternate type and size would be.  */
+      tree gnu_packable_type = make_packable_type (gnu_field_type);
+
+      /* Compute whether we should avoid the substitution.  */
+      int reject =
+        /* There is no point subtituting if there is no change.  */
+        (gnu_packable_type == gnu_field_type
+         ||
+         /* The size of an aliased field must be an exact multiple of the
+            type's alignment, which the substitution might increase.  Reject
+            substitutions that would so invalidate a component clause when the
+            specified position is byte aligned, as the change would have no
+            real benefit from the packing standpoint anyway.  */
+         (Is_Aliased (gnat_field)
+          && Present (Component_Clause (gnat_field))
+          && UI_To_Int (Component_Bit_Offset (gnat_field)) % BITS_PER_UNIT == 0
+          && tree_low_cst (gnu_size, 1) % TYPE_ALIGN (gnu_packable_type) != 0)
+         );
+
+      /* Substitute unless told otherwise.  */
+      if (!reject)
+        {
+          gnu_field_type = gnu_packable_type;
+
+          if (gnu_size == 0)
             gnu_size = rm_size (gnu_field_type);
         }
+    }
 
   /* If we are packing the record and the field is BLKmode, round the
      size up to a byte boundary.  */
@@ -5678,10 +5700,6 @@ annotate_value (tree gnu_size)
   int i;
   int size;
 
-  /* If back annotation is suppressed by the front end, return No_Uint */
-  if (!Back_Annotate_Rep_Info)
-    return No_Uint;
-
   /* See if we've already saved the value for this node.  */
   if (EXPR_P (gnu_size) && TREE_COMPLEXITY (gnu_size))
     return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_size);
@@ -6606,7 +6624,7 @@ create_concat_name (Entity_Id gnat_entity, const char *suffix)
 
   Get_External_Name_With_Suffix (gnat_entity, fp);
 
-#ifdef _WIN32
+#ifdef TARGET_DLLIMPORT_DECL_ATTRIBUTES
   /* A variable using the Stdcall convention (meaning we are running
      on a Windows box) live in a DLL. Here we adjust its name to use
      the jump-table, the _imp__NAME contains the address for the NAME

gcc/ada/gigi.h

@@ -709,10 +709,13 @@ extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size,
    RESULT_TYPE, which must be some type of pointer.  Return the tree.
    GNAT_PROC and GNAT_POOL optionally give the procedure to call and
    the storage pool to use.  GNAT_NODE is used to provide an error
-   location for restriction violations messages.  */
+   location for restriction violations messages.  If IGNORE_INIT_TYPE is
+   true, ignore the type of INIT for the purpose of determining the size;
+   this will cause the maximum size to be allocated if TYPE is of
+   self-referential size.  */
 extern tree build_allocator (tree type, tree init, tree result_type,
                              Entity_Id gnat_proc, Entity_Id gnat_pool,
-                             Node_Id gnat_node);
+                             Node_Id gnat_node, bool);
 
 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
    GNAT_FORMAL is how we find the descriptor record.  */

gcc/ada/trans.c

@@ -592,6 +592,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 
       /* If we are taking 'Address of an unconstrained object, this is the
 	 pointer to the underlying array.  */
+      if (attribute == Attr_Address)
 	gnu_prefix = maybe_unconstrained_array (gnu_prefix);
 
       /* ... fall through ... */
@@ -1633,6 +1634,27 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
 	      tree gnu_copy = gnu_name;
 	      tree gnu_temp;
 
+	      /* For users of Starlet we issue a warning because the
+		 interface apparently assumes that by-ref parameters
+		 outlive the procedure invocation.  The code still
+		 will not work as intended, but we cannot do much
+		 better since other low-level parts of the back-end
+		 would allocate temporaries at will because of the
+		 misalignment if we did not do so here.  */
+
+	      if (Is_Valued_Procedure (Entity (Name (gnat_node))))
+		{
+		  post_error
+		    ("?possible violation of implicit assumption",
+		     gnat_actual);
+		  post_error_ne
+		    ("?made by pragma Import_Valued_Procedure on &",
+		     gnat_actual, Entity (Name (gnat_node)));
+		  post_error_ne
+		    ("?because of misalignment of &",
+		     gnat_actual, gnat_formal);
+		}
+
 	      /* Remove any unpadding on the actual and make a copy.  But if
 		 the actual is a justified modular type, first convert
 		 to it.  */
@@ -3319,6 +3341,7 @@ gnat_to_gnu (Node_Id gnat_node)
       {
 	tree gnu_init = 0;
 	tree gnu_type;
+	bool ignore_init_type = false;
 
 	gnat_temp = Expression (gnat_node);
 
@@ -3334,6 +3357,7 @@ gnat_to_gnu (Node_Id gnat_node)
 	    Entity_Id gnat_desig_type
 	      = Designated_Type (Underlying_Type (Etype (gnat_node)));
 
+	    ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
 	    gnu_init = gnat_to_gnu (Expression (gnat_temp));
 
 	    gnu_init = maybe_unconstrained_array (gnu_init);
@@ -3361,7 +3385,8 @@ gnat_to_gnu (Node_Id gnat_node)
 	gnu_result_type = get_unpadded_type (Etype (gnat_node));
 	return build_allocator (gnu_type, gnu_init, gnu_result_type,
 				Procedure_To_Call (gnat_node),
-				Storage_Pool (gnat_node), gnat_node);
+				Storage_Pool (gnat_node), gnat_node,
+				ignore_init_type);
       }
       break;
 
@@ -3576,7 +3601,7 @@ gnat_to_gnu (Node_Id gnat_node)
 			= build_allocator (TREE_TYPE (gnu_ret_val),
 					   gnu_ret_val,
 					   TREE_TYPE (gnu_subprog_type),
-					   0, -1, gnat_node);
+					   0, -1, gnat_node, false);
 		    else
 		      gnu_ret_val
 			= build_allocator (TREE_TYPE (gnu_ret_val),
@@ -3584,7 +3609,7 @@ gnat_to_gnu (Node_Id gnat_node)
 					   TREE_TYPE (gnu_subprog_type),
 					   Procedure_To_Call (gnat_node),
 					   Storage_Pool (gnat_node),
-					   gnat_node);
+					   gnat_node, false);
 		  }
 	      }
 	  }
@@ -4754,11 +4779,15 @@ process_freeze_entity (Node_Id gnat_node)
 
   /* Don't do anything for subprograms that may have been elaborated before
      their freeze nodes.  This can happen, for example because of an inner call
-     in an instance body.  */
-  if (gnu_old
+     in an instance body, or a previous compilation of a spec for inlining
+     purposes.  */
+  if  ((gnu_old
         && TREE_CODE (gnu_old) == FUNCTION_DECL
         && (Ekind (gnat_entity) == E_Function
           || Ekind (gnat_entity) == E_Procedure))
+    || (gnu_old
+        && (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
+        && Ekind (gnat_entity) == E_Subprogram_Type)))
     return;
 
   /* If we have a non-dummy type old tree, we have nothing to do.   Unless
@@ -4798,6 +4827,16 @@ process_freeze_entity (Node_Id gnat_node)
     {
       gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
 
+      /* Propagate back-annotations from full view to partial view.  */
+      if (Unknown_Alignment (gnat_entity))
+	Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
+
+      if (Unknown_Esize (gnat_entity))
+	Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
+
+      if (Unknown_RM_Size (gnat_entity))
+	Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
+
       /* The above call may have defined this entity (the simplest example
   	 of this is when we have a private enumeral type since the bounds
   	 will have the public view.  */