gcc/ada/init.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                 I N I T                                  *
   6  *                                                                          *
   7  *                          C Implementation File                           *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2005, Free Software Foundation, Inc.         *
  10  *                                                                          *
  11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  12  * terms of the  GNU General Public License as published  by the Free Soft- *
  13  * ware  Foundation;  either version 2,  or (at your option) any later ver- *
  14  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  15  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  16  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  17  * for  more details.  You should have  received  a copy of the GNU General *
  18  * Public License  distributed with GNAT;  see file COPYING.  If not, write *
  19  * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
  20  * MA 02111-1307, USA.                                                      *
  21  *                                                                          *
  22  * As a  special  exception,  if you  link  this file  with other  files to *
  23  * produce an executable,  this file does not by itself cause the resulting *
  24  * executable to be covered by the GNU General Public License. This except- *
  25  * ion does not  however invalidate  any other reasons  why the  executable *
  26  * file might be covered by the  GNU Public License.                        *
  27  *                                                                          *
  28  * GNAT was originally developed  by the GNAT team at  New York University. *
  29  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  30  *                                                                          *
  31  ****************************************************************************/
  32
  33 /*  This unit contains initialization circuits that are system dependent. A
  34     major part of the functionality involved involves stack overflow checking.
  35     The GCC backend generates probe instructions to test for stack overflow.
  36     For details on the exact approach used to generate these probes, see the
  37     "Using and Porting GCC" manual, in particular the "Stack Checking" section
  38     and the subsection "Specifying How Stack Checking is Done". The handlers
  39     installed by this file are used to handle resulting signals that come
  40     from these probes failing (i.e. touching protected pages) */
  41
  42 /* This file should be kept synchronized with 2sinit.ads, 2sinit.adb, and
  43    5zinit.adb. All these files implement the required functionality for
  44    different targets. */
  45
  46 /* The following include is here to meet the published VxWorks requirement
  47    that the __vxworks header appear before any other include. */
  48 #ifdef __vxworks
  49 #include "vxWorks.h"
  50 #endif
  51
  52 #ifdef IN_RTS
  53 #include "tconfig.h"
  54 #include "tsystem.h"
  55 #include <sys/stat.h>
  56
  57 /* We don't have libiberty, so us malloc.  */
  58 #define xmalloc(S) malloc (S)
  59 #else
  60 #include "config.h"
  61 #include "system.h"
  62 #endif
  63
  64 #include "adaint.h"
  65 #include "raise.h"
  66
  67 extern void __gnat_raise_program_error (const char *, int);
  68
  69 /* Addresses of exception data blocks for predefined exceptions. */
  70 extern struct Exception_Data constraint_error;
  71 extern struct Exception_Data numeric_error;
  72 extern struct Exception_Data program_error;
  73 extern struct Exception_Data storage_error;
  74 extern struct Exception_Data tasking_error;
  75 extern struct Exception_Data _abort_signal;
  76
  77 #define Lock_Task system__soft_links__lock_task
  78 extern void (*Lock_Task) (void);
  79
  80 #define Unlock_Task system__soft_links__unlock_task
  81 extern void (*Unlock_Task) (void);
  82
  83 #define Get_Machine_State_Addr \
  84                       system__soft_links__get_machine_state_addr
  85 extern struct Machine_State *(*Get_Machine_State_Addr) (void);
  86
  87 #define Check_Abort_Status     \
  88                       system__soft_links__check_abort_status
  89 extern int (*Check_Abort_Status) (void);
  90
  91 #define Raise_From_Signal_Handler \
  92                       ada__exceptions__raise_from_signal_handler
  93 extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
  94
  95 #define Propagate_Signal_Exception \
  96                       __gnat_propagate_sig_exc
  97 extern void Propagate_Signal_Exception (struct Machine_State *,
  98                                         struct Exception_Data *,
  99                                         const char *);
 100
 101 /* Copies of global values computed by the binder */
 102 int   __gl_main_priority            = -1;
 103 int   __gl_time_slice_val           = -1;
 104 char  __gl_wc_encoding              = 'n';
 105 char  __gl_locking_policy           = ' ';
 106 char  __gl_queuing_policy           = ' ';
 107 char  __gl_task_dispatching_policy  = ' ';
 108 char *__gl_restrictions             = 0;
 109 char *__gl_interrupt_states         = 0;
 110 int   __gl_num_interrupt_states     = 0;
 111 int   __gl_unreserve_all_interrupts = 0;
 112 int   __gl_exception_tracebacks     = 0;
 113 int   __gl_zero_cost_exceptions     = 0;
 114 int   __gl_detect_blocking          = 0;
 115
 116 /* Indication of whether synchronous signal handler has already been
 117    installed by a previous call to adainit */
 118 int  __gnat_handler_installed      = 0;
 119
 120 /* HAVE_GNAT_INIT_FLOAT must be set on every targets where a __gnat_init_float
 121    is defined. If this is not set them a void implementation will be defined
 122    at the end of this unit. */
 123 #undef HAVE_GNAT_INIT_FLOAT
 124
 125 /******************************/
 126 /* __gnat_get_interrupt_state */
 127 /******************************/
 128
 129 char __gnat_get_interrupt_state (int);
 130
 131 /* This routine is called from the runtime as needed to determine the state
 132    of an interrupt, as set by an Interrupt_State pragma appearing anywhere
 133    in the current partition. The input argument is the interrupt number,
 134    and the result is one of the following:
 135
 136        'n'   this interrupt not set by any Interrupt_State pragma
 137        'u'   Interrupt_State pragma set state to User
 138        'r'   Interrupt_State pragma set state to Runtime
 139        's'   Interrupt_State pragma set state to System */
 140
 141 char
 142 __gnat_get_interrupt_state (int intrup)
 143 {
 144   if (intrup >= __gl_num_interrupt_states)
 145     return 'n';
 146   else
 147     return __gl_interrupt_states [intrup];
 148 }
 149
 150 /**********************/
 151 /* __gnat_set_globals */
 152 /**********************/
 153
 154 /* This routine is called from the binder generated main program.  It copies
 155    the values for global quantities computed by the binder into the following
 156    global locations. The reason that we go through this copy, rather than just
 157    define the global locations in the binder generated file, is that they are
 158    referenced from the runtime, which may be in a shared library, and the
 159    binder file is not in the shared library. Global references across library
 160    boundaries like this are not handled correctly in all systems.  */
 161
 162 /* For detailed description of the parameters to this routine, see the
 163    section titled Run-Time Globals in package Bindgen (bindgen.adb) */
 164
 165 void
 166 __gnat_set_globals (int main_priority,
 167                     int time_slice_val,
 168                     char wc_encoding,
 169                     char locking_policy,
 170                     char queuing_policy,
 171                     char task_dispatching_policy,
 172                     char *restrictions,
 173                     char *interrupt_states,
 174                     int num_interrupt_states,
 175                     int unreserve_all_interrupts,
 176                     int exception_tracebacks,
 177                     int zero_cost_exceptions,
 178                     int detect_blocking)
 179 {
 180   static int already_called = 0;
 181
 182   /* If this procedure has been already called once, check that the
 183      arguments in this call are consistent with the ones in the previous
 184      calls. Otherwise, raise a Program_Error exception.
 185
 186      We do not check for consistency of the wide character encoding
 187      method. This default affects only Wide_Text_IO where no explicit
 188      coding method is given, and there is no particular reason to let
 189      this default be affected by the source representation of a library
 190      in any case.
 191
 192      We do not check either for the consistency of exception tracebacks,
 193      because exception tracebacks are not normally set in Stand-Alone
 194      libraries. If a library or the main program set the exception
 195      tracebacks, then they are never reset afterwards (see below).
 196
 197      The value of main_priority is meaningful only when we are invoked
 198      from the main program elaboration routine of an Ada application.
 199      Checking the consistency of this parameter should therefore not be
 200      done. Since it is assured that the main program elaboration will
 201      always invoke this procedure before any library elaboration
 202      routine, only the value of main_priority during the first call
 203      should be taken into account and all the subsequent ones should be
 204      ignored. Note that the case where the main program is not written
 205      in Ada is also properly handled, since the default value will then
 206      be used for this parameter.
 207
 208      For identical reasons, the consistency of time_slice_val should not
 209      be checked. */
 210
 211   if (already_called)
 212     {
 213       if (__gl_locking_policy              != locking_policy
 214           || __gl_queuing_policy           != queuing_policy
 215           || __gl_task_dispatching_policy  != task_dispatching_policy
 216           || __gl_unreserve_all_interrupts != unreserve_all_interrupts
 217           || __gl_zero_cost_exceptions     != zero_cost_exceptions)
 218         __gnat_raise_program_error (__FILE__, __LINE__);
 219
 220       /* If either a library or the main program set the exception traceback
 221          flag, it is never reset later */
 222
 223       if (exception_tracebacks != 0)
 224          __gl_exception_tracebacks = exception_tracebacks;
 225
 226       return;
 227     }
 228   already_called = 1;
 229
 230   __gl_main_priority            = main_priority;
 231   __gl_time_slice_val           = time_slice_val;
 232   __gl_wc_encoding              = wc_encoding;
 233   __gl_locking_policy           = locking_policy;
 234   __gl_queuing_policy           = queuing_policy;
 235   __gl_restrictions             = restrictions;
 236   __gl_interrupt_states         = interrupt_states;
 237   __gl_num_interrupt_states     = num_interrupt_states;
 238   __gl_task_dispatching_policy  = task_dispatching_policy;
 239   __gl_unreserve_all_interrupts = unreserve_all_interrupts;
 240   __gl_exception_tracebacks     = exception_tracebacks;
 241   __gl_detect_blocking          = detect_blocking;
 242
 243   /* ??? __gl_zero_cost_exceptions is new in 3.15 and is referenced from
 244      a-except.adb, which is also part of the compiler sources. Since the
 245      compiler is built with an older release of GNAT, the call generated by
 246      the old binder to this function does not provide any value for the
 247      corresponding argument, so the global has to be initialized in some
 248      reasonable other way. This could be removed as soon as the next major
 249      release is out.  */
 250
 251 #ifdef IN_RTS
 252   __gl_zero_cost_exceptions = zero_cost_exceptions;
 253 #else
 254   __gl_zero_cost_exceptions = 0;
 255   /* We never build the compiler to run in ZCX mode currently anyway.  */
 256 #endif
 257 }
 258
 259 /*********************/
 260 /* __gnat_initialize */
 261 /*********************/
 262
 263 /* __gnat_initialize is called at the start of execution of an Ada program
 264    (the call is generated by the binder). The standard routine does nothing
 265    at all; the intention is that this be replaced by system specific
 266    code where initialization is required. */
 267
 268 /* Notes on the Zero Cost Exceptions scheme and its impact on the signal
 269    handlers implemented below :
 270
 271    What we call Zero Cost Exceptions is implemented using the GCC eh
 272    circuitry, even if the underlying implementation is setjmp/longjmp
 273    based. In any case ...
 274
 275    The GCC unwinder expects to be dealing with call return addresses, since
 276    this is the "nominal" case of what we retrieve while unwinding a regular
 277    call chain. To evaluate if a handler applies at some point in this chain,
 278    the propagation engine needs to determine what region the corresponding
 279    call instruction pertains to. The return address may not be attached to the
 280    same region as the call, so the unwinder unconditionally subtracts "some"
 281    amount to the return addresses it gets to search the region tables. The
 282    exact amount is computed to ensure that the resulting address is inside the
 283    call instruction, and is thus target dependent (think about delay slots for
 284    instance).
 285
 286    When we raise an exception from a signal handler, e.g. to transform a
 287    SIGSEGV into Storage_Error, things need to appear as if the signal handler
 288    had been "called" by the instruction which triggered the signal, so that
 289    exception handlers that apply there are considered. What the unwinder will
 290    retrieve as the return address from the signal handler is what it will find
 291    as the faulting instruction address in the corresponding signal context
 292    pushed by the kernel. Leaving this address untouched may loose, because if
 293    the triggering instruction happens to be the very first of a region, the
 294    later adjustments performed by the unwinder would yield an address outside
 295    that region. We need to compensate for those adjustments at some point,
 296    which we currently do in the GCC unwinding fallback macro.
 297
 298    The thread at http://gcc.gnu.org/ml/gcc-patches/2004-05/msg00343.html
 299    describes a couple of issues with our current approach. Basically: on some
 300    targets the adjustment to apply depends on the triggering signal, which is
 301    not easily accessible from the macro, and we actually do not tackle this as
 302    of today. Besides, other languages, e.g. Java, deal with this by performing
 303    the adjustment in the signal handler before the raise, so our adjustments
 304    may break those front-ends.
 305
 306    To have it all right, we should either find a way to deal with the signal
 307    variants from the macro and convert Java on all targets (ugh), or remove
 308    our macro adjustments and update our signal handlers a-la-java way.  The
 309    latter option appears the simplest, although some targets have their share
 310    of subtleties to account for.  See for instance the syscall(SYS_sigaction)
 311    story in libjava/include/i386-signal.h.  */
 312
 313 /***********************************/
 314 /* __gnat_initialize (AIX Version) */
 315 /***********************************/
 316
 317 #if defined (_AIX)
 318
 319 #include <signal.h>
 320 #include <sys/time.h>
 321
 322 /* Some versions of AIX don't define SA_NODEFER. */
 323
 324 #ifndef SA_NODEFER
 325 #define SA_NODEFER 0
 326 #endif /* SA_NODEFER */
 327
 328 /* Versions of AIX before 4.3 don't have nanosleep but provide
 329    nsleep instead. */
 330
 331 #ifndef _AIXVERSION_430
 332
 333 extern int nanosleep (struct timestruc_t *, struct timestruc_t *);
 334
 335 int
 336 nanosleep (struct timestruc_t *Rqtp, struct timestruc_t *Rmtp)
 337 {
 338   return nsleep (Rqtp, Rmtp);
 339 }
 340
 341 #endif /* _AIXVERSION_430 */
 342
 343 static void __gnat_error_handler (int);
 344
 345 static void
 346 __gnat_error_handler (int sig)
 347 {
 348   struct Exception_Data *exception;
 349   const char *msg;
 350
 351   switch (sig)
 352     {
 353     case SIGSEGV:
 354       /* FIXME: we need to detect the case of a *real* SIGSEGV */
 355       exception = &storage_error;
 356       msg = "stack overflow or erroneous memory access";
 357       break;
 358
 359     case SIGBUS:
 360       exception = &constraint_error;
 361       msg = "SIGBUS";
 362       break;
 363
 364     case SIGFPE:
 365       exception = &constraint_error;
 366       msg = "SIGFPE";
 367       break;
 368
 369     default:
 370       exception = &program_error;
 371       msg = "unhandled signal";
 372     }
 373
 374   Raise_From_Signal_Handler (exception, msg);
 375 }
 376
 377 void
 378 __gnat_install_handler (void)
 379 {
 380   struct sigaction act;
 381
 382   /* Set up signal handler to map synchronous signals to appropriate
 383      exceptions.  Make sure that the handler isn't interrupted by another
 384      signal that might cause a scheduling event! */
 385
 386   act.sa_handler = __gnat_error_handler;
 387   act.sa_flags = SA_NODEFER | SA_RESTART;
 388   sigemptyset (&act.sa_mask);
 389
 390   /* Do not install handlers if interrupt state is "System" */
 391   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 392     sigaction (SIGABRT, &act, NULL);
 393   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 394     sigaction (SIGFPE,  &act, NULL);
 395   if (__gnat_get_interrupt_state (SIGILL) != 's')
 396     sigaction (SIGILL,  &act, NULL);
 397   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 398     sigaction (SIGSEGV, &act, NULL);
 399   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 400     sigaction (SIGBUS,  &act, NULL);
 401
 402   __gnat_handler_installed = 1;
 403 }
 404
 405 void
 406 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 407 {
 408 }
 409
 410 /***************************************/
 411 /* __gnat_initialize (RTEMS version) */
 412 /***************************************/
 413
 414 #elif defined(__rtems__)
 415
 416 extern void __gnat_install_handler (void);
 417
 418 /* For RTEMS, each bsp will provide a custom __gnat_install_handler (). */
 419
 420 void
 421 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 422 {
 423    __gnat_install_handler ();
 424 }
 425
 426 /****************************************/
 427 /* __gnat_initialize (Dec Unix Version) */
 428 /****************************************/
 429
 430 #elif defined(__alpha__) && defined(__osf__) && ! defined(__alpha_vxworks)
 431
 432 /* Note: it seems that __osf__ is defined for the Alpha VXWorks case. Not
 433    clear that this is reasonable, but in any case we have to be sure to
 434    exclude this case in the above test.  */
 435
 436 #include <signal.h>
 437 #include <sys/siginfo.h>
 438
 439 static void __gnat_error_handler (int, siginfo_t *, struct sigcontext *);
 440 extern char *__gnat_get_code_loc (struct sigcontext *);
 441 extern void __gnat_enter_handler (struct sigcontext *, char *);
 442 extern size_t __gnat_machine_state_length (void);
 443
 444 extern long exc_lookup_gp (char *);
 445 extern void exc_resume (struct sigcontext *);
 446
 447 static void
 448 __gnat_error_handler (int sig, siginfo_t *sip, struct sigcontext *context)
 449 {
 450   struct Exception_Data *exception;
 451   static int recurse = 0;
 452   struct sigcontext *mstate;
 453   const char *msg;
 454
 455   /* If this was an explicit signal from a "kill", just resignal it.  */
 456   if (SI_FROMUSER (sip))
 457     {
 458       signal (sig, SIG_DFL);
 459       kill (getpid(), sig);
 460     }
 461
 462   /* Otherwise, treat it as something we handle.  */
 463   switch (sig)
 464     {
 465     case SIGSEGV:
 466       /* If the problem was permissions, this is a constraint error.
 467          Likewise if the failing address isn't maximally aligned or if
 468          we've recursed.
 469
 470          ??? Using a static variable here isn't task-safe, but it's
 471          much too hard to do anything else and we're just determining
 472          which exception to raise.  */
 473       if (sip->si_code == SEGV_ACCERR
 474           || (((long) sip->si_addr) & 3) != 0
 475           || recurse)
 476         {
 477           exception = &constraint_error;
 478           msg = "SIGSEGV";
 479         }
 480       else
 481         {
 482           /* See if the page before the faulting page is accessible.  Do that
 483              by trying to access it.  We'd like to simply try to access
 484              4096 + the faulting address, but it's not guaranteed to be
 485              the actual address, just to be on the same page.  */
 486           recurse++;
 487           ((volatile char *)
 488            ((long) sip->si_addr & - getpagesize ()))[getpagesize ()];
 489           msg = "stack overflow (or erroneous memory access)";
 490           exception = &storage_error;
 491         }
 492       break;
 493
 494     case SIGBUS:
 495       exception = &program_error;
 496       msg = "SIGBUS";
 497       break;
 498
 499     case SIGFPE:
 500       exception = &constraint_error;
 501       msg = "SIGFPE";
 502       break;
 503
 504     default:
 505       exception = &program_error;
 506       msg = "unhandled signal";
 507     }
 508
 509   recurse = 0;
 510   mstate = (struct sigcontext *) (*Get_Machine_State_Addr) ();
 511   if (mstate != 0)
 512     *mstate = *context;
 513
 514   Raise_From_Signal_Handler (exception, (char *) msg);
 515 }
 516
 517 void
 518 __gnat_install_handler (void)
 519 {
 520   struct sigaction act;
 521
 522   /* Setup signal handler to map synchronous signals to appropriate
 523      exceptions. Make sure that the handler isn't interrupted by another
 524      signal that might cause a scheduling event! */
 525
 526   act.sa_handler = (void (*) (int)) __gnat_error_handler;
 527   act.sa_flags = SA_RESTART | SA_NODEFER | SA_SIGINFO;
 528   sigemptyset (&act.sa_mask);
 529
 530   /* Do not install handlers if interrupt state is "System" */
 531   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 532     sigaction (SIGABRT, &act, NULL);
 533   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 534     sigaction (SIGFPE,  &act, NULL);
 535   if (__gnat_get_interrupt_state (SIGILL) != 's')
 536     sigaction (SIGILL,  &act, NULL);
 537   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 538     sigaction (SIGSEGV, &act, NULL);
 539   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 540     sigaction (SIGBUS,  &act, NULL);
 541
 542   __gnat_handler_installed = 1;
 543 }
 544
 545 void
 546 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 547 {
 548 }
 549
 550 /* Routines called by s-mastop-tru64.adb.  */
 551
 552 #define SC_GP 29
 553
 554 char *
 555 __gnat_get_code_loc (struct sigcontext *context)
 556 {
 557   return (char *) context->sc_pc;
 558 }
 559
 560 void
 561 __gnat_enter_handler (struct sigcontext *context, char *pc)
 562 {
 563   context->sc_pc = (long) pc;
 564   context->sc_regs[SC_GP] = exc_lookup_gp (pc);
 565   exc_resume (context);
 566 }
 567
 568 size_t
 569 __gnat_machine_state_length (void)
 570 {
 571   return sizeof (struct sigcontext);
 572 }
 573
 574 /************************************/
 575 /* __gnat_initialize (HPUX Version) */
 576 /************************************/
 577
 578 #elif defined (__hpux__)
 579
 580 #include <signal.h>
 581 #include <sys/ucontext.h>
 582
 583 static void
 584 __gnat_error_handler (int sig, siginfo_t *siginfo, void *ucontext);
 585
 586 /* __gnat_adjust_context_for_raise - see comments along with the default
 587    version later in this file.  */
 588
 589 #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
 590
 591 void
 592 __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
 593 {
 594   mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext;
 595
 596   if (UseWideRegs (mcontext))
 597     mcontext->ss_wide.ss_32.ss_pcoq_head_lo ++;
 598   else
 599     mcontext->ss_narrow.ss_pcoq_head ++;
 600 }
 601
 602 static void
 603 __gnat_error_handler (int sig, siginfo_t *siginfo, void *ucontext)
 604 {
 605   struct Exception_Data *exception;
 606   char *msg;
 607
 608   switch (sig)
 609     {
 610     case SIGSEGV:
 611       /* FIXME: we need to detect the case of a *real* SIGSEGV */
 612       exception = &storage_error;
 613       msg = "stack overflow or erroneous memory access";
 614       break;
 615
 616     case SIGBUS:
 617       exception = &constraint_error;
 618       msg = "SIGBUS";
 619       break;
 620
 621     case SIGFPE:
 622       exception = &constraint_error;
 623       msg = "SIGFPE";
 624       break;
 625
 626     default:
 627       exception = &program_error;
 628       msg = "unhandled signal";
 629     }
 630
 631   __gnat_adjust_context_for_raise (sig, ucontext);
 632
 633   Raise_From_Signal_Handler (exception, msg);
 634 }
 635
 636 void
 637 __gnat_install_handler (void)
 638 {
 639   struct sigaction act;
 640
 641   /* Set up signal handler to map synchronous signals to appropriate
 642      exceptions.  Make sure that the handler isn't interrupted by another
 643      signal that might cause a scheduling event! Also setup an alternate
 644      stack region for the handler execution so that stack overflows can be
 645      handled properly, avoiding a SEGV generation from stack usage by the
 646      handler itself. */
 647
 648   static char handler_stack[SIGSTKSZ*2];
 649   /* SIGSTKSZ appeared to be "short" for the needs in some contexts
 650      (e.g. experiments with GCC ZCX exceptions).  */
 651
 652   stack_t stack;
 653
 654   stack.ss_sp    = handler_stack;
 655   stack.ss_size  = sizeof (handler_stack);
 656   stack.ss_flags = 0;
 657
 658   sigaltstack (&stack, NULL);
 659
 660   act.sa_sigaction = __gnat_error_handler;
 661   act.sa_flags = SA_NODEFER | SA_RESTART | SA_ONSTACK | SA_SIGINFO;
 662   sigemptyset (&act.sa_mask);
 663
 664   /* Do not install handlers if interrupt state is "System" */
 665   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 666     sigaction (SIGABRT, &act, NULL);
 667   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 668     sigaction (SIGFPE,  &act, NULL);
 669   if (__gnat_get_interrupt_state (SIGILL) != 's')
 670     sigaction (SIGILL,  &act, NULL);
 671   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 672     sigaction (SIGSEGV, &act, NULL);
 673   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 674     sigaction (SIGBUS,  &act, NULL);
 675
 676   __gnat_handler_installed = 1;
 677 }
 678
 679 void
 680 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 681 {
 682 }
 683
 684 /*****************************************/
 685 /* __gnat_initialize (GNU/Linux Version) */
 686 /*****************************************/
 687
 688 #elif defined (linux) && defined (i386) && !defined (__RT__)
 689
 690 #include <signal.h>
 691 #include <asm/sigcontext.h>
 692
 693 /* GNU/Linux, which uses glibc, does not define NULL in included
 694    header files */
 695
 696 #if !defined (NULL)
 697 #define NULL ((void *) 0)
 698 #endif
 699
 700 struct Machine_State
 701 {
 702   unsigned long eip;
 703   unsigned long ebx;
 704   unsigned long esp;
 705   unsigned long ebp;
 706   unsigned long esi;
 707   unsigned long edi;
 708 };
 709
 710 static void __gnat_error_handler (int);
 711
 712 static void
 713 __gnat_error_handler (int sig)
 714 {
 715   struct Exception_Data *exception;
 716   const char *msg;
 717   static int recurse = 0;
 718
 719   struct sigcontext *info
 720     = (struct sigcontext *) (((char *) &sig) + sizeof (int));
 721
 722   /* The Linux kernel does not document how to get the machine state in a
 723      signal handler, but in fact the necessary data is in a sigcontext_struct
 724      value that is on the stack immediately above the signal number
 725      parameter, and the above messing accesses this value on the stack. */
 726
 727   struct Machine_State *mstate;
 728
 729   switch (sig)
 730     {
 731     case SIGSEGV:
 732       /* If the problem was permissions, this is a constraint error.
 733        Likewise if the failing address isn't maximally aligned or if
 734        we've recursed.
 735
 736        ??? Using a static variable here isn't task-safe, but it's
 737        much too hard to do anything else and we're just determining
 738        which exception to raise.  */
 739       if (recurse)
 740       {
 741         exception = &constraint_error;
 742         msg = "SIGSEGV";
 743       }
 744       else
 745       {
 746         /* Here we would like a discrimination test to see whether the
 747            page before the faulting address is accessible. Unfortunately
 748            Linux seems to have no way of giving us the faulting address.
 749
 750            In versions of a-init.c before 1.95, we had a test of the page
 751            before the stack pointer using:
 752
 753             recurse++;
 754              ((volatile char *)
 755               ((long) info->esp_at_signal & - getpagesize ()))[getpagesize ()];
 756
 757            but that's wrong, since it tests the stack pointer location, and
 758            the current stack probe code does not move the stack pointer
 759            until all probes succeed.
 760
 761            For now we simply do not attempt any discrimination at all. Note
 762            that this is quite acceptable, since a "real" SIGSEGV can only
 763            occur as the result of an erroneous program */
 764
 765         msg = "stack overflow (or erroneous memory access)";
 766         exception = &storage_error;
 767       }
 768       break;
 769
 770     case SIGBUS:
 771       exception = &constraint_error;
 772       msg = "SIGBUS";
 773       break;
 774
 775     case SIGFPE:
 776       exception = &constraint_error;
 777       msg = "SIGFPE";
 778       break;
 779
 780     default:
 781       exception = &program_error;
 782       msg = "unhandled signal";
 783     }
 784
 785   mstate = (*Get_Machine_State_Addr) ();
 786   if (mstate)
 787     {
 788       mstate->eip = info->eip;
 789       mstate->ebx = info->ebx;
 790       mstate->esp = info->esp_at_signal;
 791       mstate->ebp = info->ebp;
 792       mstate->esi = info->esi;
 793       mstate->edi = info->edi;
 794     }
 795
 796   recurse = 0;
 797   Raise_From_Signal_Handler (exception, msg);
 798 }
 799
 800 void
 801 __gnat_install_handler (void)
 802 {
 803   struct sigaction act;
 804
 805   /* Set up signal handler to map synchronous signals to appropriate
 806      exceptions.  Make sure that the handler isn't interrupted by another
 807      signal that might cause a scheduling event! */
 808
 809   act.sa_handler = __gnat_error_handler;
 810   act.sa_flags = SA_NODEFER | SA_RESTART;
 811   sigemptyset (&act.sa_mask);
 812
 813   /* Do not install handlers if interrupt state is "System" */
 814   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 815     sigaction (SIGABRT, &act, NULL);
 816   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 817     sigaction (SIGFPE,  &act, NULL);
 818   if (__gnat_get_interrupt_state (SIGILL) != 's')
 819     sigaction (SIGILL,  &act, NULL);
 820   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 821     sigaction (SIGSEGV, &act, NULL);
 822   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 823     sigaction (SIGBUS,  &act, NULL);
 824
 825   __gnat_handler_installed = 1;
 826 }
 827
 828 void
 829 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 830 {
 831 }
 832
 833 /******************************************/
 834 /* __gnat_initialize (NT-mingw32 Version) */
 835 /******************************************/
 836
 837 #elif defined (__MINGW32__)
 838 #include <windows.h>
 839
 840 void
 841 __gnat_install_handler (void)
 842 {
 843 }
 844
 845 void
 846 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 847 {
 848    /* Initialize floating-point coprocessor. This call is needed because
 849       the MS libraries default to 64-bit precision instead of 80-bit
 850       precision, and we require the full precision for proper operation,
 851       given that we have set Max_Digits etc with this in mind */
 852    __gnat_init_float ();
 853
 854    /* Initialize a lock for a process handle list - see a-adaint.c for the
 855       implementation of __gnat_portable_no_block_spawn, __gnat_portable_wait */
 856    __gnat_plist_init();
 857
 858    /* Note that we do not activate this for the compiler itself to avoid a
 859       bootstrap path problem.  Older version of gnatbind will generate a call
 860       to __gnat_initialize() without argument. Therefore we cannot use eh in
 861       this case.  It will be possible to remove the following #ifdef at some
 862       point.  */
 863 #ifdef IN_RTS
 864    /* Install the Structured Exception handler.  */
 865    if (eh)
 866      __gnat_install_SEH_handler (eh);
 867 #endif
 868 }
 869
 870 /***************************************/
 871 /* __gnat_initialize (Interix Version) */
 872 /***************************************/
 873
 874 #elif defined (__INTERIX)
 875
 876 #include <signal.h>
 877
 878 static void __gnat_error_handler (int);
 879
 880 static void
 881 __gnat_error_handler (int sig)
 882 {
 883   struct Exception_Data *exception;
 884   char *msg;
 885
 886   switch (sig)
 887     {
 888     case SIGSEGV:
 889       exception = &storage_error;
 890       msg = "stack overflow or erroneous memory access";
 891       break;
 892
 893     case SIGBUS:
 894       exception = &constraint_error;
 895       msg = "SIGBUS";
 896       break;
 897
 898     case SIGFPE:
 899       exception = &constraint_error;
 900       msg = "SIGFPE";
 901       break;
 902
 903     default:
 904       exception = &program_error;
 905       msg = "unhandled signal";
 906     }
 907
 908   Raise_From_Signal_Handler (exception, msg);
 909 }
 910
 911 void
 912 __gnat_install_handler (void)
 913 {
 914   struct sigaction act;
 915
 916   /* Set up signal handler to map synchronous signals to appropriate
 917      exceptions.  Make sure that the handler isn't interrupted by another
 918      signal that might cause a scheduling event! */
 919
 920   act.sa_handler = __gnat_error_handler;
 921   act.sa_flags = 0;
 922   sigemptyset (&act.sa_mask);
 923
 924   /* Handlers for signals besides SIGSEGV cause c974013 to hang */
 925 /*  sigaction (SIGILL,  &act, NULL); */
 926 /*  sigaction (SIGABRT, &act, NULL); */
 927 /*  sigaction (SIGFPE,  &act, NULL); */
 928 /*  sigaction (SIGBUS,  &act, NULL); */
 929
 930   /* Do not install handlers if interrupt state is "System" */
 931   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 932     sigaction (SIGSEGV, &act, NULL);
 933
 934   __gnat_handler_installed = 1;
 935 }
 936
 937 void
 938 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 939 {
 940    __gnat_init_float ();
 941 }
 942
 943 /**************************************/
 944 /* __gnat_initialize (LynxOS Version) */
 945 /**************************************/
 946
 947 #elif defined (__Lynx__)
 948
 949 void
 950 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 951 {
 952    __gnat_init_float ();
 953 }
 954
 955 /*********************************/
 956 /* __gnat_install_handler (Lynx) */
 957 /*********************************/
 958
 959 void
 960 __gnat_install_handler (void)
 961 {
 962   __gnat_handler_installed = 1;
 963 }
 964
 965 /****************************/
 966 /* __gnat_initialize (OS/2) */
 967 /****************************/
 968
 969 #elif defined (__EMX__) /* OS/2 dependent initialization */
 970
 971 void
 972 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
 973 {
 974 }
 975
 976 /*********************************/
 977 /* __gnat_install_handler (OS/2) */
 978 /*********************************/
 979
 980 void
 981 __gnat_install_handler (void)
 982 {
 983   __gnat_handler_installed = 1;
 984 }
 985
 986 /***********************************/
 987 /* __gnat_initialize (SGI Version) */
 988 /***********************************/
 989
 990 #elif defined (sgi)
 991
 992 #include <signal.h>
 993 #include <siginfo.h>
 994
 995 #ifndef NULL
 996 #define NULL 0
 997 #endif
 998
 999 #define SIGADAABORT 48
1000 #define SIGNAL_STACK_SIZE 4096
1001 #define SIGNAL_STACK_ALIGNMENT 64
1002
1003 struct Machine_State
1004 {
1005   sigcontext_t context;
1006 };
1007
1008 static void __gnat_error_handler (int, int, sigcontext_t *);
1009
1010 /* We are not setting the SA_SIGINFO bit in the sigaction flags when
1011    connecting that handler, with the effects described in the sigaction
1012    man page:
1013
1014           SA_SIGINFO [...]
1015           If cleared and the signal is caught, the first argument is
1016           also the signal number but the second argument is the signal
1017           code identifying the cause of the signal. The third argument
1018           points to a sigcontext_t structure containing the receiving
1019           process's context when the signal was delivered.
1020 */
1021
1022 static void
1023 __gnat_error_handler (int sig, int code, sigcontext_t *sc)
1024 {
1025   struct Machine_State  *mstate;
1026   struct Exception_Data *exception;
1027   const char *msg;
1028
1029   switch (sig)
1030     {
1031     case SIGSEGV:
1032       if (code == EFAULT)
1033         {
1034           exception = &program_error;
1035           msg = "SIGSEGV: (Invalid virtual address)";
1036         }
1037       else if (code == ENXIO)
1038         {
1039           exception = &program_error;
1040           msg = "SIGSEGV: (Read beyond mapped object)";
1041         }
1042       else if (code == ENOSPC)
1043         {
1044           exception = &program_error; /* ??? storage_error ??? */
1045           msg = "SIGSEGV: (Autogrow for file failed)";
1046         }
1047       else if (code == EACCES || code == EEXIST)
1048         {
1049           /* ??? We handle stack overflows here, some of which do trigger
1050                  SIGSEGV + EEXIST on Irix 6.5 although EEXIST is not part of
1051                  the documented valid codes for SEGV in the signal(5) man
1052                  page.  */
1053
1054           /* ??? Re-add smarts to further verify that we launched
1055                  the stack into a guard page, not an attempt to
1056                  write to .text or something */
1057           exception = &storage_error;
1058           msg = "SIGSEGV: (stack overflow or erroneous memory access)";
1059         }
1060       else
1061         {
1062           /* Just in case the OS guys did it to us again.  Sometimes
1063              they fail to document all of the valid codes that are
1064              passed to signal handlers, just in case someone depends
1065              on knowing all the codes */
1066           exception = &program_error;
1067           msg = "SIGSEGV: (Undocumented reason)";
1068         }
1069       break;
1070
1071     case SIGBUS:
1072       /* Map all bus errors to Program_Error.  */
1073       exception = &program_error;
1074       msg = "SIGBUS";
1075       break;
1076
1077     case SIGFPE:
1078       /* Map all fpe errors to Constraint_Error.  */
1079       exception = &constraint_error;
1080       msg = "SIGFPE";
1081       break;
1082
1083     case SIGADAABORT:
1084       if ((*Check_Abort_Status) ())
1085         {
1086           exception = &_abort_signal;
1087           msg = "";
1088         }
1089       else
1090         return;
1091
1092       break;
1093
1094     default:
1095       /* Everything else is a Program_Error. */
1096       exception = &program_error;
1097       msg = "unhandled signal";
1098     }
1099
1100   mstate = (*Get_Machine_State_Addr) ();
1101   if (mstate != 0)
1102     memcpy ((void *) mstate, (const void *) sc, sizeof (sigcontext_t));
1103
1104   Raise_From_Signal_Handler (exception, msg);
1105 }
1106
1107 void
1108 __gnat_install_handler (void)
1109 {
1110   struct sigaction act;
1111
1112   /* Setup signal handler to map synchronous signals to appropriate
1113      exceptions.  Make sure that the handler isn't interrupted by another
1114      signal that might cause a scheduling event! */
1115
1116   act.sa_handler = __gnat_error_handler;
1117   act.sa_flags = SA_NODEFER + SA_RESTART;
1118   sigfillset (&act.sa_mask);
1119   sigemptyset (&act.sa_mask);
1120
1121   /* Do not install handlers if interrupt state is "System" */
1122   if (__gnat_get_interrupt_state (SIGABRT) != 's')
1123     sigaction (SIGABRT, &act, NULL);
1124   if (__gnat_get_interrupt_state (SIGFPE) != 's')
1125     sigaction (SIGFPE,  &act, NULL);
1126   if (__gnat_get_interrupt_state (SIGILL) != 's')
1127     sigaction (SIGILL,  &act, NULL);
1128   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
1129     sigaction (SIGSEGV, &act, NULL);
1130   if (__gnat_get_interrupt_state (SIGBUS) != 's')
1131     sigaction (SIGBUS,  &act, NULL);
1132   if (__gnat_get_interrupt_state (SIGADAABORT) != 's')
1133     sigaction (SIGADAABORT,  &act, NULL);
1134
1135   __gnat_handler_installed = 1;
1136 }
1137
1138 void
1139 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
1140 {
1141 }
1142
1143 /*************************************************/
1144 /* __gnat_initialize (Solaris and SunOS Version) */
1145 /*************************************************/
1146
1147 #elif defined (sun) && defined (__SVR4) && !defined (__vxworks)
1148
1149 #include <signal.h>
1150 #include <siginfo.h>
1151
1152 static void __gnat_error_handler (int, siginfo_t *);
1153
1154 static void
1155 __gnat_error_handler (int sig, siginfo_t *sip)
1156 {
1157   struct Exception_Data *exception;
1158   static int recurse = 0;
1159   const char *msg;
1160
1161   /* If this was an explicit signal from a "kill", just resignal it.  */
1162   if (SI_FROMUSER (sip))
1163     {
1164       signal (sig, SIG_DFL);
1165       kill (getpid(), sig);
1166     }
1167
1168   /* Otherwise, treat it as something we handle.  */
1169   switch (sig)
1170     {
1171     case SIGSEGV:
1172       /* If the problem was permissions, this is a constraint error.
1173          Likewise if the failing address isn't maximally aligned or if
1174          we've recursed.
1175
1176          ??? Using a static variable here isn't task-safe, but it's
1177          much too hard to do anything else and we're just determining
1178          which exception to raise.  */
1179       if (sip->si_code == SEGV_ACCERR
1180           || (((long) sip->si_addr) & 3) != 0
1181           || recurse)
1182         {
1183           exception = &constraint_error;
1184           msg = "SIGSEGV";
1185         }
1186       else
1187         {
1188           /* See if the page before the faulting page is accessible.  Do that
1189              by trying to access it.  We'd like to simply try to access
1190              4096 + the faulting address, but it's not guaranteed to be
1191              the actual address, just to be on the same page.  */
1192           recurse++;
1193           ((volatile char *)
1194            ((long) sip->si_addr & - getpagesize ()))[getpagesize ()];
1195           exception = &storage_error;
1196           msg = "stack overflow (or erroneous memory access)";
1197         }
1198       break;
1199
1200     case SIGBUS:
1201       exception = &program_error;
1202       msg = "SIGBUS";
1203       break;
1204
1205     case SIGFPE:
1206       exception = &constraint_error;
1207       msg = "SIGFPE";
1208       break;
1209
1210     default:
1211       exception = &program_error;
1212       msg = "unhandled signal";
1213     }
1214
1215   recurse = 0;
1216
1217   Raise_From_Signal_Handler (exception, msg);
1218 }
1219
1220 void
1221 __gnat_install_handler (void)
1222 {
1223   struct sigaction act;
1224
1225   /* Set up signal handler to map synchronous signals to appropriate
1226      exceptions.  Make sure that the handler isn't interrupted by another
1227      signal that might cause a scheduling event! */
1228
1229   act.sa_handler = __gnat_error_handler;
1230   act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
1231   sigemptyset (&act.sa_mask);
1232
1233   /* Do not install handlers if interrupt state is "System" */
1234   if (__gnat_get_interrupt_state (SIGABRT) != 's')
1235     sigaction (SIGABRT, &act, NULL);
1236   if (__gnat_get_interrupt_state (SIGFPE) != 's')
1237     sigaction (SIGFPE,  &act, NULL);
1238   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
1239     sigaction (SIGSEGV, &act, NULL);
1240   if (__gnat_get_interrupt_state (SIGBUS) != 's')
1241     sigaction (SIGBUS,  &act, NULL);
1242
1243   __gnat_handler_installed = 1;
1244 }
1245
1246 void
1247 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
1248 {
1249 }
1250
1251 /***********************************/
1252 /* __gnat_initialize (VMS Version) */
1253 /***********************************/
1254
1255 #elif defined (VMS)
1256
1257 #ifdef __IA64
1258 #define lib_get_curr_invo_context LIB$I64_GET_CURR_INVO_CONTEXT
1259 #define lib_get_prev_invo_context LIB$I64_GET_PREV_INVO_CONTEXT
1260 #define lib_get_invo_handle LIB$I64_GET_INVO_HANDLE
1261 #else
1262 #define lib_get_curr_invo_context LIB$GET_CURR_INVO_CONTEXT
1263 #define lib_get_prev_invo_context LIB$GET_PREV_INVO_CONTEXT
1264 #define lib_get_invo_handle LIB$GET_INVO_HANDLE
1265 #endif
1266
1267 #if defined (IN_RTS) && !defined (__IA64)
1268
1269 /* The prehandler actually gets control first on a condition. It swaps the
1270    stack pointer and calls the handler (__gnat_error_handler). */
1271 extern long __gnat_error_prehandler (void);
1272
1273 extern char *__gnat_error_prehandler_stack;   /* Alternate signal stack */
1274 #endif
1275
1276 /* Conditions that don't have an Ada exception counterpart must raise
1277    Non_Ada_Error.  Since this is defined in s-auxdec, it should only be
1278    referenced by user programs, not the compiler or tools. Hence the
1279    #ifdef IN_RTS. */
1280
1281 #ifdef IN_RTS
1282 #define Non_Ada_Error system__aux_dec__non_ada_error
1283 extern struct Exception_Data Non_Ada_Error;
1284
1285 #define Coded_Exception system__vms_exception_table__coded_exception
1286 extern struct Exception_Data *Coded_Exception (Exception_Code);
1287
1288 #define Base_Code_In system__vms_exception_table__base_code_in
1289 extern Exception_Code Base_Code_In (Exception_Code);
1290 #endif
1291
1292 /* Define macro symbols for the VMS conditions that become Ada exceptions.
1293    Most of these are also defined in the header file ssdef.h which has not
1294    yet been converted to be recognized by Gnu C. Some, which couldn't be
1295    located, are assigned names based on the DEC test suite tests which
1296    raise them. */
1297
1298 #define SS$_ACCVIO            12
1299 #define SS$_DEBUG           1132
1300 #define SS$_INTDIV          1156
1301 #define SS$_HPARITH         1284
1302 #define SS$_STKOVF          1364
1303 #define SS$_RESIGNAL        2328
1304 #define MTH$_FLOOVEMAT   1475268       /* Some ACVC_21 CXA tests */
1305 #define SS$_CE24VRU      3253636       /* Write to unopened file */
1306 #define SS$_C980VTE      3246436       /* AST requests time slice */
1307 #define CMA$_EXIT_THREAD 4227492
1308 #define CMA$_EXCCOPLOS   4228108
1309 #define CMA$_ALERTED     4227460
1310
1311 struct descriptor_s {unsigned short len, mbz; char *adr; };
1312
1313 long __gnat_error_handler (int *, void *);
1314
1315 /* To deal with VMS conditions and their mapping to Ada exceptions,
1316    the __gnat_error_handler routine below is installed as an exception
1317    vector having precedence over DEC frame handlers.  Some conditions
1318    still need to be handled by such handlers, however, in which case
1319    __gnat_error_handler needs to return SS$_RESIGNAL.  Consider for
1320    instance the use of a third party library compiled with DECAda and
1321    performing its own exception handling internally.
1322
1323    To allow some user-level flexibility, which conditions should be
1324    resignaled is controlled by a predicate function, provided with the
1325    condition value and returning a boolean indication stating whether
1326    this condition should be resignaled or not.
1327
1328    That predicate function is called indirectly, via a function pointer,
1329    by __gnat_error_handler, and changing that pointer is allowed to the
1330    the user code by way of the __gnat_set_resignal_predicate interface.
1331
1332    The user level function may then implement what it likes, including
1333    for instance the maintenance of a dynamic data structure if the set
1334    of to be resignalled conditions has to change over the program's
1335    lifetime.
1336
1337    ??? This is not a perfect solution to deal with the possible
1338    interactions between the GNAT and the DECAda exception handling
1339    models and better (more general) schemes are studied.  This is so
1340    just provided as a convenient workaround in the meantime, and
1341    should be use with caution since the implementation has been kept
1342    very simple.  */
1343
1344 typedef int
1345 resignal_predicate (int code);
1346
1347 /* Default GNAT predicate for resignaling conditions.  */
1348
1349 static int
1350 __gnat_default_resignal_p (int code)
1351 {
1352   return
1353     code == CMA$_EXIT_THREAD
1354     || code == SS$_DEBUG /* Gdb attach, resignal to merge activate gdbstub. */
1355     || code == 1409786   /* Nickerson bug #33 ??? */
1356     || code == 1381050   /* Nickerson bug #33 ??? */
1357     || code == 20480426  /* RDB-E-STREAM_EOF */
1358     || code == 11829410  /* Resignalled as Use_Error for CE10VRC */
1359   ;
1360 }
1361
1362 /* Static pointer to predicate that the __gnat_error_handler exception
1363    vector invokes to determine if it should resignal a condition.  */
1364
1365 static resignal_predicate * __gnat_resignal_p = __gnat_default_resignal_p;
1366
1367 /* User interface to change the predicate pointer to PREDICATE. Reset to
1368    the default if PREDICATE is null.  */
1369
1370 void
1371 __gnat_set_resignal_predicate (resignal_predicate * predicate)
1372 {
1373   if (predicate == 0)
1374     __gnat_resignal_p = __gnat_default_resignal_p;
1375   else
1376     __gnat_resignal_p = predicate;
1377 }
1378
1379 long
1380 __gnat_error_handler (int *sigargs, void *mechargs)
1381 {
1382   struct Exception_Data *exception = 0;
1383   Exception_Code base_code;
1384
1385   char *msg = "";
1386   char message[256];
1387   long prvhnd;
1388   struct descriptor_s msgdesc;
1389   int msg_flag = 0x000f; /* 1 bit for each of the four message parts */
1390   unsigned short outlen;
1391   char curr_icb[544];
1392   long curr_invo_handle;
1393   long *mstate;
1394
1395   /* Check for conditions to resignal which aren't effected by pragma
1396      Import_Exception.  */
1397   if (__gnat_resignal_p (sigargs [1]))
1398     return SS$_RESIGNAL;
1399
1400 #ifdef IN_RTS
1401   /* See if it's an imported exception. Beware that registered exceptions
1402      are bound to their base code, with the severity bits masked off.  */
1403   base_code = Base_Code_In ((Exception_Code) sigargs [1]);
1404   exception = Coded_Exception (base_code);
1405
1406   if (exception)
1407     {
1408       msgdesc.len = 256;
1409       msgdesc.mbz = 0;
1410       msgdesc.adr = message;
1411       SYS$GETMSG (sigargs[1], &outlen, &msgdesc, msg_flag, 0);
1412       message[outlen] = 0;
1413       msg = message;
1414
1415       exception->Name_Length = 19;
1416       /* The full name really should be get sys$getmsg returns. ??? */
1417       exception->Full_Name = "IMPORTED_EXCEPTION";
1418       exception->Import_Code = base_code;
1419     }
1420 #endif
1421
1422   if (exception == 0)
1423     switch (sigargs[1])
1424       {
1425       case SS$_ACCVIO:
1426         if (sigargs[3] == 0)
1427           {
1428             exception = &constraint_error;
1429             msg = "access zero";
1430           }
1431         else
1432           {
1433             exception = &storage_error;
1434             msg = "stack overflow (or erroneous memory access)";
1435           }
1436         break;
1437
1438       case SS$_STKOVF:
1439         exception = &storage_error;
1440         msg = "stack overflow";
1441         break;
1442
1443       case SS$_INTDIV:
1444         exception = &constraint_error;
1445         msg = "division by zero";
1446         break;
1447
1448       case SS$_HPARITH:
1449 #ifndef IN_RTS
1450         return SS$_RESIGNAL; /* toplev.c handles for compiler */
1451 #else
1452         {
1453           exception = &constraint_error;
1454           msg = "arithmetic error";
1455         }
1456 #endif
1457         break;
1458
1459       case MTH$_FLOOVEMAT:
1460         exception = &constraint_error;
1461         msg = "floating overflow in math library";
1462         break;
1463
1464       case SS$_CE24VRU:
1465         exception = &constraint_error;
1466         msg = "";
1467         break;
1468
1469       case SS$_C980VTE:
1470         exception = &program_error;
1471         msg = "";
1472         break;
1473
1474       default:
1475 #ifndef IN_RTS
1476         exception = &program_error;
1477 #else
1478         /* User programs expect Non_Ada_Error to be raised, reference
1479            DEC Ada test CXCONDHAN. */
1480         exception = &Non_Ada_Error;
1481 #endif
1482         msgdesc.len = 256;
1483         msgdesc.mbz = 0;
1484         msgdesc.adr = message;
1485         SYS$GETMSG (sigargs[1], &outlen, &msgdesc, msg_flag, 0);
1486         message[outlen] = 0;
1487         msg = message;
1488         break;
1489       }
1490
1491   mstate = (long *) (*Get_Machine_State_Addr) ();
1492   if (mstate != 0)
1493     {
1494       lib_get_curr_invo_context (&curr_icb);
1495       lib_get_prev_invo_context (&curr_icb);
1496       lib_get_prev_invo_context (&curr_icb);
1497       curr_invo_handle = lib_get_invo_handle (&curr_icb);
1498       *mstate = curr_invo_handle;
1499     }
1500   Raise_From_Signal_Handler (exception, msg);
1501 }
1502
1503 void
1504 __gnat_install_handler (void)
1505 {
1506   long prvhnd;
1507 #if defined (IN_RTS) && !defined (__IA64)
1508   char *c;
1509
1510   c = (char *) xmalloc (2049);
1511
1512   __gnat_error_prehandler_stack = &c[2048];
1513
1514   /* __gnat_error_prehandler is an assembly function.  */
1515   SYS$SETEXV (1, __gnat_error_prehandler, 3, &prvhnd);
1516 #else
1517   SYS$SETEXV (1, __gnat_error_handler, 3, &prvhnd);
1518 #endif
1519   __gnat_handler_installed = 1;
1520 }
1521
1522 void
1523 __gnat_initialize(void *eh ATTRIBUTE_UNUSED)
1524 {
1525 }
1526
1527 /*************************************************/
1528 /* __gnat_initialize (FreeBSD version) */
1529 /*************************************************/
1530
1531 #elif defined (__FreeBSD__)
1532
1533 #include <signal.h>
1534 #include <unistd.h>
1535
1536 static void __gnat_error_handler (int, int, struct sigcontext *);
1537
1538 static void
1539 __gnat_error_handler (int sig, int code __attribute__ ((unused)),
1540                       struct sigcontext *sc __attribute__ ((unused)))
1541 {
1542   struct Exception_Data *exception;
1543   const char *msg;
1544
1545   switch (sig)
1546     {
1547     case SIGFPE:
1548       exception = &constraint_error;
1549       msg = "SIGFPE";
1550       break;
1551
1552     case SIGILL:
1553       exception = &constraint_error;
1554       msg = "SIGILL";
1555       break;
1556
1557     case SIGSEGV:
1558       exception = &storage_error;
1559       msg = "stack overflow or erroneous memory access";
1560       break;
1561
1562     case SIGBUS:
1563       exception = &constraint_error;
1564       msg = "SIGBUS";
1565       break;
1566
1567     default:
1568       exception = &program_error;
1569       msg = "unhandled signal";
1570     }
1571
1572   Raise_From_Signal_Handler (exception, msg);
1573 }
1574
1575 void
1576 __gnat_install_handler ()
1577 {
1578   struct sigaction act;
1579
1580   /* Set up signal handler to map synchronous signals to appropriate
1581      exceptions.  Make sure that the handler isn't interrupted by another
1582      signal that might cause a scheduling event! */
1583
1584   act.sa_handler = __gnat_error_handler;
1585   act.sa_flags = SA_NODEFER | SA_RESTART;
1586   (void) sigemptyset (&act.sa_mask);
1587
1588   (void) sigaction (SIGILL,  &act, NULL);
1589   (void) sigaction (SIGFPE,  &act, NULL);
1590   (void) sigaction (SIGSEGV, &act, NULL);
1591   (void) sigaction (SIGBUS,  &act, NULL);
1592 }
1593
1594 void
1595 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
1596 {
1597    __gnat_install_handler ();
1598
1599    /* XXX - Initialize floating-point coprocessor. This call is
1600       needed because FreeBSD defaults to 64-bit precision instead
1601       of 80-bit precision?  We require the full precision for
1602       proper operation, given that we have set Max_Digits etc
1603       with this in mind */
1604    __gnat_init_float ();
1605 }
1606
1607 /***************************************/
1608 /* __gnat_initialize (VXWorks Version) */
1609 /***************************************/
1610
1611 #elif defined(__vxworks)
1612
1613 #include <signal.h>
1614 #include <taskLib.h>
1615 #include <intLib.h>
1616 #include <iv.h>
1617
1618 #ifdef VTHREADS
1619 #include "private/vThreadsP.h"
1620 #endif
1621
1622 extern int __gnat_inum_to_ivec (int);
1623 static void __gnat_error_handler (int, int, struct sigcontext *);
1624 void __gnat_map_signal (int);
1625
1626 #ifndef __alpha_vxworks
1627
1628 /* getpid is used by s-parint.adb, but is not defined by VxWorks, except
1629    on Alpha VxWorks */
1630
1631 extern long getpid (void);
1632
1633 long
1634 getpid (void)
1635 {
1636   return taskIdSelf ();
1637 }
1638 #endif
1639
1640 /* This is needed by the GNAT run time to handle Vxworks interrupts */
1641 int
1642 __gnat_inum_to_ivec (int num)
1643 {
1644   return INUM_TO_IVEC (num);
1645 }
1646
1647 /* VxWorks expects the field excCnt to be zeroed when a signal is handled.
1648    The VxWorks version of longjmp does this; gcc's builtin_longjmp does not */
1649 void
1650 __gnat_clear_exception_count (void)
1651 {
1652 #ifdef VTHREADS
1653   WIND_TCB *currentTask = (WIND_TCB *) taskIdSelf();
1654
1655   currentTask->vThreads.excCnt = 0;
1656 #endif
1657 }
1658
1659 /* Exported to 5zintman.adb in order to handle different signal
1660    to exception mappings in different VxWorks versions */
1661 void
1662 __gnat_map_signal (int sig)
1663 {
1664   struct Exception_Data *exception;
1665   char *msg;
1666
1667   switch (sig)
1668     {
1669     case SIGFPE:
1670       exception = &constraint_error;
1671       msg = "SIGFPE";
1672       break;
1673 #ifdef VTHREADS
1674     case SIGILL:
1675       exception = &constraint_error;
1676       msg = "Floating point exception or SIGILL";
1677       break;
1678     case SIGSEGV:
1679       exception = &storage_error;
1680       msg = "SIGSEGV: possible stack overflow";
1681       break;
1682     case SIGBUS:
1683       exception = &storage_error;
1684       msg = "SIGBUS: possible stack overflow";
1685       break;
1686 #else
1687     case SIGILL:
1688       exception = &constraint_error;
1689       msg = "SIGILL";
1690       break;
1691     case SIGSEGV:
1692       exception = &program_error;
1693       msg = "SIGSEGV";
1694       break;
1695     case SIGBUS:
1696       exception = &program_error;
1697       msg = "SIGBUS";
1698       break;
1699 #endif
1700     default:
1701       exception = &program_error;
1702       msg = "unhandled signal";
1703     }
1704
1705   __gnat_clear_exception_count ();
1706   Raise_From_Signal_Handler (exception, msg);
1707 }
1708
1709 static void
1710 __gnat_error_handler (int sig, int code, struct sigcontext *sc)
1711 {
1712   sigset_t mask;
1713   int result;
1714
1715   /* VxWorks will always mask out the signal during the signal handler and
1716      will reenable it on a longjmp.  GNAT does not generate a longjmp to
1717      return from a signal handler so the signal will still be masked unless
1718      we unmask it. */
1719   sigprocmask (SIG_SETMASK, NULL, &mask);
1720   sigdelset (&mask, sig);
1721   sigprocmask (SIG_SETMASK, &mask, NULL);
1722
1723   __gnat_map_signal (sig);
1724
1725 }
1726
1727 void
1728 __gnat_install_handler (void)
1729 {
1730   struct sigaction act;
1731
1732   /* Setup signal handler to map synchronous signals to appropriate
1733      exceptions.  Make sure that the handler isn't interrupted by another
1734      signal that might cause a scheduling event! */
1735
1736   act.sa_handler = __gnat_error_handler;
1737   act.sa_flags = SA_SIGINFO | SA_ONSTACK;
1738   sigemptyset (&act.sa_mask);
1739
1740   /* For VxWorks, install all signal handlers, since pragma Interrupt_State
1741      applies to vectored hardware interrupts, not signals */
1742   sigaction (SIGFPE,  &act, NULL);
1743   sigaction (SIGILL,  &act, NULL);
1744   sigaction (SIGSEGV, &act, NULL);
1745   sigaction (SIGBUS,  &act, NULL);
1746
1747   __gnat_handler_installed = 1;
1748 }
1749
1750 #define HAVE_GNAT_INIT_FLOAT
1751
1752 void
1753 __gnat_init_float (void)
1754 {
1755   /* Disable overflow/underflow exceptions on the PPC processor, this is needed
1756      to get correct Ada semantics.  Note that for AE653 vThreads, the HW
1757      overflow settings are an OS configuration issue.  The instructions
1758      below have no effect */
1759 #if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS)
1760   asm ("mtfsb0 25");
1761   asm ("mtfsb0 26");
1762 #endif
1763
1764   /* Similarly for sparc64. Achieved by masking bits in the Trap Enable Mask
1765      field of the Floating-point Status Register (see the Sparc Architecture
1766      Manual Version 9, p 48).  */
1767 #if defined (sparc64)
1768
1769 #define FSR_TEM_NVM (1 << 27)  /* Invalid operand  */
1770 #define FSR_TEM_OFM (1 << 26)  /* Overflow  */
1771 #define FSR_TEM_UFM (1 << 25)  /* Underflow  */
1772 #define FSR_TEM_DZM (1 << 24)  /* Division by Zero  */
1773 #define FSR_TEM_NXM (1 << 23)  /* Inexact result  */
1774   {
1775     unsigned int fsr;
1776
1777     __asm__("st %%fsr, %0" : "=m" (fsr));
1778     fsr &= ~(FSR_TEM_OFM | FSR_TEM_UFM);
1779     __asm__("ld %0, %%fsr" : : "m" (fsr));
1780   }
1781 #endif
1782 }
1783
1784 void
1785 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
1786 {
1787   __gnat_init_float ();
1788
1789   /* On targets where we might be using the ZCX scheme, we need to register
1790      the frame tables.
1791
1792      For applications loaded as a set of "modules", the crtstuff objects
1793      linked in (crtbegin/end) are tailored to provide this service a-la C++
1794      constructor fashion, typically triggered by the VxWorks loader.  This is
1795      achieved by way of a special variable declaration in the crt object, the
1796      name of which has been deduced by analyzing the output of the "munching"
1797      step documented for C++.  The de-registration is handled symmetrically,
1798      a-la C++ destructor fashion and typically triggered by the dynamic
1799      unloader.  Note that since the tables shall be registered against a
1800      common datastructure, libgcc should be one of the modules (vs being
1801      partially linked against all the others at build time) and shall be
1802      loaded first.
1803
1804      For applications linked with the kernel, the scheme above would lead to
1805      duplicated symbols because the VxWorks kernel build "munches" by default.
1806      To prevent those conflicts, we link against crtbegin/endS objects that
1807      don't include the special variable and directly call the appropriate
1808      function here. We'll never unload that, so there is no de-registration to
1809      worry about.
1810
1811      For whole applications loaded as a single module, we may use one scheme
1812      or the other, except for the mixed Ada/C++ case in which the first scheme
1813      would fail for the same reason as in the linked-with-kernel situation.
1814
1815      We can differentiate by looking at the __module_has_ctors value provided
1816      by each class of crt objects. As of today, selecting the crt set with the
1817      ctors/dtors capabilities (first scheme above) is triggered by adding
1818      "-dynamic" to the gcc *link* command line options. Selecting the other
1819      set of crt objects is achieved by "-static" instead.
1820
1821      This is a first approach, tightly synchronized with a number of GCC
1822      configuration and crtstuff changes. We need to ensure that those changes
1823      are there to activate this circuitry.  */
1824
1825 #if (__GNUC__ >= 3) && (defined (_ARCH_PPC) || defined (__ppc))
1826  {
1827    /* The scheme described above is only useful for the actual ZCX case, and
1828       we don't want any reference to the crt provided symbols otherwise.  We
1829       may not link with any of the crt objects in the non-ZCX case, e.g. from
1830       documented procedures instructing the use of -nostdlib, and references
1831       to the ctors symbols here would just remain unsatisfied.
1832
1833       We have no way to avoid those references in the right conditions in this
1834       C module, because we have nothing like a IN_ZCX_RTS macro.  This aspect
1835       is then deferred to an Ada routine, which can do that based on a test
1836       against a constant System flag value.  */
1837
1838    extern void __gnat_vxw_setup_for_eh (void);
1839    __gnat_vxw_setup_for_eh ();
1840  }
1841 #endif
1842 }
1843
1844 /********************************/
1845 /* __gnat_initialize for NetBSD */
1846 /********************************/
1847
1848 #elif defined(__NetBSD__)
1849
1850 #include <signal.h>
1851 #include <unistd.h>
1852
1853 static void
1854 __gnat_error_handler (int sig)
1855 {
1856   struct Exception_Data *exception;
1857   const char *msg;
1858
1859   switch(sig)
1860   {
1861     case SIGFPE:
1862       exception = &constraint_error;
1863       msg = "SIGFPE";
1864       break;
1865     case SIGILL:
1866       exception = &constraint_error;
1867       msg = "SIGILL";
1868       break;
1869     case SIGSEGV:
1870       exception = &storage_error;
1871       msg = "stack overflow or erroneous memory access";
1872       break;
1873     case SIGBUS:
1874       exception = &constraint_error;
1875       msg = "SIGBUS";
1876       break;
1877     default:
1878       exception = &program_error;
1879       msg = "unhandled signal";
1880     }
1881
1882     Raise_From_Signal_Handler(exception, msg);
1883 }
1884
1885 void
1886 __gnat_install_handler(void)
1887 {
1888   struct sigaction act;
1889
1890   act.sa_handler = __gnat_error_handler;
1891   act.sa_flags = SA_NODEFER | SA_RESTART;
1892   sigemptyset (&act.sa_mask);
1893
1894   /* Do not install handlers if interrupt state is "System" */
1895   if (__gnat_get_interrupt_state (SIGFPE) != 's')
1896     sigaction (SIGFPE,  &act, NULL);
1897   if (__gnat_get_interrupt_state (SIGILL) != 's')
1898     sigaction (SIGILL,  &act, NULL);
1899   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
1900     sigaction (SIGSEGV, &act, NULL);
1901   if (__gnat_get_interrupt_state (SIGBUS) != 's')
1902     sigaction (SIGBUS,  &act, NULL);
1903
1904   __gnat_handler_installed = 1;
1905 }
1906
1907 void
1908 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
1909 {
1910   __gnat_install_handler ();
1911   __gnat_init_float ();
1912 }
1913
1914 #else
1915
1916 /* For all other versions of GNAT, the initialize routine and handler
1917    installation do nothing */
1918
1919 /***************************************/
1920 /* __gnat_initialize (Default Version) */
1921 /***************************************/
1922
1923 void
1924 __gnat_initialize (void *eh ATTRIBUTE_UNUSED)
1925 {
1926 }
1927
1928 /********************************************/
1929 /* __gnat_install_handler (Default Version) */
1930 /********************************************/
1931
1932 void
1933 __gnat_install_handler (void)
1934 {
1935   __gnat_handler_installed = 1;
1936 }
1937
1938 #endif
1939
1940 /*********************/
1941 /* __gnat_init_float */
1942 /*********************/
1943
1944 /* This routine is called as each process thread is created, for possible
1945    initialization of the FP processor. This version is used under INTERIX,
1946    WIN32 and could be used under OS/2 */
1947
1948 #if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \
1949   || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__)
1950
1951 #define HAVE_GNAT_INIT_FLOAT
1952
1953 void
1954 __gnat_init_float (void)
1955 {
1956 #if defined (__i386__) || defined (i386)
1957
1958   /* This is used to properly initialize the FPU on an x86 for each
1959      process thread. */
1960
1961   asm ("finit");
1962
1963 #endif  /* Defined __i386__ */
1964 }
1965 #endif
1966
1967 #ifndef HAVE_GNAT_INIT_FLOAT
1968
1969 /* All targets without a specific __gnat_init_float will use an empty one */
1970 void
1971 __gnat_init_float (void)
1972 {
1973 }
1974 #endif
1975
1976 /***********************************/
1977 /* __gnat_adjust_context_for_raise */
1978 /***********************************/
1979
1980 #ifndef HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
1981
1982 /* All targets without a specific version will use an empty one */
1983
1984 /* UCONTEXT is a pointer to a context structure received by a signal handler
1985    about to propagate an exception. Adjust it to compensate the fact that the
1986    generic unwinder thinks the corresponding PC is a call return address.  */
1987
1988 void
1989 __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED,
1990                                  void *ucontext ATTRIBUTE_UNUSED)
1991 {
1992   /* The point is that the interrupted context PC typically is the address
1993      that we should search an EH region for, which is different from the call
1994      return address case. The target independent part of the GCC unwinder
1995      don't differentiate the two situations, so we compensate here for the
1996      adjustments it will blindly make.
1997
1998      signo is passed because on some targets for some signals the PC in
1999      context points to the instruction after the faulting one, in which case
2000      the unwinder adjustment is still desired.  */
2001
2002   /* On a number of targets, we have arranged for the adjustment to be
2003      performed by the MD_FALLBACK_FRAME_STATE circuitry, so we don't provide a
2004      specific instance of this routine.  The MD_FALLBACK doesn't have access
2005      to the signal number, though, so the compensation is systematic there and
2006      might be wrong in some cases.  */
2007
2008   /* Having the compensation wrong leads to potential failures.  A very
2009      typical case is what happens when there is no compensation and a signal
2010      triggers for the first instruction in a region : the unwinder adjustment
2011      has it search in the wrong EH region.  */
2012 }
2013
2014 #endif