bindgen.adb [VMS] (Gen_Adainit_Ada, [...]): Import and call __gnat_set_features.

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

	* bindgen.adb [VMS] (Gen_Adainit_Ada, Gen_Adainit_C): Import and call
	__gnat_set_features.

	* init.c
	(__gnat_set_features): New function.
	(__gnat_features_set): New tracking variable.
	(__gl_no_malloc_64): New feature global variable

From-SVN: r139456

gcc/ada/bindgen.adb

@@ -604,6 +604,20 @@ package body Bindgen is
          WBI ("      pragma Import (C, Handler_Installed, " &
               """__gnat_handler_installed"");");
 
+         --  Import entry point for environment feature enable/disable
+         --  routine, and indication that it's been called previously.
+
+         if OpenVMS_On_Target then
+            WBI ("");
+            WBI ("      procedure Set_Features;");
+            WBI ("      pragma Import (C, Set_Features, " &
+                 """__gnat_set_features"");");
+            WBI ("");
+            WBI ("      Features_Set : Integer;");
+            WBI ("      pragma Import (C, Features_Set, " &
+                 """__gnat_features_set"");");
+         end if;
+
          --  Initialize stack limit variable of the environment task if the
          --  stack check method is stack limit and stack check is enabled.
 
@@ -765,6 +779,15 @@ package body Bindgen is
          WBI ("      if Handler_Installed = 0 then");
          WBI ("         Install_Handler;");
          WBI ("      end if;");
+
+         --  Generate call to Set_Features
+
+         if OpenVMS_On_Target then
+            WBI ("");
+            WBI ("      if Features_Set = 0 then");
+            WBI ("         Set_Features;");
+            WBI ("      end if;");
+         end if;
       end if;
 
       --  Generate call to set Initialize_Scalar values if active
@@ -1048,6 +1071,15 @@ package body Bindgen is
          WBI ("     {");
          WBI ("        __gnat_install_handler ();");
          WBI ("     }");
+
+         --  Call feature enable/disable routine
+
+         if OpenVMS_On_Target then
+            WBI ("   if (__gnat_features_set == 0)");
+            WBI ("     {");
+            WBI ("        __gnat_set_features ();");
+            WBI ("     }");
+         end if;
       end if;
 
       --  Initialize stack limit for the environment task if the stack
@@ -2599,12 +2631,21 @@ package body Bindgen is
 
       Gen_Elab_Defs_C;
 
-      --  Imported variable used to track elaboration/finalization phase.
-      --  Used only when we have a runtime.
+      --  Imported variables used only when we have a runtime.
 
       if not Suppress_Standard_Library_On_Target then
+
+         --  Track elaboration/finalization phase.
+
          WBI ("extern int  __gnat_handler_installed;");
          WBI ("");
+
+         --  Track feature enable/disable on VMS.
+
+         if OpenVMS_On_Target then
+            WBI ("extern int  __gnat_features_set;");
+            WBI ("");
+         end if;
       end if;
 
       --  Write argv/argc exit status stuff if main program case

gcc/ada/init.c

@@ -291,6 +291,30 @@ extern char *__gnat_get_code_loc (struct sigcontext *);
 extern void __gnat_set_code_loc (struct sigcontext *, char *);
 extern size_t __gnat_machine_state_length (void);
 
+/* __gnat_adjust_context_for_raise - see comments along with the default
+   version later in this file.  */
+
+#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
+
+void
+__gnat_adjust_context_for_raise (int signo, void *context)
+{
+  struct sigcontext * sigcontext = (struct sigcontext *) context;
+
+  /* The fallback code fetches the faulting insn address from sc_pc, so
+     adjust that when need be.  For SIGFPE, the required adjustment depends
+     on the trap shadow situation (see man ieee).  */
+  if (signo == SIGFPE)
+    {
+      /* ??? We never adjust here, considering that sc_pc always
+	 designates the instruction following the one which trapped.
+	 This is not necessarily true but corresponds to what we have
+	 always observed.  */
+    }
+  else
+    sigcontext->sc_pc ++;
+}
+
 static void
 __gnat_error_handler
   (int sig, siginfo_t *sip, struct sigcontext *context)
@@ -299,6 +323,10 @@ __gnat_error_handler
   static int recurse = 0;
   const char *msg;
 
+  /* Adjusting is required for every fault context, so adjust for this one
+     now, before we possibly trigger a recursive fault below.  */
+  __gnat_adjust_context_for_raise (sig, context);
+
   /* If this was an explicit signal from a "kill", just resignal it.  */
   if (SI_FROMUSER (sip))
     {
@@ -1078,6 +1106,10 @@ __gnat_install_handler (void)
 
 #elif defined (VMS)
 
+/* Routine called from binder to override default feature values. */
+void __gnat_set_features ();
+int __gnat_features_set = 0;
+
 long __gnat_error_handler (int *, void *);
 
 #ifdef __IA64
@@ -1591,6 +1623,54 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
 
 #endif
 
+/* Feature logical name and global variable address pair */
+struct feature {char *name; int* gl_addr;};
+
+/* Default values for GNAT features set by environment. */
+int __gl_no_malloc_64 = 0;
+
+/* Array feature logical names and global variable addresses */
+static struct feature features[] = {
+  {"GNAT$NO_MALLOC_64", &__gl_no_malloc_64},
+  {0, 0}
+};
+
+void __gnat_set_features ()
+{
+  struct descriptor_s name_desc, result_desc;
+  int i, status;
+  unsigned short rlen;
+
+#define MAXEQUIV 10
+  char buff [MAXEQUIV];
+
+  /* Loop through features array and test name for enable/disable */
+  for (i=0; features [i].name; i++)
+    {
+       name_desc.len = strlen (features [i].name);
+       name_desc.mbz = 0;
+       name_desc.adr = features [i].name;
+
+       result_desc.len = MAXEQUIV - 1;
+       result_desc.mbz = 0;
+       result_desc.adr = buff;
+
+       status = LIB$GET_LOGICAL (&name_desc, &result_desc, &rlen);
+
+       if (((status & 1) == 1) && (rlen < MAXEQUIV))
+         buff [rlen] = 0;
+       else
+         strcpy (buff, "");
+
+       if (strcmp (buff, "ENABLE") == 0)
+          *features [i].gl_addr = 1;
+       else if (strcmp (buff, "DISABLE") == 0)
+          *features [i].gl_addr = 0;
+    }
+
+    __gnat_features_set = 1;
+}
+
 /*******************/
 /* FreeBSD Section */
 /*******************/
@@ -2076,7 +2156,7 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED,
 {
   /* We used to compensate here for the raised from call vs raised from signal
      exception discrepancy with the GCC ZCX scheme, but this is now dealt with
-     generically (except for the IA-64), see GCC PR other/26208.
+     generically (except for the Alpha and IA-64), see GCC PR other/26208.
 
      *** Call vs signal exception discrepancy with GCC ZCX scheme ***