gnat_rm.texi: Document new mechanism Short_Descriptor.

2008-08-01  Doug Rupp  <rupp@adacore.com>

	* gnat_rm.texi: Document new mechanism Short_Descriptor.
	
	* types.ads (Mechanism_Type): Modify range for new Short_Descriptor
	mechanism values.

	* sem_prag.adb (Set_Mechanism_Value): Enhance for Short_Descriptor
	mechanism and Short_Descriptor mechanism values.

	* snames.adb (preset_names): Add short_descriptor entry.

	* snames.ads: Add Name_Short_Descriptor.

	* types.h: Add new By_Short_Descriptor mechanism values.

	* sem_mech.adb (Set_Mechanism_Value): Enhance for Short_Descriptor
	mechanism and Short_Descriptor mechanism values.

	* sem_mech.ads (Mechanism_Type): Add new By_Short_Descriptor mechanism
	values.
	(Descriptor_Codes): Modify range for new mechanism values.

	* treepr.adb (Print_Entity_Enfo): Handle new By_Short_Descriptor
	mechanism values.

	* gcc-interface/decl.c (gnat_to_gnu_entity): Handle By_Short_Descriptor.
	(gnat_to_gnu_param): Handle By_Short_Descriptor.

	* gcc-interface/gigi.h (build_vms_descriptor64): Remove prototype.
	(build_vms_descriptor32): New prototype.
	(fill_vms_descriptor): Remove unneeded gnat_actual parameter.

	* gcc-interface/trans.c (call_to_gnu): Removed unneeded gnat_actual
	argument in call fill_vms_descriptor.

	* gcc-interface/utils.c (build_vms_descriptor32): Renamed from
	build_vms_descriptor and enhanced to hande Short_Descriptor mechanism.
	(build_vms_descriptor): Renamed from build_vms_descriptor64. 
	(convert_vms_descriptor32): New function.
	(convert_vms_descriptor64): New function.
	(convert_vms_descriptor): Rewrite to handle both 32bit and 64bit
	descriptors.

	* gcc-interface/utils2.c (fill_vms_descriptor): Revert previous changes,
	no longer needed.

From-SVN: r138473

5 files changed, 263 insertions, 60 deletions

diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index f8ebf5a..f7f4a0d 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -3872,6 +3872,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	      ;
 	    else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
 	      mech = By_Descriptor;
+
+	    else if (By_Short_Descriptor_Last <= mech &&
+                     mech <= By_Short_Descriptor)
+	      mech = By_Short_Descriptor;
+
 	    else if (mech > 0)
 	      {
 		if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
@@ -3913,7 +3918,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		      = chainon (gnu_param, gnu_stub_param_list);
 		    /* Change By_Descriptor parameter to By_Reference for
 		       the internal version of an exported subprogram.  */
-		    if (mech == By_Descriptor)
+		    if (mech == By_Descriptor || mech == By_Short_Descriptor)
 		      {
 			gnu_param
 			  = gnat_to_gnu_param (gnat_param, By_Reference,
@@ -4828,11 +4833,11 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
 
   /* 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 */
+     in fill_vms_descriptor. */
   if (mech == By_Descriptor)
     {
       gnu_param_type_alt
-        = build_pointer_type (build_vms_descriptor64 (gnu_param_type,
+        = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
 						      Mechanism (gnat_param),
 						      gnat_subprog));
       gnu_param_type
@@ -4840,6 +4845,15 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
 						    Mechanism (gnat_param),
 						    gnat_subprog));
     }
+  else if (mech == By_Short_Descriptor)
+    {
+      gnu_param_type_alt = NULL_TREE;
+
+      gnu_param_type
+        = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
+						    Mechanism (gnat_param),
+						    gnat_subprog));
+    }
 
   /* Arrays are passed as pointers to element type for foreign conventions.  */
   else if (foreign
@@ -4920,6 +4934,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
       && !by_ref
       && (by_return
 	  || (mech != By_Descriptor
+              && mech != By_Short_Descriptor
 	      && !POINTER_TYPE_P (gnu_param_type)
 	      && !AGGREGATE_TYPE_P (gnu_param_type)))
       && !(Is_Array_Type (Etype (gnat_param))
@@ -4931,11 +4946,12 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
 				 ro_param || by_ref || by_component_ptr);
   DECL_BY_REF_P (gnu_param) = by_ref;
   DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
-  DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
+  DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
+                                      mech == By_Short_Descriptor);
   DECL_POINTS_TO_READONLY_P (gnu_param)
     = (ro_param && (by_ref || by_component_ptr));
 
-  /* Save the 64bit descriptor for later. */
+  /* Save the alternate descriptor for later. */
   SET_DECL_PARM_ALT (gnu_param, gnu_param_type_alt);
 
   /* If no Mechanism was specified, indicate what we're using, then
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index f44fec8..915e44f 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -683,7 +683,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 32bit VMS descriptor from a Mechanism_Type, which must specify
+/* 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 a gnat node used
@@ -692,8 +692,8 @@ 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,
+/* Build a 32bit VMS descriptor from a Mechanism_Type. See above. */
+extern tree build_vms_descriptor32 (tree type, Mechanism_Type mech,
                                   Entity_Id gnat_entity);
 
 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
@@ -853,9 +853,8 @@ 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. 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);
+   GNAT_FORMAL is how we find the descriptor record. */
+extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal);
 
 /* 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 f8e1d49..677ec01 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -2392,8 +2392,7 @@ 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_actual));
+							      gnat_formal));
 	}
       else
 	{
@@ -5910,7 +5909,7 @@ build_unary_op_trapv (enum tree_code code,
 {
   gcc_assert ((code == NEGATE_EXPR) || (code == ABS_EXPR));
 
-  operand = save_expr (operand);
+  operand = protect_multiple_eval (operand);
 
   return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
 				      operand, TYPE_MIN_VALUE (gnu_type)),
@@ -5929,8 +5928,8 @@ build_binary_op_trapv (enum tree_code code,
 		       tree left,
 		       tree right)
 {
-  tree lhs = save_expr (left);
-  tree rhs = save_expr (right);
+  tree lhs = protect_multiple_eval (left);
+  tree rhs = protect_multiple_eval (right);
   tree type_max = TYPE_MAX_VALUE (gnu_type);
   tree type_min = TYPE_MIN_VALUE (gnu_type);
   tree gnu_expr;
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index 2105abd..f94d4ba 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -2659,7 +2659,7 @@ build_template (tree template_type, tree array_type, tree expr)
    an object of that type and also for the name.  */
 
 tree
-build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
+build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 {
   tree record_type = make_node (RECORD_TYPE);
   tree pointer32_type;
@@ -2689,7 +2689,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 
   idx_arr = (tree *) alloca (ndim * sizeof (tree));
 
-  if (mech != By_Descriptor_NCA
+  if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA
       && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
     for (i = ndim - 1, inner_type = type;
 	 i >= 0;
@@ -2775,16 +2775,21 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
   switch (mech)
     {
     case By_Descriptor_A:
+    case By_Short_Descriptor_A:
       class = 4;
       break;
     case By_Descriptor_NCA:
+    case By_Short_Descriptor_NCA:
       class = 10;
       break;
     case By_Descriptor_SB:
+    case By_Short_Descriptor_SB:
       class = 15;
       break;
     case By_Descriptor:
+    case By_Short_Descriptor:
     case By_Descriptor_S:
+    case By_Short_Descriptor_S:
     default:
       class = 1;
       break;
@@ -2797,7 +2802,9 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
     = chainon (field_list,
 	       make_descriptor_field
 	       ("LENGTH", gnat_type_for_size (16, 1), record_type,
-		size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
+		size_in_bytes ((mech == By_Descriptor_A ||
+                                mech == By_Short_Descriptor_A)
+                               ? inner_type : type)));
 
   field_list = chainon (field_list,
 			make_descriptor_field ("DTYPE",
@@ -2823,10 +2830,13 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
   switch (mech)
     {
     case By_Descriptor:
+    case By_Short_Descriptor:
     case By_Descriptor_S:
+    case By_Short_Descriptor_S:
       break;
 
     case By_Descriptor_SB:
+    case By_Short_Descriptor_SB:
       field_list
 	= chainon (field_list,
 		   make_descriptor_field
@@ -2842,7 +2852,9 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
       break;
 
     case By_Descriptor_A:
+    case By_Short_Descriptor_A:
     case By_Descriptor_NCA:
+    case By_Short_Descriptor_NCA:
       field_list = chainon (field_list,
 			    make_descriptor_field ("SCALE",
 						   gnat_type_for_size (8, 1),
@@ -2859,7 +2871,8 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 	= chainon (field_list,
 		   make_descriptor_field
 		   ("AFLAGS", gnat_type_for_size (8, 1), record_type,
-		    size_int (mech == By_Descriptor_NCA
+		    size_int ((mech == By_Descriptor_NCA ||
+                              mech == By_Short_Descriptor_NCA)
 			      ? 0
 			      /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS.  */
 			      : (TREE_CODE (type) == ARRAY_TYPE
@@ -2910,7 +2923,8 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 						  TYPE_MIN_VALUE (idx_arr[i])),
 				      size_int (1)));
 
-	  fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
+	  fname[0] = ((mech == By_Descriptor_NCA ||
+                       mech == By_Short_Descriptor_NCA) ? 'S' : 'M');
 	  fname[1] = '0' + i, fname[2] = 0;
 	  field_list
 	    = chainon (field_list,
@@ -2918,7 +2932,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 					      gnat_type_for_size (32, 1),
 					      record_type, idx_length));
 
-	  if (mech == By_Descriptor_NCA)
+	  if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA)
 	    tem = idx_length;
 	}
 
@@ -2962,7 +2976,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
    an object of that type and also for the name.  */
 
 tree
-build_vms_descriptor64 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
+build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
 {
   tree record64_type = make_node (RECORD_TYPE);
   tree pointer64_type;
@@ -3283,12 +3297,160 @@ make_descriptor_field (const char *name, tree type,
   return field;
 }
 
-/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
-   pointer or fat pointer type.  GNAT_SUBPROG is the subprogram to which
-   the VMS descriptor is passed.  */
+/* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a
+   regular pointer or fat pointer type.  GNAT_SUBPROG is the subprogram to
+   which the VMS descriptor is passed.  */
 
 static tree
-convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
+convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
+{
+  tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
+  tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
+  /* The CLASS field is the 3rd field in the descriptor.  */
+  tree class = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type)));
+  /* The POINTER field is the 6th field in the descriptor.  */
+  tree pointer64 = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (class)));
+
+  /* Retrieve the value of the POINTER field.  */
+  tree gnu_expr64
+    = build3 (COMPONENT_REF, TREE_TYPE (pointer64), desc, pointer64, NULL_TREE);
+
+  if (POINTER_TYPE_P (gnu_type))
+    return convert (gnu_type, gnu_expr64);
+
+  else if (TYPE_FAT_POINTER_P (gnu_type))
+    {
+      tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
+      tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
+      tree template_type = TREE_TYPE (p_bounds_type);
+      tree min_field = TYPE_FIELDS (template_type);
+      tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type));
+      tree template, template_addr, aflags, dimct, t, u;
+      /* See the head comment of build_vms_descriptor.  */
+      int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class));
+      tree lfield, ufield;
+
+      /* Convert POINTER to the type of the P_ARRAY field.  */
+      gnu_expr64 = convert (p_array_type, gnu_expr64);
+
+      switch (iclass)
+	{
+	case 1:  /* Class S  */
+	case 15: /* Class SB */
+	  /* Build {1, LENGTH} template; LENGTH64 is the 5th field.  */
+	  t = TREE_CHAIN (TREE_CHAIN (class));
+	  t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  t = tree_cons (min_field,
+			 convert (TREE_TYPE (min_field), integer_one_node),
+			 tree_cons (max_field,
+				    convert (TREE_TYPE (max_field), t),
+				    NULL_TREE));
+	  template = gnat_build_constructor (template_type, t);
+	  template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
+
+	  /* For class S, we are done.  */
+	  if (iclass == 1)
+	    break;
+
+	  /* Test that we really have a SB descriptor, like DEC Ada.  */
+	  t = build3 (COMPONENT_REF, TREE_TYPE (class), desc, class, NULL);
+	  u = convert (TREE_TYPE (class), DECL_INITIAL (class));
+	  u = build_binary_op (EQ_EXPR, integer_type_node, t, u);
+	  /* If so, there is already a template in the descriptor and
+	     it is located right after the POINTER field.  The fields are
+             64bits so they must be repacked. */
+	  t = TREE_CHAIN (pointer64);
+          lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+          lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
+
+	  t = TREE_CHAIN (t);
+          ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+          ufield = convert
+           (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield);
+
+	  /* Build the template in the form of a constructor. */
+	  t = tree_cons (TYPE_FIELDS (template_type), lfield,
+			 tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)),
+                                    ufield, NULL_TREE));
+	  template = gnat_build_constructor (template_type, t);
+
+	  /* Otherwise use the {1, LENGTH} template we build above.  */
+	  template_addr = build3 (COND_EXPR, p_bounds_type, u,
+				  build_unary_op (ADDR_EXPR, p_bounds_type,
+				 		 template),
+				  template_addr);
+	  break;
+
+	case 4:  /* Class A */
+	  /* The AFLAGS field is the 3rd field after the pointer in the
+             descriptor.  */
+	  t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer64)));
+	  aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  /* The DIMCT field is the next field in the descriptor after
+             aflags.  */
+	  t = TREE_CHAIN (t);
+	  dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  /* Raise CONSTRAINT_ERROR if either more than 1 dimension
+	     or FL_COEFF or FL_BOUNDS not set.  */
+	  u = build_int_cst (TREE_TYPE (aflags), 192);
+	  u = build_binary_op (TRUTH_OR_EXPR, integer_type_node,
+			       build_binary_op (NE_EXPR, integer_type_node,
+						dimct,
+						convert (TREE_TYPE (dimct),
+							 size_one_node)),
+			       build_binary_op (NE_EXPR, integer_type_node,
+						build2 (BIT_AND_EXPR,
+							TREE_TYPE (aflags),
+							aflags, u),
+						u));
+	  /* There is already a template in the descriptor and it is located
+             in block 3.  The fields are 64bits so they must be repacked. */
+	  t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN
+              (t)))));
+          lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+          lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
+
+	  t = TREE_CHAIN (t);
+          ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+          ufield = convert
+           (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield);
+
+	  /* Build the template in the form of a constructor. */
+	  t = tree_cons (TYPE_FIELDS (template_type), lfield,
+			 tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)),
+                                    ufield, NULL_TREE));
+	  template = gnat_build_constructor (template_type, t);
+	  template = build3 (COND_EXPR, p_bounds_type, u,
+			    build_call_raise (CE_Length_Check_Failed, Empty,
+					      N_Raise_Constraint_Error),
+			    template);
+	  template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template);
+	  break;
+
+	case 10: /* Class NCA */
+	default:
+	  post_error ("unsupported descriptor type for &", gnat_subprog);
+	  template_addr = integer_zero_node;
+	  break;
+	}
+
+      /* Build the fat pointer in the form of a constructor.  */
+      t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr64,
+		     tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)),
+				template_addr, NULL_TREE));
+      return gnat_build_constructor (gnu_type, t);
+    }
+
+  else
+    gcc_unreachable ();
+}
+
+/* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a
+   regular pointer or fat pointer type.  GNAT_SUBPROG is the subprogram to
+   which the VMS descriptor is passed.  */
+
+static tree
+convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
 {
   tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
   tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
@@ -3298,11 +3460,11 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
   tree pointer = TREE_CHAIN (class);
 
   /* Retrieve the value of the POINTER field.  */
-  gnu_expr
+  tree gnu_expr32
     = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
 
   if (POINTER_TYPE_P (gnu_type))
-    return convert (gnu_type, gnu_expr);
+    return convert (gnu_type, gnu_expr32);
 
   else if (TYPE_FAT_POINTER_P (gnu_type))
     {
@@ -3316,7 +3478,7 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
       int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class));
 
       /* Convert POINTER to the type of the P_ARRAY field.  */
-      gnu_expr = convert (p_array_type, gnu_expr);
+      gnu_expr32 = convert (p_array_type, gnu_expr32);
 
       switch (iclass)
 	{
@@ -3372,14 +3534,14 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
 							TREE_TYPE (aflags),
 							aflags, u),
 						u));
-	  add_stmt (build3 (COND_EXPR, void_type_node, u,
-			    build_call_raise (CE_Length_Check_Failed, Empty,
-					      N_Raise_Constraint_Error),
-			    NULL_TREE));
 	  /* There is already a template in the descriptor and it is
 	     located at the start of block 3 (12th field).  */
 	  t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t))));
 	  template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+	  template = build3 (COND_EXPR, p_bounds_type, u,
+			    build_call_raise (CE_Length_Check_Failed, Empty,
+					      N_Raise_Constraint_Error),
+			    template);
 	  template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template);
 	  break;
 
@@ -3391,9 +3553,10 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
 	}
 
       /* Build the fat pointer in the form of a constructor.  */
-      t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr,
+      t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr32,
 		     tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)),
 				template_addr, NULL_TREE));
+
       return gnat_build_constructor (gnu_type, t);
     }
 
@@ -3401,6 +3564,56 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
     gcc_unreachable ();
 }
 
+/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a
+   regular pointer or fat pointer type.  GNAT_SUBPROG is the subprogram to
+   which the VMS descriptor is passed.  */
+
+static tree
+convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
+{
+  tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
+  tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
+  tree mbo = TYPE_FIELDS (desc_type);
+  const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo));
+  tree mbmo = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (mbo)));
+  tree is64bit;
+  tree save_type = TREE_TYPE (gnu_expr);
+  tree gnu_expr32, gnu_expr64;
+
+  if (strcmp (mbostr, "MBO") != 0)
+    /* If the field name is not MBO, it must be 32bit and no alternate */
+    return convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog);
+
+  /* Otherwise primary must be 64bit and alternate 32bit */
+
+  /* Test for 64bit descriptor */
+  mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE);
+  mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE);
+  is64bit = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
+            build_binary_op (EQ_EXPR, integer_type_node,
+                                convert (integer_type_node, mbo),
+                                integer_one_node),
+            build_binary_op (EQ_EXPR, integer_type_node,
+                                convert (integer_type_node, mbmo),
+                                integer_minus_one_node));
+
+  gnu_expr64 = convert_vms_descriptor64 (gnu_type, gnu_expr,
+                                         gnat_subprog);
+  /* Convert 32bit alternate. Hack alert ??? */
+  TREE_TYPE (gnu_expr) = DECL_PARM_ALT (gnu_expr);
+  gnu_expr32 = convert_vms_descriptor32 (gnu_type, gnu_expr,
+                                         gnat_subprog);
+  TREE_TYPE (gnu_expr) = save_type;
+
+  if (POINTER_TYPE_P (gnu_type))
+     return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32);
+
+  else if (TYPE_FAT_POINTER_P (gnu_type))
+      return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32);
+  else
+    gcc_unreachable ();
+}
+
 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
    and the GNAT node GNAT_SUBPROG.  */
 
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 1ed1b9f..1424ac8 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -2156,37 +2156,13 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
    alternate 64bit descriptor. */
 
 tree
-fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
+fill_vms_descriptor (tree expr, Entity_Id 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);