gigi.h (build_vms_descriptor64): New function prototype.

2008-07-30  Doug Rupp  <rupp@adacore.com>

	* gigi.h (build_vms_descriptor64): New function prototype.
	(fill_vms_descriptor): Modified function prototype.

	* utils.c (build_vms_descriptor64): New function.

	* utils2.c (fill_vms_descriptor): Fix handling on 32bit systems.

	* trans.c (call_to_gnu): Call fill_vms_descriptor with new third
	argument.

	* decl.c (gnat_to_gnu_tree): For By_Descriptor mech, build both a
	64bit and 32bit descriptor and save the 64bit version as an alternate
	TREE_TYPE in the parameter.
	(make_type_from_size) <RECORD_TYPE>: Use the appropriate mode for the
	thin pointer.

	* ada-tree.h (DECL_PARM_ALT, SET_DECL_PARM_ALT): New macros.

From-SVN: r138307

7 files changed, 409 insertions, 17 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c5409d3..aa6615c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,23 @@
+2008-07-30  Doug Rupp  <rupp@adacore.com>
+
+	* gigi.h (build_vms_descriptor64): New function prototype.
+	(fill_vms_descriptor): Modified function prototype.
+
+	* utils.c (build_vms_descriptor64): New function.
+
+	* utils2.c (fill_vms_descriptor): Fix handling on 32bit systems.
+
+	* trans.c (call_to_gnu): Call fill_vms_descriptor with new third
+	argument.
+
+	* decl.c (gnat_to_gnu_tree): For By_Descriptor mech, build both a
+	64bit and 32bit descriptor and save the 64bit version as an alternate
+	TREE_TYPE in the parameter.
+	(make_type_from_size) <RECORD_TYPE>: Use the appropriate mode for the
+	thin pointer.
+
+	* ada-tree.h (DECL_PARM_ALT, SET_DECL_PARM_ALT): New macros.
+
 2008-07-30  Robert Dewar  <dewar@adacore.com>
 
 	* make.adb: Minor reformatting
diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index 9c31e46..9472995 100644
--- a/gcc/ada/gcc-interface/ada-tree.h
+++ b/gcc/ada/gcc-interface/ada-tree.h
@@ -294,6 +294,12 @@ struct lang_type GTY(()) {tree t; };
 #define SET_DECL_FUNCTION_STUB(NODE, X) \
   SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X)
 
+/* In a PARM_DECL, points to the alternate TREE_TYPE */
+#define DECL_PARM_ALT(NODE) \
+  GET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE))
+#define SET_DECL_PARM_ALT(NODE, X) \
+  SET_DECL_LANG_SPECIFIC (PARM_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))
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index ebc2e5e..61ae653 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -4774,6 +4774,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
 {
   tree gnu_param_name = get_entity_name (gnat_param);
   tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
+  tree gnu_param_type_alt = NULL_TREE;
   bool in_param = (Ekind (gnat_param) == E_In_Parameter);
   /* The parameter can be indirectly modified if its address is taken.  */
   bool ro_param = in_param && !Address_Taken (gnat_param);
@@ -4820,12 +4821,20 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
     gnu_param_type
       = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
 
-  /* VMS descriptors are themselves passed by reference.  */
+  /* VMS descriptors are themselves passed by reference.
+     Build both a 32bit and 64bit descriptor, one of which will be chosen
+     in fill_vms_descriptor based on the allocator size */
   if (mech == By_Descriptor)
-    gnu_param_type
-      = build_pointer_type (build_vms_descriptor (gnu_param_type,
-						  Mechanism (gnat_param),
-						  gnat_subprog));
+    {
+      gnu_param_type_alt
+        = build_pointer_type (build_vms_descriptor64 (gnu_param_type,
+						      Mechanism (gnat_param),
+						      gnat_subprog));
+      gnu_param_type
+        = build_pointer_type (build_vms_descriptor (gnu_param_type,
+						    Mechanism (gnat_param),
+						    gnat_subprog));
+    }
 
   /* Arrays are passed as pointers to element type for foreign conventions.  */
   else if (foreign
@@ -4921,6 +4930,9 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
   DECL_POINTS_TO_READONLY_P (gnu_param)
     = (ro_param && (by_ref || by_component_ptr));
 
+  /* Save the 64bit descriptor for later. */
+  SET_DECL_PARM_ALT (gnu_param, gnu_param_type_alt);
+
   /* If no Mechanism was specified, indicate what we're using, then
      back-annotate it.  */
   if (mech == Default)
@@ -7155,9 +7167,15 @@ make_type_from_size (tree type, tree size_tree, bool for_biased)
       /* Do something if this is a fat pointer, in which case we
 	 may need to return the thin pointer.  */
       if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
-	return
-	  build_pointer_type
-	    (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
+	{
+	  enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
+	  if (!targetm.valid_pointer_mode (p_mode))
+	    p_mode = ptr_mode;
+	  return
+	    build_pointer_type_for_mode
+	      (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
+	       p_mode, 0);
+	}
       break;
 
     case POINTER_TYPE:
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index aaf5e7f..685bb38 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -678,7 +678,7 @@ extern void end_subprog_body (tree body, bool elab_p);
    Return a constructor for the template.  */
 extern tree build_template (tree template_type, tree array_type, tree expr);
 
-/* Build a VMS descriptor from a Mechanism_Type, which must specify
+/* Build a 32bit VMS descriptor from a Mechanism_Type, which must specify
    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
    in the type contains in its DECL_INITIAL the expression to use when
    a constructor is made for the type.  GNAT_ENTITY is a gnat node used
@@ -687,6 +687,10 @@ extern tree build_template (tree template_type, tree array_type, tree expr);
 extern tree build_vms_descriptor (tree type, Mechanism_Type mech,
                                   Entity_Id gnat_entity);
 
+/* Build a 64bit VMS descriptor from a Mechanism_Type. See above. */
+extern tree build_vms_descriptor64 (tree type, Mechanism_Type mech,
+                                  Entity_Id gnat_entity);
+
 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
    and the GNAT node GNAT_SUBPROG.  */
 extern void build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog);
@@ -844,9 +848,9 @@ extern tree build_allocator (tree type, tree init, tree result_type,
                              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.  */
-
-extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal);
+   GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is how we
+   find the size of the allocator. */
+extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual);
 
 /* Indicate that we need to make the address of EXPR_NODE and it therefore
    should not be allocated in a register.  Return true if successful.  */
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 88f9a20..3b15e30 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -2368,7 +2368,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
 	  else
 	    gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
 					 fill_vms_descriptor (gnu_actual,
-							      gnat_formal));
+							      gnat_formal,
+							      gnat_actual));
 	}
       else
 	{
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index 4188d38..01cc9b8 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -2635,7 +2635,7 @@ build_template (tree template_type, tree array_type, tree expr)
   return gnat_build_constructor (template_type, nreverse (template_elts));
 }
 
-/* Build a VMS descriptor from a Mechanism_Type, which must specify
+/* Build a 32bit VMS descriptor from a Mechanism_Type, which must specify
    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
    in the type contains in its DECL_INITIAL the expression to use when
    a constructor is made for the type.  GNAT_ENTITY is an entity used
@@ -2937,6 +2937,321 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
   return record_type;
 }
 
+/* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify
+   a descriptor type, and the GCC type of an object.  Each FIELD_DECL
+   in the type contains in its DECL_INITIAL the expression to use when
+   a constructor is made for the type.  GNAT_ENTITY is an entity used
+   to print out an error message if the mechanism cannot be applied to
+   an object of that type and also for the name.  */
+
+tree
+build_vms_descriptor64 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
+{
+  tree record64_type = make_node (RECORD_TYPE);
+  tree pointer64_type;
+  tree field_list64 = 0;
+  int class;
+  int dtype = 0;
+  tree inner_type;
+  int ndim;
+  int i;
+  tree *idx_arr;
+  tree tem;
+
+  /* If TYPE is an unconstrained array, use the underlying array type.  */
+  if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+    type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
+
+  /* If this is an array, compute the number of dimensions in the array,
+     get the index types, and point to the inner type.  */
+  if (TREE_CODE (type) != ARRAY_TYPE)
+    ndim = 0;
+  else
+    for (ndim = 1, inner_type = type;
+	 TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
+	 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
+	 ndim++, inner_type = TREE_TYPE (inner_type))
+      ;
+
+  idx_arr = (tree *) alloca (ndim * sizeof (tree));
+
+  if (mech != By_Descriptor_NCA
+      && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
+    for (i = ndim - 1, inner_type = type;
+	 i >= 0;
+	 i--, inner_type = TREE_TYPE (inner_type))
+      idx_arr[i] = TYPE_DOMAIN (inner_type);
+  else
+    for (i = 0, inner_type = type;
+	 i < ndim;
+	 i++, inner_type = TREE_TYPE (inner_type))
+      idx_arr[i] = TYPE_DOMAIN (inner_type);
+
+  /* Now get the DTYPE value.  */
+  switch (TREE_CODE (type))
+    {
+    case INTEGER_TYPE:
+    case ENUMERAL_TYPE:
+      if (TYPE_VAX_FLOATING_POINT_P (type))
+	switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
+	  {
+	  case 6:
+	    dtype = 10;
+	    break;
+	  case 9:
+	    dtype = 11;
+	    break;
+	  case 15:
+	    dtype = 27;
+	    break;
+	  }
+      else
+	switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
+	  {
+	  case 8:
+	    dtype = TYPE_UNSIGNED (type) ? 2 : 6;
+	    break;
+	  case 16:
+	    dtype = TYPE_UNSIGNED (type) ? 3 : 7;
+	    break;
+	  case 32:
+	    dtype = TYPE_UNSIGNED (type) ? 4 : 8;
+	    break;
+	  case 64:
+	    dtype = TYPE_UNSIGNED (type) ? 5 : 9;
+	    break;
+	  case 128:
+	    dtype = TYPE_UNSIGNED (type) ? 25 : 26;
+	    break;
+	  }
+      break;
+
+    case REAL_TYPE:
+      dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
+      break;
+
+    case COMPLEX_TYPE:
+      if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
+	  && TYPE_VAX_FLOATING_POINT_P (type))
+	switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
+	  {
+	  case 6:
+	    dtype = 12;
+	    break;
+	  case 9:
+	    dtype = 13;
+	    break;
+	  case 15:
+	    dtype = 29;
+	  }
+      else
+	dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
+      break;
+
+    case ARRAY_TYPE:
+      dtype = 14;
+      break;
+
+    default:
+      break;
+    }
+
+  /* Get the CLASS value.  */
+  switch (mech)
+    {
+    case By_Descriptor_A:
+      class = 4;
+      break;
+    case By_Descriptor_NCA:
+      class = 10;
+      break;
+    case By_Descriptor_SB:
+      class = 15;
+      break;
+    case By_Descriptor:
+    case By_Descriptor_S:
+    default:
+      class = 1;
+      break;
+    }
+
+  /* Make the type for a 64bit descriptor for VMS.  The first six fields
+     are the same for all types.  */
+
+  field_list64 = chainon (field_list64,
+			make_descriptor_field ("MBO",
+                                               gnat_type_for_size (16, 1),
+                                               record64_type, size_int (1)));
+
+  field_list64 = chainon (field_list64,
+			make_descriptor_field ("DTYPE",
+					       gnat_type_for_size (8, 1),
+					       record64_type, size_int (dtype)));
+  field_list64 = chainon (field_list64,
+			make_descriptor_field ("CLASS",
+					       gnat_type_for_size (8, 1),
+					       record64_type, size_int (class)));
+
+  field_list64 = chainon (field_list64,
+			make_descriptor_field ("MBMO",
+                                               gnat_type_for_size (32, 1),
+                                               record64_type, ssize_int (-1)));
+
+  field_list64
+    = chainon (field_list64,
+	       make_descriptor_field
+	       ("LENGTH", gnat_type_for_size (64, 1), record64_type,
+		size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
+
+  pointer64_type = build_pointer_type_for_mode (type, DImode, false);
+
+  field_list64
+    = chainon (field_list64,
+	       make_descriptor_field
+	       ("POINTER", pointer64_type, record64_type,
+		build_unary_op (ADDR_EXPR,
+				pointer64_type,
+				build0 (PLACEHOLDER_EXPR, type))));
+
+  switch (mech)
+    {
+    case By_Descriptor:
+    case By_Descriptor_S:
+      break;
+
+    case By_Descriptor_SB:
+      field_list64
+	= chainon (field_list64,
+		   make_descriptor_field
+		   ("SB_L1", gnat_type_for_size (64, 1), record64_type,
+		    TREE_CODE (type) == ARRAY_TYPE
+		    ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
+      field_list64
+	= chainon (field_list64,
+		   make_descriptor_field
+		   ("SB_U1", gnat_type_for_size (64, 1), record64_type,
+		    TREE_CODE (type) == ARRAY_TYPE
+		    ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
+      break;
+
+    case By_Descriptor_A:
+    case By_Descriptor_NCA:
+      field_list64 = chainon (field_list64,
+			    make_descriptor_field ("SCALE",
+						   gnat_type_for_size (8, 1),
+						   record64_type,
+						   size_zero_node));
+
+      field_list64 = chainon (field_list64,
+			    make_descriptor_field ("DIGITS",
+						   gnat_type_for_size (8, 1),
+						   record64_type,
+						   size_zero_node));
+
+      field_list64
+	= chainon (field_list64,
+		   make_descriptor_field
+		   ("AFLAGS", gnat_type_for_size (8, 1), record64_type,
+		    size_int (mech == By_Descriptor_NCA
+			      ? 0
+			      /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS.  */
+			      : (TREE_CODE (type) == ARRAY_TYPE
+				 && TYPE_CONVENTION_FORTRAN_P (type)
+				 ? 224 : 192))));
+
+      field_list64 = chainon (field_list64,
+			    make_descriptor_field ("DIMCT",
+						   gnat_type_for_size (8, 1),
+						   record64_type,
+						   size_int (ndim)));
+
+      field_list64 = chainon (field_list64,
+			    make_descriptor_field ("MBZ",
+						   gnat_type_for_size (32, 1),
+						   record64_type,
+						   size_int (0)));
+      field_list64 = chainon (field_list64,
+			    make_descriptor_field ("ARSIZE",
+						   gnat_type_for_size (64, 1),
+						   record64_type,
+						   size_in_bytes (type)));
+
+      /* Now build a pointer to the 0,0,0... element.  */
+      tem = build0 (PLACEHOLDER_EXPR, type);
+      for (i = 0, inner_type = type; i < ndim;
+	   i++, inner_type = TREE_TYPE (inner_type))
+	tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
+		      convert (TYPE_DOMAIN (inner_type), size_zero_node),
+		      NULL_TREE, NULL_TREE);
+
+      field_list64
+	= chainon (field_list64,
+		   make_descriptor_field
+		   ("A0",
+		    build_pointer_type_for_mode (inner_type, DImode, false),
+		    record64_type,
+		    build1 (ADDR_EXPR,
+			    build_pointer_type_for_mode (inner_type, DImode,
+							 false),
+			    tem)));
+
+      /* Next come the addressing coefficients.  */
+      tem = size_one_node;
+      for (i = 0; i < ndim; i++)
+	{
+	  char fname[3];
+	  tree idx_length
+	    = size_binop (MULT_EXPR, tem,
+			  size_binop (PLUS_EXPR,
+				      size_binop (MINUS_EXPR,
+						  TYPE_MAX_VALUE (idx_arr[i]),
+						  TYPE_MIN_VALUE (idx_arr[i])),
+				      size_int (1)));
+
+	  fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
+	  fname[1] = '0' + i, fname[2] = 0;
+	  field_list64
+	    = chainon (field_list64,
+		       make_descriptor_field (fname,
+					      gnat_type_for_size (64, 1),
+					      record64_type, idx_length));
+
+	  if (mech == By_Descriptor_NCA)
+	    tem = idx_length;
+	}
+
+      /* Finally here are the bounds.  */
+      for (i = 0; i < ndim; i++)
+	{
+	  char fname[3];
+
+	  fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
+	  field_list64
+	    = chainon (field_list64,
+		       make_descriptor_field
+		       (fname, gnat_type_for_size (64, 1), record64_type,
+			TYPE_MIN_VALUE (idx_arr[i])));
+
+	  fname[0] = 'U';
+	  field_list64
+	    = chainon (field_list64,
+		       make_descriptor_field
+		       (fname, gnat_type_for_size (64, 1), record64_type,
+			TYPE_MAX_VALUE (idx_arr[i])));
+	}
+      break;
+
+    default:
+      post_error ("unsupported descriptor type for &", gnat_entity);
+    }
+
+  finish_record_type (record64_type, field_list64, 0, true);
+  create_type_decl (create_concat_name (gnat_entity, "DESC64"), record64_type,
+		    NULL, true, false, gnat_entity);
+
+  return record64_type;
+}
+
 /* Utility routine for above code to make a field.  */
 
 static tree
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 300fbd3..1ed1b9f 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -2151,15 +2151,43 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
 }
 
 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
-   GNAT_FORMAL is how we find the descriptor record.  */
+   GNAT_FORMAL is how we find the descriptor record.  GNAT_ACTUAL is
+   how we find the allocator size which determines whether to use the
+   alternate 64bit descriptor. */
 
 tree
-fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
+fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
 {
-  tree record_type = TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal)));
   tree field;
+  tree parm_decl = get_gnu_tree (gnat_formal);
   tree const_list = NULL_TREE;
+  int size;
+  tree record_type;
+
+  /* A string literal will always be in 32bit space on VMS. Where
+     will it be on other 64bit systems???
+     An identifier's allocation may be unknown at compile time.
+     An explicit dereference could be either in 32bit or 64bit space.
+     Don't know about other possibilities, so assume unknown which
+     will result in fetching the 64bit descriptor. ??? */
+  if (Nkind (gnat_actual) == N_String_Literal)
+    size = 32;
+  else if (Nkind (gnat_actual) == N_Identifier)
+    size = UI_To_Int (Esize (Etype (gnat_actual)));
+  else if (Nkind (gnat_actual) == N_Explicit_Dereference)
+    size = UI_To_Int (Esize (Etype (Prefix (gnat_actual))));
+  else
+    size = 0;
+
+  /* If size is unknown, make it POINTER_SIZE */
+  if (size == 0)
+    size = POINTER_SIZE;
+
+  /* If size is 64bits grab the alternate 64bit descriptor. */
+  if (size == 64)
+    TREE_TYPE (parm_decl) = DECL_PARM_ALT (parm_decl);
 
+  record_type = TREE_TYPE (TREE_TYPE (parm_decl));
   expr = maybe_unconstrained_array (expr);
   gnat_mark_addressable (expr);