re PR ada/26096 (Ada bootstrap fails in g-alleve.adb)

2006-02-13  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>
	    Olivier Hainque  <hainque@adacore.com>
	    Eric Botcazou  <ebotcazou@adacore.com>

	* ada-tree.h: (TYPE_UNCHECKED_UNION_P): Deleted.
	
	* gigi.h (value_factor_p): Add prototype and description, now public.

	* decl.c (gnat_to_gnu_field): Don't attempt BLKmode to integral type
	promotion for field with rep clause if the associated size was proven
	to be in error.
	Expand comments describing attempts to use a packable type.
	(gnat_to_gnu_entity) <E_Signed_Integer_Subtype,
	E_Floating_Point_Subtype>: Inherit alias set of what we are making a
	subtype of to ensure conflicts amongst all subtypes in a hierarchy,
	necessary since these are not different types and pointers may
	actually designate any subtype in this hierarchy.
	(gnat_to_gnu_entity, case E_Record_Type): Always make fields for
	discriminants but put them into record only if not Unchecked_Union;
	pass flag to components_to_record showing Unchecked_Union.
	(make_dummy_type): Use UNION_TYPE only if Unchecked_Union and no
	components before variants; don't set TYPE_UNCHECKED_UNION_P.
	(components_to_record): New argument UNCHECKED_UNION.
	Remove special case code for Unchecked_Union and instead use main code
	with small changes.

	PR ada/26096
	(gnat_to_gnu_entity) <E_Variable>: Do not initialize the
	aligning variable with the expression being built, only its inner
	field.

	* trans.c (Handled_Sequence_Of_Statements_to_gnu): Remove call to
	emit_sequence_entry_statements.
	(emit_sequence_entry_statements, body_with_handlers_p): Delete.
	(establish_gnat_vms_condition_handler): Move before
	Subprogram_Body_to_gnu.
	(Subprogram_Body_to_gnu): On VMS, establish_gnat_vms_condition_handler
	for a subprogram if it has a foreign convention or is exported.
	(Identifier_to_gnu): Manually unshare the DECL_INITIAL tree when it is
	substituted for a CONST_DECL.
	(tree_transform, case N_Aggregate): Remove code for UNION_TYPE and pass
	Etype to assoc_to_constructor.
	(assoc_to_constructor): New argument, GNAT_ENTITY; use it to ignore
	discriminants of Unchecked_Union.
	(TARGET_ABI_OPEN_VMS): Define to 0 if not defined, so that later uses
	don't need cluttering preprocessor directives.
	(establish_gnat_vms_condition_handler): New function. Establish the GNAT
	condition handler as current in the compiled function.
	(body_with_handlers_p): New function. Tell whether a given sequence of
	statements node is attached to a package or subprogram body and involves
	exception handlers possibly nested within inner block statements.
	(emit_sequence_entry_statements): New function, to emit special
	statements on entry of sequences when necessary. Establish GNAT
	condition handler in the proper cases for VMS.
	(Handled_Sequence_Of_Statements_to_gnu): Start block code with
	emit_sequence_entry_statements.

	* utils2.c (find_common_type): If both input types are BLKmode and
	have a constant size, use the smaller one.
	(build_simple_component_ref): Also match if FIELD and NEW_FIELD are
	the same.

	* utils.c (value_factor_p): Make public, to allow uses from other gigi
	units.
	(create_type_decl): Do not set the flag DECL_IGNORED_P for dummy types.
	(convert, case UNION_TYPE): Remove special treatment for unchecked
	unions.

	PR ada/18659
	(update_pointer_to): Update variants of pointer types to
	unconstrained arrays by attaching the list of fields of the main
	variant.

From-SVN: r111030

gcc/ada/ada-tree.h

@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2005 Free Software Foundation, Inc.          *
+ *          Copyright (C) 1992-2006 Free Software Foundation, Inc.          *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -160,9 +160,6 @@ struct lang_type GTY(()) {tree t; };
    padding or alignment.  */
 #define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE))
 
-/* For a UNION_TYPE, nonzero if this is an unchecked union.  */
-#define TYPE_UNCHECKED_UNION_P(NODE) TYPE_LANG_FLAG_6 (UNION_TYPE_CHECK (NODE))
-
 /* This field is only defined for FUNCTION_TYPE nodes. If the Ada
    subprogram contains no parameters passed by copy in/copy out then this
    field is 0. Otherwise it points to a list of nodes used to specify the

gcc/ada/gigi.h

@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2005 Free Software Foundation, Inc.          *
+ *          Copyright (C) 1992-2006 Free Software Foundation, Inc.          *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -680,6 +680,10 @@ extern tree get_ada_base_type (tree type);
    in bits.  If we don't know anything about the alignment, return 0.  */
 extern unsigned int known_alignment (tree exp);
 
+/* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power
+   of 2. */
+extern bool value_factor_p (tree value, HOST_WIDE_INT factor);
+
 /* Make a binary operation of kind OP_CODE.  RESULT_TYPE is the type
    desired for the result.  Usually the operation is to be performed
    in that type.  For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0

gcc/ada/trans.c

@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 1992-2005, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2006, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -57,6 +57,12 @@
 #include "ada-tree.h"
 #include "gigi.h"
 
+/* Let code below know whether we are targetting VMS without need of
+   intrusive preprocessor directives.  */
+#ifndef TARGET_ABI_OPEN_VMS
+#define TARGET_ABI_OPEN_VMS 0
+#endif
+
 int max_gnat_nodes;
 int number_names;
 struct Node *Nodes_Ptr;
@@ -159,7 +165,7 @@ static tree emit_index_check (tree, tree, tree, tree);
 static tree emit_check (tree, tree, int);
 static tree convert_with_check (Entity_Id, tree, bool, bool, bool);
 static bool addressable_p (tree);
-static tree assoc_to_constructor (Node_Id, 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 tree maybe_implicit_deref (tree);
@@ -446,7 +452,18 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
 			    == Attr_Unchecked_Access)
 		       || (Get_Attribute_Id (Attribute_Name (gnat_temp))
 			   == Attr_Unrestricted_Access)))))
-	gnu_result = DECL_INITIAL (gnu_result);
+	{
+	  gnu_result = DECL_INITIAL (gnu_result);
+	  /* ??? The mark/unmark mechanism implemented in Gigi to prevent tree
+	     sharing between global level and subprogram level doesn't apply
+	     to elaboration routines.  As a result, the DECL_INITIAL tree may
+	     be shared between the static initializer of a global object and
+	     the elaboration routine, thus wreaking havoc if a local temporary
+	     is created in place during gimplification of the latter and the
+	     former is emitted afterwards.  Manually unshare for now.  */
+	  if (TREE_VISITED (gnu_result))
+	    gnu_result = unshare_expr (gnu_result);
+	}
     }
 
   *gnu_result_type_p = gnu_result_type;
@@ -1340,6 +1357,57 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
   return gnu_result;
 }
 
+/* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
+   handler for the current function.  */
+
+/* This is implemented by issuing a call to the appropriate VMS specific
+   builtin.  To avoid having VMS specific sections in the global gigi decls
+   array, we maintain the decls of interest here.  We can't declare them
+   inside the function because we must mark them never to be GC'd, which we
+   can only do at the global level.  */
+
+static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
+static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
+
+static void
+establish_gnat_vms_condition_handler (void)
+{
+  tree establish_stmt;
+
+  /* Elaborate the required decls on the first call.  Check on the decl for
+     the gnat condition handler to decide, as this is one we create so we are
+     sure that it will be non null on subsequent calls.  The builtin decl is
+     looked up so remains null on targets where it is not implemented yet.  */
+  if (gnat_vms_condition_handler_decl == NULL_TREE)
+    {
+      vms_builtin_establish_handler_decl
+	= builtin_decl_for
+	  (get_identifier ("__builtin_establish_vms_condition_handler"));
+
+      gnat_vms_condition_handler_decl
+	= create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
+			       NULL_TREE,
+			       build_function_type_list (integer_type_node,
+							 ptr_void_type_node,
+							 ptr_void_type_node,
+							 NULL_TREE),
+			       NULL_TREE, 0, 1, 1, 0, Empty);
+    }
+
+  /* Do nothing if the establish builtin is not available, which might happen
+     on targets where the facility is not implemented.  */
+  if (vms_builtin_establish_handler_decl == NULL_TREE)
+    return;
+
+  establish_stmt
+    = build_call_1_expr (vms_builtin_establish_handler_decl,
+			 build_unary_op
+			 (ADDR_EXPR, NULL_TREE,
+			  gnat_vms_condition_handler_decl));
+
+  add_stmt (establish_stmt);
+}
+
 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body.  We
    don't return anything.  */
 
@@ -1433,6 +1501,22 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
 		     gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
       }
 
+
+  /* On VMS, establish our condition handler to possibly turn a condition into
+     the corresponding exception if the subprogram has a foreign convention or
+     is exported.
+
+     To ensure proper execution of local finalizations on condition instances,
+     we must turn a condition into the corresponding exception even if there
+     is no applicable Ada handler, and need at least one condition handler per
+     possible call chain involving GNAT code.  OTOH, establishing the handler
+     has a cost so we want to mimize the number of subprograms into which this
+     happens.  The foreign or exported condition is expected to satisfy all
+     the constraints.  */
+  if (TARGET_ABI_OPEN_VMS
+      && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node)))
+    establish_gnat_vms_condition_handler ();
+
   process_decls (Declarations (gnat_node), Empty, Empty, true, true);
 
   /* Generate the code of the subprogram itself.  A return statement will be
@@ -3082,25 +3166,11 @@ gnat_to_gnu (Node_Id gnat_node)
 	if (Null_Record_Present (gnat_node))
 	  gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
 
-	else if (TREE_CODE (gnu_aggr_type) == UNION_TYPE
-		 && TYPE_UNCHECKED_UNION_P (gnu_aggr_type))
-	  {
-	    /* The first element is the discrimant, which we ignore.  The
-	       next is the field we're building.  Convert the expression
-	       to the type of the field and then to the union type.  */
-	    Node_Id gnat_assoc
-	      = Next (First (Component_Associations (gnat_node)));
-	    Entity_Id gnat_field = Entity (First (Choices (gnat_assoc)));
-	    tree gnu_field_type
-	      = TREE_TYPE (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0));
-
-	    gnu_result = convert (gnu_field_type,
-				  gnat_to_gnu (Expression (gnat_assoc)));
-	  }
 	else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
 		 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
 	  gnu_result
-	    = assoc_to_constructor (First (Component_Associations (gnat_node)),
+	    = assoc_to_constructor (Etype (gnat_node),
+				    First (Component_Associations (gnat_node)),
 				    gnu_aggr_type);
 	else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
 	  gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
@@ -3996,7 +4066,8 @@ gnat_to_gnu (Node_Id gnat_node)
 
 	  if (Present (Actual_Designated_Subtype (gnat_node)))
 	    {
-	      gnu_actual_obj_type = gnat_to_gnu_type (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
@@ -5582,13 +5653,14 @@ process_type (Entity_Id gnat_entity)
     }
 }
 
-/* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
-   GNU_TYPE is the GCC type of the corresponding record.
+/* GNAT_ENTITY is the type of the resulting constructors,
+   GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
+   and GNU_TYPE is the GCC type of the corresponding record.
 
    Return a CONSTRUCTOR to build the record.  */
 
 static tree
-assoc_to_constructor (Node_Id gnat_assoc, tree gnu_type)
+assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
 {
   tree gnu_list, gnu_result;
 
@@ -5614,6 +5686,11 @@ assoc_to_constructor (Node_Id gnat_assoc, tree gnu_type)
 	  && Is_Tagged_Type (Scope (Entity (gnat_field))))
 	continue;
 
+      /* Also ignore discriminants of Unchecked_Unions.  */
+      else if (Is_Unchecked_Union (gnat_entity)
+	       && Ekind (Entity (gnat_field)) == E_Discriminant)
+	continue;
+
       /* Before assigning a value in an aggregate make sure range checks
 	 are done if required.  Then convert to the type of the field.  */
       if (Do_Range_Check (Expression (gnat_assoc)))

gcc/ada/utils.c

@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 1992-2005, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2006, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -133,7 +133,6 @@ static tree float_type_for_precision (int, enum machine_mode);
 static tree convert_to_fat_pointer (tree, tree);
 static tree convert_to_thin_pointer (tree, tree);
 static tree make_descriptor_field (const char *,tree, tree, tree);
-static bool value_factor_p (tree, HOST_WIDE_INT);
 static bool potential_alignment_gap (tree, tree, tree);
 
 /* Initialize the association of GNAT nodes to GCC trees.  */
@@ -1215,9 +1214,10 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list,
 
   /* Pass type declaration information to the debugger unless this is an
      UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
-     and ENUMERAL_TYPE or RECORD_TYPE which is handled separately,
-     a dummy type, which will be completed later, or a type for which
-     debugging information was not requested.  */
+     and ENUMERAL_TYPE or RECORD_TYPE which is handled separately, or
+     type for which debugging information was not requested.  */
+  if (code == UNCONSTRAINED_ARRAY_TYPE || ! debug_info_p)
+    DECL_IGNORED_P (type_decl) = 1;
   if (code == UNCONSTRAINED_ARRAY_TYPE || TYPE_IS_DUMMY_P (type)
       || !debug_info_p)
     DECL_IGNORED_P (type_decl) = 1;
@@ -1573,7 +1573,7 @@ process_attributes (tree decl, struct attrib *attr_list)
 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
    a power of 2. */
 
-static bool
+bool
 value_factor_p (tree value, HOST_WIDE_INT factor)
 {
   if (host_integerp (value, 1))
@@ -2471,7 +2471,8 @@ build_unc_object_type (tree template_type, tree object_type, tree name)
 /* Same, taking a thin or fat pointer type instead of a template type. */
 
 tree
-build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, tree name)
+build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
+				tree name)
 {
   tree template_type;
 
@@ -2592,7 +2593,13 @@ update_pointer_to (tree old_type, tree new_type)
 				  TREE_CHAIN (TYPE_FIELDS (ptr)), new_ref));
 
       for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var))
-	SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type);
+	{
+	  SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type);
+
+	  /* This may seem a bit gross, in particular wrt DECL_CONTEXT, but
+	     actually is in keeping with what build_qualified_type does.  */
+	  TYPE_FIELDS (var) = TYPE_FIELDS (ptr);
+	}
 
       TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type)
 	= TREE_TYPE (new_type) = ptr;
@@ -2722,7 +2729,6 @@ convert (tree type, tree expr)
   enum tree_code code = TREE_CODE (type);
   tree etype = TREE_TYPE (expr);
   enum tree_code ecode = TREE_CODE (etype);
-  tree tem;
 
   /* If EXPR is already the right type, we are done.  */
   if (type == etype)
@@ -2892,11 +2898,9 @@ convert (tree type, tree expr)
 	      return build1 (VIEW_CONVERT_EXPR, type, op0);
 
 	    /* Otherwise, we may just bypass the input view conversion unless
-	       one of the types is a fat pointer, or we're converting to an
-	       unchecked union type.  Both are handled by specialized code
-	       below and the latter relies on exact type matching.  */
-	    else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)
-		     && !(code == UNION_TYPE && TYPE_UNCHECKED_UNION_P (type)))
+	       one of the types is a fat pointer,  which is handled by
+	       specialized code below which relies on exact type matching.  */
+	    else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
 	      return convert (type, op0);
 	  }
       }
@@ -3020,29 +3024,10 @@ convert (tree type, tree expr)
       return unchecked_convert (type, expr, false);
 
     case UNION_TYPE:
-      /* For unchecked unions, just validate that the type is indeed that of
-	 a field of the type.  Then make the simple conversion.  */
-      if (TYPE_UNCHECKED_UNION_P (type))
-	{
-	  for (tem = TYPE_FIELDS (type); tem; tem = TREE_CHAIN (tem))
-	    {
-	      if (TREE_TYPE (tem) == etype)
-		return build1 (CONVERT_EXPR, type, expr);
-	      else if (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
-		       && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
-			   || TYPE_IS_PADDING_P (TREE_TYPE (tem)))
-		       && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype)
-		return build1 (CONVERT_EXPR, type,
-			       convert (TREE_TYPE (tem), expr));
-	    }
-
-	  gcc_unreachable ();
-	}
-      else
-	/* Otherwise, this is a conversion between a tagged type and some
-	   subtype, which we have to mark as a UNION_TYPE because of
-	   overlapping fields.  */
-	return unchecked_convert (type, expr, false);
+      /* This is a either a conversion between a tagged type and some
+	 subtype, which we have to mark as a UNION_TYPE because of
+	 overlapping fields or a conversion of an Unchecked_Union.  */
+      return unchecked_convert (type, expr, false);
 
     case UNCONSTRAINED_ARRAY_TYPE:
       /* If EXPR is a constrained array, take its address, convert it to a

gcc/ada/utils2.c

@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 1992-2005, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2006, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -232,8 +232,12 @@ find_common_type (tree t1, tree t2)
   else if (TYPE_MODE (t2) != BLKmode)
     return t2;
 
-  /* Otherwise, return the type that has a constant size.  */
-  if (TREE_CONSTANT (TYPE_SIZE (t1)))
+  /* If both types have constant size, use the smaller one.  */
+  if (TREE_CONSTANT (TYPE_SIZE (t1)) && TREE_CONSTANT (TYPE_SIZE (t2)))
+    return tree_int_cst_lt (TYPE_SIZE (t1), TYPE_SIZE (t2)) ? t1 : t2;
+
+  /* Otherwise, if either type has a constant size, use it.  */
+  else if (TREE_CONSTANT (TYPE_SIZE (t1)))
     return t1;
   else if (TREE_CONSTANT (TYPE_SIZE (t2)))
     return t2;
@@ -1617,7 +1621,8 @@ build_simple_component_ref (tree record_variable, tree component,
 
       for (new_field = TYPE_FIELDS (record_type); new_field;
 	   new_field = TREE_CHAIN (new_field))
-	if (DECL_ORIGINAL_FIELD (new_field) == field
+	if (field == new_field
+	    || DECL_ORIGINAL_FIELD (new_field) == field
 	    || new_field == DECL_ORIGINAL_FIELD (field)
 	    || (DECL_ORIGINAL_FIELD (field)
 		&& (DECL_ORIGINAL_FIELD (field)