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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 909e815..beef1a4 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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,
 \f
 /* 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);
     }