[multiple changes]

2014-02-19  Robert Dewar  <dewar@adacore.com>

	* exp_util.adb: Update comments.

2014-02-19  Doug Rupp  <rupp@adacore.com>

	* bindgen.adb (Gen_Adainit) [VMS] New global Float_Format.
	* init.c (__gl_float_format): [VMS] New global.
	(__gnat_set_features): Call FP_CONTROL to set FPSR for the float
	representation in effect.

2014-02-19  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch6.adb Add with and use clause for Exp_Prag.
	(Expand_Contract_Cases): Relocated to Exp_Prag.
	* exp_ch6.ads (Expand_Contract_Cases): Relocated to Exp_Prag.
	* exp_prag.adb Add with and use clauses for Checks and Validsw.
	(Expand_Contract_Cases): Relocated from Exp_Ch6. Update the
	structure of the expanded code to showcase the evaluation of
	attribute 'Old prefixes. Add local variable Old_Evals. Expand
	any attribute 'Old references found within a consequence. Add
	circuitry to evaluate the prefixes of attribute 'Old that
	belong to a selected consequence.
	(Expand_Old_In_Consequence): New routine.
	* exp_prag.ads (Expand_Contract_Cases): Relocated from Exp_Ch6.
	* sem_attr.adb (Check_Use_In_Contract_Cases): Warn that a
	potentially unevaluated prefix is always evaluated.

From-SVN: r207891

1 files changed, 37 insertions, 1 deletions

diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index e943837..d61086e 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -1508,6 +1508,14 @@ __gnat_set_stack_limit (void)
 #endif
 }
 
+#ifdef IN_RTS
+extern int SYS$IEEE_SET_FP_CONTROL (void *, void *, void *);
+#define K_TRUE 1
+#define __int64 long long
+#define __NEW_STARLET
+#include <vms/ieeedef.h>
+#endif
+
 /* Feature logical name and global variable address pair.
    If we ever add another feature logical to this list, the
    feature struct will need to be enhanced to take into account
@@ -1517,9 +1525,21 @@ struct feature {
   int *gl_addr;
 };
 
-/* Default values for GNAT features set by environment.  */
+/* Default values for GNAT features set by environment or binder.  */
 int __gl_heap_size = 64;
 
+/* Default float format is 'I' meaning IEEE.  If gnatbind detetcts that a
+   VAX Float format is specified, it will set this global variable to 'V'.
+   Subsequently __gnat_set_features will test the variable and if set for
+   VAX Float will call a Starlet function to enable trapping for invalid
+   operation, drivide by zero, and overflow. This will prevent the VMS runtime
+   (specifically OTS$CHECK_FP_MODE) from complaining about inconsistent
+   floating point settings in a mixed language program. Ideally the setting
+   would be determined at link time based on setttings in the object files,
+   however the VMS linker seems to take the setting from the first object
+   in the link, e.g. pcrt0.o which is float representation neutral.  */
+char __gl_float_format = 'I';
+
 /* Array feature logical names and global variable addresses.  */
 static const struct feature features[] =
 {
@@ -1532,6 +1552,12 @@ __gnat_set_features (void)
 {
   int i;
   char buff[16];
+#ifdef IN_RTS
+  IEEE clrmsk, setmsk, prvmsk;
+
+  clrmsk.ieee$q_flags = 0LL;
+  setmsk.ieee$q_flags = 0LL;
+#endif
 
   /* Loop through features array and test name for enable/disable.  */
   for (i = 0; features[i].name; i++)
@@ -1551,6 +1577,16 @@ __gnat_set_features (void)
   /* Features to artificially limit the stack size.  */
   __gnat_set_stack_limit ();
 
+#ifdef IN_RTS
+  if (__gl_float_format == 'V')
+    {
+      setmsk.ieee$v_trap_enable_inv = K_TRUE;
+      setmsk.ieee$v_trap_enable_dze = K_TRUE;
+      setmsk.ieee$v_trap_enable_ovf = K_TRUE;
+      SYS$IEEE_SET_FP_CONTROL (&clrmsk, &setmsk, &prvmsk);
+    }
+#endif
+
   __gnat_features_set = 1;
 }