File : a-except-xi.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       A D A . E X C E P T I O N S                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2015, 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 3,  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.                                     --
  17 --                                                                          --
  18 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31 
  32 --  This body is part of the bare board Ravenscar run time. It implements
  33 --  Ada 83 exception handling, plus a subset of the operations available
  34 --  in Ada 95 for Exception_Occurrences and Exception_Ids (Exception_Name,
  35 --  Exception_Identity ...).
  36 
  37 with System;                  use System;
  38 with System.Standard_Library; use System.Standard_Library;
  39 with System.Soft_Links;       use System.Soft_Links;
  40 with System.Exceptions_Debug; use System.Exceptions_Debug;
  41 
  42 package body Ada.Exceptions is
  43 
  44    procedure Last_Chance_Handler (Except :  Exception_Occurrence);
  45    pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler");
  46    pragma No_Return (Last_Chance_Handler);
  47 
  48    pragma Suppress (All_Checks);
  49    --  We definitely do not want exceptions occurring within this unit, or
  50    --  we are in big trouble. If an exceptional situation does occur, better
  51    --  that it not be raised, since raising it can cause confusing chaos.
  52 
  53    -----------------------
  54    -- Local Subprograms --
  55    -----------------------
  56 
  57    function Code_Address_For_AAA return System.Address;
  58    function Code_Address_For_ZZZ return System.Address;
  59    --  Return start and end of procedures in this package
  60    --
  61    --  These procedures are used to provide exclusion bounds in calls to
  62    --  Call_Chain at exception raise points from this unit. The purpose is to
  63    --  arrange for the exception tracebacks not to include frames from routines
  64    --  involved in the raise process, as these are meaningless from the user's
  65    --  standpoint.
  66    --
  67    --  For these bounds to be meaningful, we need to ensure that the object
  68    --  code for the routines involved in processing a raise is located after
  69    --  the object code Code_Address_For_AAA and before the object code
  70    --  Code_Address_For_ZZZ. This will indeed be the case as long as the
  71    --  following rules are respected:
  72    --
  73    --  1) The bodies of the subprograms involved in processing a raise are
  74    --     located after the body of Code_Address_For_AAA and before the
  75    --     body of Code_Address_For_ZZZ.
  76    --
  77    --  2) No pragma Inline applies to any of these subprograms, as this could
  78    --     delay the corresponding assembly output until the end of the unit.
  79 
  80    procedure Call_Chain (Excep : EOA);
  81    --  Generate traceback if enabled
  82 
  83    procedure Process_Exception
  84      (E          : Exception_Id;
  85       Is_Reraise : Boolean := False);
  86    pragma No_Return (Process_Exception);
  87    pragma Export (Ada, Process_Exception, "__gnat_raise_nodefer_with_msg");
  88    --  Shared exception processing for raise / reraise
  89 
  90    procedure Raise_Constraint_Error (File : System.Address; Line : Integer);
  91    pragma No_Return (Raise_Constraint_Error);
  92    pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
  93    --  Raise constraint error
  94 
  95    procedure Raise_Program_Error (File : System.Address; Line : Integer);
  96    pragma No_Return (Raise_Program_Error);
  97    pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error");
  98    --  Raise program error
  99 
 100    procedure Raise_Storage_Error (File : System.Address; Line : Integer);
 101    pragma No_Return (Raise_Storage_Error);
 102    pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error");
 103    --  Raise storage error
 104 
 105    -----------------------------
 106    -- Run-Time Check Routines --
 107    -----------------------------
 108 
 109    --  These routines raise a specific exception with a reason message
 110    --  attached. The parameters are the file name and line number in each
 111    --  case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
 112 
 113    procedure Rcheck_CE_Access_Check
 114      (File : System.Address; Line : Integer);
 115    procedure Rcheck_CE_Null_Access_Parameter
 116      (File : System.Address; Line : Integer);
 117    procedure Rcheck_CE_Discriminant_Check
 118      (File : System.Address; Line : Integer);
 119    procedure Rcheck_CE_Divide_By_Zero
 120      (File : System.Address; Line : Integer);
 121    procedure Rcheck_CE_Explicit_Raise
 122      (File : System.Address; Line : Integer);
 123    procedure Rcheck_CE_Index_Check
 124      (File : System.Address; Line : Integer);
 125    procedure Rcheck_CE_Invalid_Data
 126      (File : System.Address; Line : Integer);
 127    procedure Rcheck_CE_Length_Check
 128      (File : System.Address; Line : Integer);
 129    procedure Rcheck_CE_Null_Exception_Id
 130      (File : System.Address; Line : Integer);
 131    procedure Rcheck_CE_Null_Not_Allowed
 132      (File : System.Address; Line : Integer);
 133    procedure Rcheck_CE_Overflow_Check
 134      (File : System.Address; Line : Integer);
 135    procedure Rcheck_CE_Partition_Check
 136      (File : System.Address; Line : Integer);
 137    procedure Rcheck_CE_Range_Check
 138      (File : System.Address; Line : Integer);
 139    procedure Rcheck_CE_Tag_Check
 140      (File : System.Address; Line : Integer);
 141    procedure Rcheck_PE_Access_Before_Elaboration
 142      (File : System.Address; Line : Integer);
 143    procedure Rcheck_PE_Accessibility_Check
 144      (File : System.Address; Line : Integer);
 145    procedure Rcheck_PE_Address_Of_Intrinsic
 146      (File : System.Address; Line : Integer);
 147    procedure Rcheck_PE_Aliased_Parameters
 148      (File : System.Address; Line : Integer);
 149    procedure Rcheck_PE_All_Guards_Closed
 150      (File : System.Address; Line : Integer);
 151    procedure Rcheck_PE_Bad_Predicated_Generic_Type
 152      (File : System.Address; Line : Integer);
 153    procedure Rcheck_PE_Current_Task_In_Entry_Body
 154      (File : System.Address; Line : Integer);
 155    procedure Rcheck_PE_Duplicated_Entry_Address
 156      (File : System.Address; Line : Integer);
 157    procedure Rcheck_PE_Explicit_Raise
 158      (File : System.Address; Line : Integer);
 159    procedure Rcheck_PE_Implicit_Return
 160      (File : System.Address; Line : Integer);
 161    procedure Rcheck_PE_Misaligned_Address_Value
 162      (File : System.Address; Line : Integer);
 163    procedure Rcheck_PE_Missing_Return
 164      (File : System.Address; Line : Integer);
 165    procedure Rcheck_PE_Non_Transportable_Actual
 166      (File : System.Address; Line : Integer);
 167    procedure Rcheck_PE_Overlaid_Controlled_Object
 168      (File : System.Address; Line : Integer);
 169    procedure Rcheck_PE_Potentially_Blocking_Operation
 170      (File : System.Address; Line : Integer);
 171    procedure Rcheck_PE_Stream_Operation_Not_Allowed
 172      (File : System.Address; Line : Integer);
 173    procedure Rcheck_PE_Stubbed_Subprogram_Called
 174      (File : System.Address; Line : Integer);
 175    procedure Rcheck_PE_Unchecked_Union_Restriction
 176      (File : System.Address; Line : Integer);
 177    procedure Rcheck_SE_Empty_Storage_Pool
 178      (File : System.Address; Line : Integer);
 179    procedure Rcheck_SE_Explicit_Raise
 180      (File : System.Address; Line : Integer);
 181    procedure Rcheck_SE_Infinite_Recursion
 182      (File : System.Address; Line : Integer);
 183    procedure Rcheck_SE_Object_Too_Large
 184      (File : System.Address; Line : Integer);
 185    procedure Rcheck_PE_Finalize_Raised_Exception
 186      (File : System.Address; Line : Integer);
 187 
 188    pragma Export (C, Rcheck_CE_Access_Check,
 189                   "__gnat_rcheck_CE_Access_Check");
 190    pragma Export (C, Rcheck_CE_Null_Access_Parameter,
 191                   "__gnat_rcheck_CE_Null_Access_Parameter");
 192    pragma Export (C, Rcheck_CE_Discriminant_Check,
 193                   "__gnat_rcheck_CE_Discriminant_Check");
 194    pragma Export (C, Rcheck_CE_Divide_By_Zero,
 195                   "__gnat_rcheck_CE_Divide_By_Zero");
 196    pragma Export (C, Rcheck_CE_Explicit_Raise,
 197                   "__gnat_rcheck_CE_Explicit_Raise");
 198    pragma Export (C, Rcheck_CE_Index_Check,
 199                   "__gnat_rcheck_CE_Index_Check");
 200    pragma Export (C, Rcheck_CE_Invalid_Data,
 201                   "__gnat_rcheck_CE_Invalid_Data");
 202    pragma Export (C, Rcheck_CE_Length_Check,
 203                   "__gnat_rcheck_CE_Length_Check");
 204    pragma Export (C, Rcheck_CE_Null_Exception_Id,
 205                   "__gnat_rcheck_CE_Null_Exception_Id");
 206    pragma Export (C, Rcheck_CE_Null_Not_Allowed,
 207                   "__gnat_rcheck_CE_Null_Not_Allowed");
 208    pragma Export (C, Rcheck_CE_Overflow_Check,
 209                   "__gnat_rcheck_CE_Overflow_Check");
 210    pragma Export (C, Rcheck_CE_Partition_Check,
 211                   "__gnat_rcheck_CE_Partition_Check");
 212    pragma Export (C, Rcheck_CE_Range_Check,
 213                   "__gnat_rcheck_CE_Range_Check");
 214    pragma Export (C, Rcheck_CE_Tag_Check,
 215                   "__gnat_rcheck_CE_Tag_Check");
 216    pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
 217                   "__gnat_rcheck_PE_Access_Before_Elaboration");
 218    pragma Export (C, Rcheck_PE_Accessibility_Check,
 219                   "__gnat_rcheck_PE_Accessibility_Check");
 220    pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
 221                   "__gnat_rcheck_PE_Address_Of_Intrinsic");
 222    pragma Export (C, Rcheck_PE_Aliased_Parameters,
 223                   "__gnat_rcheck_PE_Aliased_Parameters");
 224    pragma Export (C, Rcheck_PE_All_Guards_Closed,
 225                   "__gnat_rcheck_PE_All_Guards_Closed");
 226    pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
 227                   "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
 228    pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
 229                   "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
 230    pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
 231                   "__gnat_rcheck_PE_Duplicated_Entry_Address");
 232    pragma Export (C, Rcheck_PE_Explicit_Raise,
 233                   "__gnat_rcheck_PE_Explicit_Raise");
 234    pragma Export (C, Rcheck_PE_Finalize_Raised_Exception,
 235                   "__gnat_rcheck_PE_Finalize_Raised_Exception");
 236    pragma Export (C, Rcheck_PE_Implicit_Return,
 237                   "__gnat_rcheck_PE_Implicit_Return");
 238    pragma Export (C, Rcheck_PE_Misaligned_Address_Value,
 239                   "__gnat_rcheck_PE_Misaligned_Address_Value");
 240    pragma Export (C, Rcheck_PE_Missing_Return,
 241                   "__gnat_rcheck_PE_Missing_Return");
 242    pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
 243                   "__gnat_rcheck_PE_Non_Transportable_Actual");
 244    pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
 245                   "__gnat_rcheck_PE_Overlaid_Controlled_Object");
 246    pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
 247                   "__gnat_rcheck_PE_Potentially_Blocking_Operation");
 248    pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
 249                   "__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
 250    pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
 251                   "__gnat_rcheck_PE_Stubbed_Subprogram_Called");
 252    pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
 253                   "__gnat_rcheck_PE_Unchecked_Union_Restriction");
 254    pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
 255                   "__gnat_rcheck_SE_Empty_Storage_Pool");
 256    pragma Export (C, Rcheck_SE_Explicit_Raise,
 257                   "__gnat_rcheck_SE_Explicit_Raise");
 258    pragma Export (C, Rcheck_SE_Infinite_Recursion,
 259                   "__gnat_rcheck_SE_Infinite_Recursion");
 260    pragma Export (C, Rcheck_SE_Object_Too_Large,
 261                   "__gnat_rcheck_SE_Object_Too_Large");
 262 
 263    --  None of these procedures ever returns (they raise an exception). By
 264    --  using pragma No_Return, we ensure that any junk code after the call,
 265    --  such as normal return epilogue stuff, can be eliminated).
 266 
 267    pragma No_Return (Rcheck_CE_Access_Check);
 268    pragma No_Return (Rcheck_CE_Null_Access_Parameter);
 269    pragma No_Return (Rcheck_CE_Discriminant_Check);
 270    pragma No_Return (Rcheck_CE_Divide_By_Zero);
 271    pragma No_Return (Rcheck_CE_Explicit_Raise);
 272    pragma No_Return (Rcheck_CE_Index_Check);
 273    pragma No_Return (Rcheck_CE_Invalid_Data);
 274    pragma No_Return (Rcheck_CE_Length_Check);
 275    pragma No_Return (Rcheck_CE_Null_Exception_Id);
 276    pragma No_Return (Rcheck_CE_Null_Not_Allowed);
 277    pragma No_Return (Rcheck_CE_Overflow_Check);
 278    pragma No_Return (Rcheck_CE_Partition_Check);
 279    pragma No_Return (Rcheck_CE_Range_Check);
 280    pragma No_Return (Rcheck_CE_Tag_Check);
 281    pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
 282    pragma No_Return (Rcheck_PE_Accessibility_Check);
 283    pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
 284    pragma No_Return (Rcheck_PE_Aliased_Parameters);
 285    pragma No_Return (Rcheck_PE_All_Guards_Closed);
 286    pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
 287    pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
 288    pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
 289    pragma No_Return (Rcheck_PE_Explicit_Raise);
 290    pragma No_Return (Rcheck_PE_Implicit_Return);
 291    pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
 292    pragma No_Return (Rcheck_PE_Missing_Return);
 293    pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
 294    pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
 295    pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
 296    pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
 297    pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
 298    pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
 299    pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
 300    pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
 301    pragma No_Return (Rcheck_SE_Explicit_Raise);
 302    pragma No_Return (Rcheck_SE_Infinite_Recursion);
 303    pragma No_Return (Rcheck_SE_Object_Too_Large);
 304 
 305    --------------------------
 306    -- Code_Address_For_AAA --
 307    --------------------------
 308 
 309    --  This function gives us the start of the PC range for addresses within
 310    --  the exception unit itself. We hope that gigi/gcc keep all the procedures
 311    --  in their original order.
 312 
 313    function Code_Address_For_AAA return System.Address is
 314    begin
 315       --  We are using a label instead of Code_Address_For_AAA'Address because
 316       --  on some platforms the latter does not yield the address we want, but
 317       --  the address of a stub or of a descriptor instead. This is the case at
 318       --  least on PA-HPUX.
 319 
 320       <<Start_Of_AAA>>
 321       return Start_Of_AAA'Address;
 322    end Code_Address_For_AAA;
 323 
 324    ----------------
 325    -- Call_Chain --
 326    ----------------
 327 
 328    procedure Call_Chain (Excep : EOA) is separate;
 329 
 330    ------------------------
 331    -- Exception_Identity --
 332    ------------------------
 333 
 334    function Exception_Identity
 335      (X : Exception_Occurrence) return Exception_Id
 336    is
 337    begin
 338       return X.Id;
 339    end Exception_Identity;
 340 
 341    --------------------
 342    -- Exception_Name --
 343    --------------------
 344 
 345    function Exception_Name (X : Exception_Occurrence) return String is
 346    begin
 347       return Exception_Name (X.Id);
 348    end Exception_Name;
 349 
 350    function Exception_Name (Id : Exception_Id) return String is
 351    begin
 352       return To_Ptr (Id.Full_Name).all (1 .. Id.Name_Length - 1);
 353    end Exception_Name;
 354 
 355    --------------------------------------
 356    -- Calls to Run-Time Check Routines --
 357    --------------------------------------
 358 
 359    procedure Rcheck_CE_Access_Check
 360      (File : System.Address; Line : Integer)
 361    is
 362    begin
 363       Raise_Constraint_Error (File, Line);
 364    end Rcheck_CE_Access_Check;
 365 
 366    procedure Rcheck_CE_Null_Access_Parameter
 367      (File : System.Address; Line : Integer)
 368    is
 369    begin
 370       Raise_Constraint_Error (File, Line);
 371    end Rcheck_CE_Null_Access_Parameter;
 372 
 373    procedure Rcheck_CE_Discriminant_Check
 374      (File : System.Address; Line : Integer)
 375    is
 376    begin
 377       Raise_Constraint_Error (File, Line);
 378    end Rcheck_CE_Discriminant_Check;
 379 
 380    procedure Rcheck_CE_Divide_By_Zero
 381      (File : System.Address; Line : Integer)
 382    is
 383    begin
 384       Raise_Constraint_Error (File, Line);
 385    end Rcheck_CE_Divide_By_Zero;
 386 
 387    procedure Rcheck_CE_Explicit_Raise
 388      (File : System.Address; Line : Integer)
 389    is
 390    begin
 391       Raise_Constraint_Error (File, Line);
 392    end Rcheck_CE_Explicit_Raise;
 393 
 394    procedure Rcheck_CE_Index_Check
 395      (File : System.Address; Line : Integer)
 396    is
 397    begin
 398       Raise_Constraint_Error (File, Line);
 399    end Rcheck_CE_Index_Check;
 400 
 401    procedure Rcheck_CE_Invalid_Data
 402      (File : System.Address; Line : Integer)
 403    is
 404    begin
 405       Raise_Constraint_Error (File, Line);
 406    end Rcheck_CE_Invalid_Data;
 407 
 408    procedure Rcheck_CE_Length_Check
 409      (File : System.Address; Line : Integer)
 410    is
 411    begin
 412       Raise_Constraint_Error (File, Line);
 413    end Rcheck_CE_Length_Check;
 414 
 415    procedure Rcheck_CE_Null_Exception_Id
 416      (File : System.Address; Line : Integer)
 417    is
 418    begin
 419       Raise_Constraint_Error (File, Line);
 420    end Rcheck_CE_Null_Exception_Id;
 421 
 422    procedure Rcheck_CE_Null_Not_Allowed
 423      (File : System.Address; Line : Integer)
 424    is
 425    begin
 426       Raise_Constraint_Error (File, Line);
 427    end Rcheck_CE_Null_Not_Allowed;
 428 
 429    procedure Rcheck_CE_Overflow_Check
 430      (File : System.Address; Line : Integer)
 431    is
 432    begin
 433       Raise_Constraint_Error (File, Line);
 434    end Rcheck_CE_Overflow_Check;
 435 
 436    procedure Rcheck_CE_Partition_Check
 437      (File : System.Address; Line : Integer)
 438    is
 439    begin
 440       Raise_Constraint_Error (File, Line);
 441    end Rcheck_CE_Partition_Check;
 442 
 443    procedure Rcheck_CE_Range_Check
 444      (File : System.Address; Line : Integer)
 445    is
 446    begin
 447       Raise_Constraint_Error (File, Line);
 448    end Rcheck_CE_Range_Check;
 449 
 450    procedure Rcheck_CE_Tag_Check
 451      (File : System.Address; Line : Integer)
 452    is
 453    begin
 454       Raise_Constraint_Error (File, Line);
 455    end Rcheck_CE_Tag_Check;
 456 
 457    procedure Rcheck_PE_Access_Before_Elaboration
 458      (File : System.Address; Line : Integer)
 459    is
 460    begin
 461       Raise_Program_Error (File, Line);
 462    end Rcheck_PE_Access_Before_Elaboration;
 463 
 464    procedure Rcheck_PE_Accessibility_Check
 465      (File : System.Address; Line : Integer)
 466    is
 467    begin
 468       Raise_Program_Error (File, Line);
 469    end Rcheck_PE_Accessibility_Check;
 470 
 471    procedure Rcheck_PE_Address_Of_Intrinsic
 472      (File : System.Address; Line : Integer)
 473    is
 474    begin
 475       Raise_Program_Error (File, Line);
 476    end Rcheck_PE_Address_Of_Intrinsic;
 477 
 478    procedure Rcheck_PE_Aliased_Parameters
 479      (File : System.Address; Line : Integer)
 480    is
 481    begin
 482       Raise_Program_Error (File, Line);
 483    end Rcheck_PE_Aliased_Parameters;
 484 
 485    procedure Rcheck_PE_All_Guards_Closed
 486      (File : System.Address; Line : Integer)
 487    is
 488    begin
 489       Raise_Program_Error (File, Line);
 490    end Rcheck_PE_All_Guards_Closed;
 491 
 492    procedure Rcheck_PE_Bad_Predicated_Generic_Type
 493      (File : System.Address; Line : Integer)
 494    is
 495    begin
 496       Raise_Program_Error (File, Line);
 497    end Rcheck_PE_Bad_Predicated_Generic_Type;
 498 
 499    procedure Rcheck_PE_Current_Task_In_Entry_Body
 500      (File : System.Address; Line : Integer)
 501    is
 502    begin
 503       Raise_Program_Error (File, Line);
 504    end Rcheck_PE_Current_Task_In_Entry_Body;
 505 
 506    procedure Rcheck_PE_Duplicated_Entry_Address
 507      (File : System.Address; Line : Integer)
 508    is
 509    begin
 510       Raise_Program_Error (File, Line);
 511    end Rcheck_PE_Duplicated_Entry_Address;
 512 
 513    procedure Rcheck_PE_Explicit_Raise
 514      (File : System.Address; Line : Integer)
 515    is
 516    begin
 517       Raise_Program_Error (File, Line);
 518    end Rcheck_PE_Explicit_Raise;
 519 
 520    procedure Rcheck_PE_Implicit_Return
 521      (File : System.Address; Line : Integer)
 522    is
 523    begin
 524       Raise_Program_Error (File, Line);
 525    end Rcheck_PE_Implicit_Return;
 526 
 527    procedure Rcheck_PE_Misaligned_Address_Value
 528      (File : System.Address; Line : Integer)
 529    is
 530    begin
 531       Raise_Program_Error (File, Line);
 532    end Rcheck_PE_Misaligned_Address_Value;
 533 
 534    procedure Rcheck_PE_Missing_Return
 535      (File : System.Address; Line : Integer)
 536    is
 537    begin
 538       Raise_Program_Error (File, Line);
 539    end Rcheck_PE_Missing_Return;
 540 
 541    procedure Rcheck_PE_Non_Transportable_Actual
 542      (File : System.Address; Line : Integer)
 543    is
 544    begin
 545       Raise_Program_Error (File, Line);
 546    end Rcheck_PE_Non_Transportable_Actual;
 547 
 548    procedure Rcheck_PE_Overlaid_Controlled_Object
 549      (File : System.Address; Line : Integer)
 550    is
 551    begin
 552       Raise_Program_Error (File, Line);
 553    end Rcheck_PE_Overlaid_Controlled_Object;
 554 
 555    procedure Rcheck_PE_Potentially_Blocking_Operation
 556      (File : System.Address; Line : Integer)
 557    is
 558    begin
 559       Raise_Program_Error (File, Line);
 560    end Rcheck_PE_Potentially_Blocking_Operation;
 561 
 562    procedure Rcheck_PE_Stream_Operation_Not_Allowed
 563      (File : System.Address; Line : Integer)
 564    is
 565    begin
 566       Raise_Program_Error (File, Line);
 567    end Rcheck_PE_Stream_Operation_Not_Allowed;
 568 
 569    procedure Rcheck_PE_Stubbed_Subprogram_Called
 570      (File : System.Address; Line : Integer)
 571    is
 572    begin
 573       Raise_Program_Error (File, Line);
 574    end Rcheck_PE_Stubbed_Subprogram_Called;
 575 
 576    procedure Rcheck_PE_Unchecked_Union_Restriction
 577      (File : System.Address; Line : Integer)
 578    is
 579    begin
 580       Raise_Program_Error (File, Line);
 581    end Rcheck_PE_Unchecked_Union_Restriction;
 582 
 583    procedure Rcheck_SE_Empty_Storage_Pool
 584      (File : System.Address; Line : Integer)
 585    is
 586    begin
 587       Raise_Storage_Error (File, Line);
 588    end Rcheck_SE_Empty_Storage_Pool;
 589 
 590    procedure Rcheck_SE_Explicit_Raise
 591      (File : System.Address; Line : Integer)
 592    is
 593    begin
 594       Raise_Storage_Error (File, Line);
 595    end Rcheck_SE_Explicit_Raise;
 596 
 597    procedure Rcheck_SE_Infinite_Recursion
 598      (File : System.Address; Line : Integer)
 599    is
 600    begin
 601       Raise_Storage_Error (File, Line);
 602    end Rcheck_SE_Infinite_Recursion;
 603 
 604    procedure Rcheck_SE_Object_Too_Large
 605      (File : System.Address; Line : Integer)
 606    is
 607    begin
 608       Raise_Storage_Error (File, Line);
 609    end Rcheck_SE_Object_Too_Large;
 610 
 611    procedure Rcheck_PE_Finalize_Raised_Exception
 612      (File : System.Address; Line : Integer)
 613    is
 614    begin
 615       Raise_Program_Error (File, Line);
 616    end Rcheck_PE_Finalize_Raised_Exception;
 617 
 618    ----------------------------
 619    -- Raise_Constraint_Error --
 620    ----------------------------
 621 
 622    procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is
 623       pragma Unreferenced (File, Line);
 624    begin
 625       Raise_Exception (Constraint_Error_Def'Access);
 626    end Raise_Constraint_Error;
 627 
 628    -----------------------
 629    -- Process_Exception --
 630    -----------------------
 631 
 632    procedure Process_Exception
 633      (E          : Exception_Id;
 634       Is_Reraise : Boolean := False)
 635    is
 636       Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
 637       Excep       : constant EOA     := Get_Current_Excep.all;
 638    begin
 639       Debug_Raise_Exception
 640         (E       => SSL.Exception_Data_Ptr (E),
 641          Message => Excep.Msg (1 .. Excep.Msg_Length));
 642 
 643       --  Store the identifier for this exception because it may be
 644       --  needed by a reraise.
 645 
 646       Excep.Id := E;
 647 
 648       --  Generate traceback if enabled
 649 
 650       if not Is_Reraise then
 651          Excep.Num_Tracebacks := 0;
 652          Call_Chain (Excep);
 653       end if;
 654 
 655       --  WARNING : There should be no exception handler for this body because
 656       --  this would cause gigi to prepend a setup for a new jmpbuf to the
 657       --  sequence of statements. We would then always get this new buf in
 658       --  Jumpbuf_Ptr instead of the one for the exception we are handling,
 659       --  which would completely break the whole design of this procedure.
 660 
 661       --  If the jump buffer pointer is non-null, transfer control using it
 662 
 663       if Jumpbuf_Ptr /= Null_Address then
 664          builtin_longjmp (To_Jmpbuf_Address (Jumpbuf_Ptr), 1);
 665 
 666       --  Otherwise this is an unhandled exception
 667 
 668       else
 669          --  Call this hook so that GDB can insert a breakpoint on unhandled
 670          --  exceptions. This procedure has no other effect.
 671 
 672          Debug_Unhandled_Exception (E => SSL.Exception_Data_Ptr (E));
 673 
 674          --  Check whether there is any termination handler to be executed for
 675          --  the environment task, and execute it if needed.
 676 
 677          Task_Termination_Handler.all (Excep.all);
 678 
 679          --  Code to be executed for unhandled exceptions
 680 
 681          Last_Chance_Handler (Excep.all);
 682       end if;
 683    end Process_Exception;
 684 
 685    ---------------------
 686    -- Raise_Exception --
 687    ---------------------
 688 
 689    procedure Raise_Exception (E : Exception_Id; Message : String := "") is
 690       pragma Unreferenced (Message);
 691       --  This appears to be as early as we can start ignoring the "Message"
 692       --  parameter, since "Raise_Exception" is externally callable.
 693    begin
 694       Process_Exception (E);
 695    end Raise_Exception;
 696 
 697    ----------------------------
 698    -- Raise_Exception_Always --
 699    ----------------------------
 700 
 701    procedure Raise_Exception_Always
 702      (E       : Exception_Id;
 703       Message : String := "") renames Raise_Exception;
 704 
 705    -------------------------
 706    -- Raise_Program_Error --
 707    -------------------------
 708 
 709    procedure Raise_Program_Error (File : System.Address; Line : Integer) is
 710       pragma Unreferenced (File, Line);
 711    begin
 712       Process_Exception (Program_Error_Def'Access);
 713    end Raise_Program_Error;
 714 
 715    -------------------------
 716    -- Raise_Storage_Error --
 717    -------------------------
 718 
 719    procedure Raise_Storage_Error (File : System.Address; Line : Integer) is
 720       pragma Unreferenced (File, Line);
 721    begin
 722       Process_Exception (Storage_Error_Def'Access);
 723    end Raise_Storage_Error;
 724 
 725    ------------------------
 726    -- Reraise_Occurrence --
 727    ------------------------
 728 
 729    procedure Reraise_Occurrence (X : Exception_Occurrence) is
 730    begin
 731       Process_Exception (X.Id, Is_Reraise => True);
 732    end Reraise_Occurrence;
 733 
 734    -------------------------------
 735    -- Reraise_Occurrence_Always --
 736    -------------------------------
 737 
 738    procedure Reraise_Occurrence_Always (X : Exception_Occurrence)
 739      renames Reraise_Occurrence;
 740 
 741    ---------------------------------
 742    -- Reraise_Occurrence_No_Defer --
 743    ---------------------------------
 744 
 745    procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence)
 746      renames Reraise_Occurrence;
 747 
 748    ---------------------
 749    -- Save_Occurrence --
 750    ---------------------
 751 
 752    procedure Save_Occurrence
 753      (Target : out Exception_Occurrence;
 754       Source : Exception_Occurrence)
 755    is
 756    begin
 757       Target.Id             := Source.Id;
 758       Target.Num_Tracebacks := Source.Num_Tracebacks;
 759 
 760       Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
 761         Source.Tracebacks (1 .. Target.Num_Tracebacks);
 762    end Save_Occurrence;
 763 
 764    --------------------------
 765    -- Code_Address_For_ZZZ --
 766    --------------------------
 767 
 768    --  This function gives us the end of the PC range for addresses
 769    --  within the exception unit itself. We hope that gigi/gcc keeps all the
 770    --  procedures in their original order.
 771 
 772    function Code_Address_For_ZZZ return System.Address is
 773    begin
 774       <<Start_Of_ZZZ>>
 775       return Start_Of_ZZZ'Address;
 776    end Code_Address_For_ZZZ;
 777 
 778 end Ada.Exceptions;