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

	* gcc-interface/utils2.c:
	(fill_vms_descriptor): Raise CE if attempt made to pass 64bit pointer
	in 32bit descriptor.

From-SVN: r138588

gcc/ada/ChangeLog

+2008-08-04  Doug Rupp  <rupp@adacore.com>
+
+	* gcc-interface/utils2.c:
+	(fill_vms_descriptor): Raise CE if attempt made to pass 64bit pointer
+	in 32bit descriptor.
+
+2008-08-04  Robert Dewar  <dewar@adacore.com>
+
+	* par-ch10.adb: Minor reformatting
+
+	* i-cobol.adb: Minor reformatting.
+
+2008-08-04  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Access_Definition): Create an itype reference for an
+	anonymous access return type of a regular function that is not a
+	compilation unit.
+
+2008-08-04  Vincent Celier  <celier@adacore.com>
+
+	* prj-attr.adb: New Builder attribute Global_Compilation_Switches
+	
+	* snames.adb: New standard name Global_Compilation_Switches
+	
+	* snames.ads: New standard name Global_Compilation_Switches
+
+	* make.adb: Correct spelling error in comment
+
+2008-08-04  Arnaud Charlet  <charlet@adacore.com>
+
+	* sem_prag.adb (Check_Form_Of_Interface_Name): Fix handling for CLI
+	target.
+
+2008-08-04  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_ch10.adb: Minor comment fix.
+
 2008-08-04  Robert Dewar  <dewar@adacore.com>
 
 	* restrict.adb: Improved messages for restriction warnings

gcc/ada/gcc-interface/utils2.c

@@ -2169,19 +2169,37 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
   tree field;
   tree parm_decl = get_gnu_tree (gnat_formal);
   tree const_list = NULL_TREE;
-  tree record_type;
+  tree record_type = TREE_TYPE (TREE_TYPE (parm_decl));
+  int do_range_check =
+      strcmp ("MBO",
+	      IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type))));
 
-  record_type = TREE_TYPE (TREE_TYPE (parm_decl));
   expr = maybe_unconstrained_array (expr);
   gnat_mark_addressable (expr);
 
   for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
-    const_list
-      = tree_cons (field,
-		   convert (TREE_TYPE (field),
-			    SUBSTITUTE_PLACEHOLDER_IN_EXPR
-			    (DECL_INITIAL (field), expr)),
-		   const_list);
+    {
+      tree conexpr = convert (TREE_TYPE (field),
+			      SUBSTITUTE_PLACEHOLDER_IN_EXPR
+			      (DECL_INITIAL (field), expr));
+
+      /* Check to ensure that only 32bit pointers are passed in
+	 32bit descriptors */
+      if (do_range_check &&
+          strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0)
+        {
+          tree t = build3 (COND_EXPR, void_type_node,
+			   build_binary_op (LT_EXPR, integer_type_node,
+					    convert (integer_type_node,
+						     conexpr), 
+					    integer_zero_node),
+			   build_call_raise (CE_Range_Check_Failed, Empty,
+					     N_Raise_Constraint_Error),
+			   NULL_TREE);
+          add_stmt (t);
+        }
+      const_list = tree_cons (field, conexpr, const_list);
+    }
 
   return gnat_build_constructor (record_type, nreverse (const_list));
 }