gigi.h (fill_vms_descriptor): Add third parameter gnat_actual

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

	* gigi.h (fill_vms_descriptor): Add third parameter gnat_actual
	* trans.c (call_to_gnu): Call fill_vms_descriptor with new parameter.
	* utils2.c (fill_vms_descriptor): Add third parameter for error sloc and
	use it.  Calculate pointer range overflow using 64bit types.

From-SVN: r138594

4 files changed, 58 insertions, 16 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 909e815..beef1a4 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,38 @@
+2008-08-04  Doug Rupp  <rupp@adacore.com>
+
+	* gigi.h (fill_vms_descriptor): Add third parameter gnat_actual
+	* trans.c (call_to_gnu): Call fill_vms_descriptor with new parameter.
+	* utils2.c (fill_vms_descriptor): Add third parameter for error sloc and
+	use it.  Calculate pointer range overflow using 64bit types.
+
+2008-08-04  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Access_Definition): A formal object declaration is a
+	legal context for an anonymous access to subprogram.
+
+	* sem_ch4.adb (Analyze_One_Call): If the call can be interpreted as an
+	indirect call, report success to the caller to include possible
+	interpretation.
+
+	* sem_ch6.adb (Check_Return_Type_Indication): Apply proper conformance
+	check when the type
+	of the extended return is an anonymous access_to_subprogram type.
+
+	* sem_res.adb:
+	(Resolve_Call): Insert a dereference if the type of the subprogram is an
+	access_to_subprogram and the context requires its return type, and a
+	dereference has not been introduced previously.
+
+2008-08-04  Arnaud Charlet  <charlet@adacore.com>
+
+	* usage.adb (Usage): Minor rewording of -gnatwz switch, to improve
+	gnatcheck support in GPS.
+
+2008-08-04  Vincent Celier  <celier@adacore.com>
+
+	* mlib.adb (Create_Sym_Links): Create relative symbolic links when
+	requested
+
 2008-08-04  Vincent Celier  <celier@adacore.com>
 
 	* gprep.adb (Process_One_File): Call Prep.Preprocess with a Boolean
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 915e44f..1b3fa24 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -853,8 +853,10 @@ 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 derive the source location on a C_E */
+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 43e6afb..97ff3bd 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -2392,7 +2392,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/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 44c78f4..89fb5f0 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -2160,11 +2160,11 @@ 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_ACTUAL is
-   how we find the allocator size which determines whether to use the
-   alternate 64bit descriptor. */
+   how we derive the source location to raise C_E on an out of range
+   pointer. */
 
 tree
-fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
+fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
 {
   tree field;
   tree parm_decl = get_gnu_tree (gnat_formal);
@@ -2173,7 +2173,6 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
   int do_range_check =
       strcmp ("MBO",
 	      IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type))));
-  tree malloc64low = build_int_cstu (long_integer_type_node, 0x80000000);
 
   expr = maybe_unconstrained_array (expr);
   gnat_mark_addressable (expr);
@@ -2189,15 +2188,20 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
       if (do_range_check &&
           strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0)
         {
-          tree t = build3 (COND_EXPR, void_type_node,
-			   build_binary_op (GE_EXPR, long_integer_type_node,
-					    convert (long_integer_type_node,
-						     conexpr), 
-					    malloc64low),
-			   build_call_raise (CE_Range_Check_Failed, Empty,
-					     N_Raise_Constraint_Error),
-			   NULL_TREE);
-	  add_stmt_with_node (t, gnat_formal);
+	  tree pointer64type =
+	     build_pointer_type_for_mode (void_type_node, DImode, false);
+	  tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr);
+	  tree malloc64low =
+	     build_int_cstu (long_integer_type_node, 0x80000000);
+
+	  add_stmt (build3 (COND_EXPR, void_type_node,
+			    build_binary_op (GE_EXPR, long_integer_type_node,
+					     convert (long_integer_type_node,
+						      addr64expr), 
+					     malloc64low),
+			    build_call_raise (CE_Range_Check_Failed, gnat_actual,
+					      N_Raise_Constraint_Error),
+			    NULL_TREE));
         }
       const_list = tree_cons (field, conexpr, const_list);
     }