From 8b91af8d3c88be2e7f1b4820d3bfeb9bcec907ac Mon Sep 17 00:00:00 2001 From: Doug Rupp Date: Fri, 22 Aug 2008 15:24:49 +0200 Subject: bindgen.adb [VMS] (Gen_Adainit_Ada, [...]): Import and call __gnat_set_features. 2008-08-22 Doug Rupp * 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 | 45 +++++++++++++++++++++++++++-- gcc/ada/init.c | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 124 insertions(+), 3 deletions(-) diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index ccdf394..7f3f627 100644 --- a/gcc/ada/bindgen.adb +++ b/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 diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 7965593..c4e2601 100644 --- a/gcc/ada/init.c +++ b/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 *** -- cgit v1.1