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-2014, 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-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 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 version of Ada.Exceptions is a full Ada 95 version, and Ada 2005 33-- features such as the additional definitions of Exception_Name returning 34-- Wide_[Wide_]String. 35 36-- It is used for building the compiler and the basic tools, since these 37-- builds may be done with bootstrap compilers that cannot handle these 38-- additions. The full version of Ada.Exceptions can be found in the files 39-- a-except-2005.ads/adb, and is used for all other builds where full Ada 40-- 2005 functionality is required. In particular, it is used for building 41-- run times on all targets. 42 43pragma Compiler_Unit_Warning; 44 45pragma Style_Checks (All_Checks); 46-- No subprogram ordering check, due to logical grouping 47 48pragma Polling (Off); 49-- We must turn polling off for this unit, because otherwise we get 50-- elaboration circularities with System.Exception_Tables. 51 52with System; use System; 53with System.Exceptions_Debug; use System.Exceptions_Debug; 54with System.Standard_Library; use System.Standard_Library; 55with System.Soft_Links; use System.Soft_Links; 56 57package body Ada.Exceptions is 58 59 pragma Suppress (All_Checks); 60 -- We definitely do not want exceptions occurring within this unit, or we 61 -- are in big trouble. If an exceptional situation does occur, better that 62 -- it not be raised, since raising it can cause confusing chaos. 63 64 ----------------------- 65 -- Local Subprograms -- 66 ----------------------- 67 68 -- Note: the exported subprograms in this package body are called directly 69 -- from C clients using the given external name, even though they are not 70 -- technically visible in the Ada sense. 71 72 procedure Process_Raise_Exception (E : Exception_Id); 73 pragma No_Return (Process_Raise_Exception); 74 -- This is the lowest level raise routine. It raises the exception 75 -- referenced by Current_Excep.all in the TSD, without deferring abort 76 -- (the caller must ensure that abort is deferred on entry). 77 78 procedure To_Stderr (S : String); 79 pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); 80 -- Little routine to output string to stderr that is also used in the 81 -- tasking run time. 82 83 procedure To_Stderr (C : Character); 84 pragma Inline (To_Stderr); 85 pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char"); 86 -- Little routine to output a character to stderr, used by some of the 87 -- separate units below. 88 89 package Exception_Data is 90 91 ----------------------------------- 92 -- Exception Message Subprograms -- 93 ----------------------------------- 94 95 procedure Set_Exception_C_Msg 96 (Excep : EOA; 97 Id : Exception_Id; 98 Msg1 : System.Address; 99 Line : Integer := 0; 100 Column : Integer := 0; 101 Msg2 : System.Address := System.Null_Address); 102 -- This routine is called to setup the exception referenced by the 103 -- Current_Excep field in the TSD to contain the indicated Id value 104 -- and message. Msg1 is a null terminated string which is generated 105 -- as the exception message. If line is non-zero, then a colon and 106 -- the decimal representation of this integer is appended to the 107 -- message. Ditto for Column. When Msg2 is non-null, a space and this 108 -- additional null terminated string is added to the message. 109 110 procedure Set_Exception_Msg 111 (Excep : EOA; 112 Id : Exception_Id; 113 Message : String); 114 -- This routine is called to setup the exception referenced by the 115 -- Current_Excep field in the TSD to contain the indicated Id value and 116 -- message. Message is a string which is generated as the exception 117 -- message. 118 119 --------------------------------------- 120 -- Exception Information Subprograms -- 121 --------------------------------------- 122 123 function Untailored_Exception_Information 124 (X : Exception_Occurrence) return String; 125 -- This is used by Stream_Attributes.EO_To_String to convert an 126 -- Exception_Occurrence to a String for the stream attributes. 127 -- String_To_EO understands the format, as documented here. 128 -- 129 -- The format of the string is as follows: 130 -- 131 -- Exception_Name: <exception name> (as in Exception_Name) 132 -- Message: <message> (only if Exception_Message is empty) 133 -- PID=nnnn (only if != 0) 134 -- Call stack traceback locations: (only if at least one location) 135 -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) 136 -- 137 -- The lines are separated by a ASCII.LF character. 138 -- The nnnn is the partition Id given as decimal digits. 139 -- The 0x... line represents traceback program counter locations, in 140 -- execution order with the first one being the exception location. 141 -- 142 -- The Exception_Name and Message lines are omitted in the abort 143 -- signal case, since this is not really an exception. 144 -- 145 -- Note: If the format of the generated string is changed, please note 146 -- that an equivalent modification to the routine String_To_EO must be 147 -- made to preserve proper functioning of the stream attributes. 148 149 function Exception_Information (X : Exception_Occurrence) return String; 150 -- This is the implementation of Ada.Exceptions.Exception_Information, 151 -- as defined in the Ada RM. 152 -- 153 -- If no traceback decorator (see GNAT.Exception_Traces) is currently 154 -- in place, this is the same as Untailored_Exception_Information. 155 -- Otherwise, the decorator is used to produce a symbolic traceback 156 -- instead of hexadecimal addresses. 157 -- 158 -- Note that unlike Untailored_Exception_Information, there is no need 159 -- to keep the output of Exception_Information stable for streaming 160 -- purposes, and in fact the output differs across platforms. 161 162 end Exception_Data; 163 164 package Exception_Traces is 165 166 ------------------------------------------------- 167 -- Run-Time Exception Notification Subprograms -- 168 ------------------------------------------------- 169 170 -- These subprograms provide a common run-time interface to trigger the 171 -- actions required when an exception is about to be propagated (e.g. 172 -- user specified actions or output of exception information). They are 173 -- exported to be usable by the Ada exception handling personality 174 -- routine when the GCC 3 mechanism is used. 175 176 procedure Notify_Handled_Exception (Excep : EOA); 177 pragma Export 178 (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); 179 -- This routine is called for a handled occurrence is about to be 180 -- propagated. 181 182 procedure Notify_Unhandled_Exception (Excep : EOA); 183 pragma Export 184 (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); 185 -- This routine is called when an unhandled occurrence is about to be 186 -- propagated. 187 188 procedure Unhandled_Exception_Terminate (Excep : EOA); 189 pragma No_Return (Unhandled_Exception_Terminate); 190 -- This procedure is called to terminate program execution following an 191 -- unhandled exception. The exception information, including traceback 192 -- if available is output, and execution is then terminated. Note that 193 -- at the point where this routine is called, the stack has typically 194 -- been destroyed. 195 196 end Exception_Traces; 197 198 package Stream_Attributes is 199 200 ---------------------------------- 201 -- Stream Attribute Subprograms -- 202 ---------------------------------- 203 204 function EId_To_String (X : Exception_Id) return String; 205 function String_To_EId (S : String) return Exception_Id; 206 -- Functions for implementing Exception_Id stream attributes 207 208 function EO_To_String (X : Exception_Occurrence) return String; 209 function String_To_EO (S : String) return Exception_Occurrence; 210 -- Functions for implementing Exception_Occurrence stream 211 -- attributes 212 213 end Stream_Attributes; 214 215 procedure Raise_Current_Excep (E : Exception_Id); 216 pragma No_Return (Raise_Current_Excep); 217 pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); 218 -- This is a simple wrapper to Process_Raise_Exception. 219 -- 220 -- This external name for Raise_Current_Excep is historical, and probably 221 -- should be changed but for now we keep it, because gdb and gigi know 222 -- about it. 223 224 procedure Raise_Exception_No_Defer 225 (E : Exception_Id; 226 Message : String := ""); 227 pragma Export 228 (Ada, Raise_Exception_No_Defer, 229 "ada__exceptions__raise_exception_no_defer"); 230 pragma No_Return (Raise_Exception_No_Defer); 231 -- Similar to Raise_Exception, but with no abort deferral 232 233 procedure Raise_With_Msg (E : Exception_Id); 234 pragma No_Return (Raise_With_Msg); 235 pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg"); 236 -- Raises an exception with given exception id value. A message is 237 -- associated with the raise, and has already been stored in the exception 238 -- occurrence referenced by the Current_Excep in the TSD. Abort is deferred 239 -- before the raise call. 240 241 procedure Raise_With_Location_And_Msg 242 (E : Exception_Id; 243 F : System.Address; 244 L : Integer; 245 M : System.Address := System.Null_Address); 246 pragma No_Return (Raise_With_Location_And_Msg); 247 -- Raise an exception with given exception id value. A filename and line 248 -- number is associated with the raise and is stored in the exception 249 -- occurrence and in addition a string message M is appended to this 250 -- if M is not null. 251 252 procedure Raise_Constraint_Error 253 (File : System.Address; 254 Line : Integer); 255 pragma No_Return (Raise_Constraint_Error); 256 pragma Export 257 (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); 258 -- Raise constraint error with file:line information 259 260 procedure Raise_Constraint_Error_Msg 261 (File : System.Address; 262 Line : Integer; 263 Msg : System.Address); 264 pragma No_Return (Raise_Constraint_Error_Msg); 265 pragma Export 266 (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); 267 -- Raise constraint error with file:line + msg information 268 269 procedure Raise_Program_Error 270 (File : System.Address; 271 Line : Integer); 272 pragma No_Return (Raise_Program_Error); 273 pragma Export 274 (C, Raise_Program_Error, "__gnat_raise_program_error"); 275 -- Raise program error with file:line information 276 277 procedure Raise_Program_Error_Msg 278 (File : System.Address; 279 Line : Integer; 280 Msg : System.Address); 281 pragma No_Return (Raise_Program_Error_Msg); 282 pragma Export 283 (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); 284 -- Raise program error with file:line + msg information 285 286 procedure Raise_Storage_Error 287 (File : System.Address; 288 Line : Integer); 289 pragma No_Return (Raise_Storage_Error); 290 pragma Export 291 (C, Raise_Storage_Error, "__gnat_raise_storage_error"); 292 -- Raise storage error with file:line information 293 294 procedure Raise_Storage_Error_Msg 295 (File : System.Address; 296 Line : Integer; 297 Msg : System.Address); 298 pragma No_Return (Raise_Storage_Error_Msg); 299 pragma Export 300 (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); 301 -- Raise storage error with file:line + reason msg information 302 303 -- The exception raising process and the automatic tracing mechanism rely 304 -- on some careful use of flags attached to the exception occurrence. The 305 -- graph below illustrates the relations between the Raise_ subprograms 306 -- and identifies the points where basic flags such as Exception_Raised 307 -- are initialized. 308 -- 309 -- (i) signs indicate the flags initialization points. R stands for Raise, 310 -- W for With, and E for Exception. 311 -- 312 -- R_No_Msg R_E R_Pe R_Ce R_Se 313 -- | | | | | 314 -- +--+ +--+ +---+ | +---+ 315 -- | | | | | 316 -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc 317 -- | | | | 318 -- +------------+ | +-----------+ +--+ 319 -- | | | | 320 -- | | | Set_E_C_Msg(i) 321 -- | | | 322 -- Raise_Current_Excep 323 324 procedure Reraise; 325 pragma No_Return (Reraise); 326 pragma Export (C, Reraise, "__gnat_reraise"); 327 -- Reraises the exception referenced by the Current_Excep field of the TSD 328 -- (all fields of this exception occurrence are set). Abort is deferred 329 -- before the reraise operation. 330 331 procedure Transfer_Occurrence 332 (Target : Exception_Occurrence_Access; 333 Source : Exception_Occurrence); 334 pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); 335 -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous 336 -- to setup Target from Source as an exception to be propagated in the 337 -- caller task. Target is expected to be a pointer to the fixed TSD 338 -- occurrence for this task. 339 340 -------------------------------- 341 -- Run-Time Check Subprograms -- 342 -------------------------------- 343 344 -- These subprograms raise a specific exception with a reason message 345 -- attached. The parameters are the file name and line number in each 346 -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. 347 348 -- Note on ordering of these subprograms. Normally in the Ada.Exceptions 349 -- units we do not care about the ordering of entries for Rcheck 350 -- subprograms, and the normal approach is to keep them in the same 351 -- order as declarations in Types. 352 353 -- This section is an IMPORTANT EXCEPTION. It is required by the .Net 354 -- runtime that the routine Rcheck_PE_Finalize_Raise_Exception is at the 355 -- end of the list (for reasons that are documented in the exceptmsg.awk 356 -- script which takes care of generating the required exception data). 357 358 procedure Rcheck_CE_Access_Check -- 00 359 (File : System.Address; Line : Integer); 360 procedure Rcheck_CE_Null_Access_Parameter -- 01 361 (File : System.Address; Line : Integer); 362 procedure Rcheck_CE_Discriminant_Check -- 02 363 (File : System.Address; Line : Integer); 364 procedure Rcheck_CE_Divide_By_Zero -- 03 365 (File : System.Address; Line : Integer); 366 procedure Rcheck_CE_Explicit_Raise -- 04 367 (File : System.Address; Line : Integer); 368 procedure Rcheck_CE_Index_Check -- 05 369 (File : System.Address; Line : Integer); 370 procedure Rcheck_CE_Invalid_Data -- 06 371 (File : System.Address; Line : Integer); 372 procedure Rcheck_CE_Length_Check -- 07 373 (File : System.Address; Line : Integer); 374 procedure Rcheck_CE_Null_Exception_Id -- 08 375 (File : System.Address; Line : Integer); 376 procedure Rcheck_CE_Null_Not_Allowed -- 09 377 (File : System.Address; Line : Integer); 378 procedure Rcheck_CE_Overflow_Check -- 10 379 (File : System.Address; Line : Integer); 380 procedure Rcheck_CE_Partition_Check -- 11 381 (File : System.Address; Line : Integer); 382 procedure Rcheck_CE_Range_Check -- 12 383 (File : System.Address; Line : Integer); 384 procedure Rcheck_CE_Tag_Check -- 13 385 (File : System.Address; Line : Integer); 386 procedure Rcheck_PE_Access_Before_Elaboration -- 14 387 (File : System.Address; Line : Integer); 388 procedure Rcheck_PE_Accessibility_Check -- 15 389 (File : System.Address; Line : Integer); 390 procedure Rcheck_PE_Address_Of_Intrinsic -- 16 391 (File : System.Address; Line : Integer); 392 procedure Rcheck_PE_Aliased_Parameters -- 17 393 (File : System.Address; Line : Integer); 394 procedure Rcheck_PE_All_Guards_Closed -- 18 395 (File : System.Address; Line : Integer); 396 procedure Rcheck_PE_Bad_Predicated_Generic_Type -- 19 397 (File : System.Address; Line : Integer); 398 procedure Rcheck_PE_Current_Task_In_Entry_Body -- 20 399 (File : System.Address; Line : Integer); 400 procedure Rcheck_PE_Duplicated_Entry_Address -- 21 401 (File : System.Address; Line : Integer); 402 procedure Rcheck_PE_Explicit_Raise -- 22 403 (File : System.Address; Line : Integer); 404 405 procedure Rcheck_PE_Implicit_Return -- 24 406 (File : System.Address; Line : Integer); 407 procedure Rcheck_PE_Misaligned_Address_Value -- 25 408 (File : System.Address; Line : Integer); 409 procedure Rcheck_PE_Missing_Return -- 26 410 (File : System.Address; Line : Integer); 411 procedure Rcheck_PE_Overlaid_Controlled_Object -- 27 412 (File : System.Address; Line : Integer); 413 procedure Rcheck_PE_Potentially_Blocking_Operation -- 28 414 (File : System.Address; Line : Integer); 415 procedure Rcheck_PE_Stubbed_Subprogram_Called -- 29 416 (File : System.Address; Line : Integer); 417 procedure Rcheck_PE_Unchecked_Union_Restriction -- 30 418 (File : System.Address; Line : Integer); 419 procedure Rcheck_PE_Non_Transportable_Actual -- 31 420 (File : System.Address; Line : Integer); 421 procedure Rcheck_SE_Empty_Storage_Pool -- 32 422 (File : System.Address; Line : Integer); 423 procedure Rcheck_SE_Explicit_Raise -- 33 424 (File : System.Address; Line : Integer); 425 procedure Rcheck_SE_Infinite_Recursion -- 34 426 (File : System.Address; Line : Integer); 427 procedure Rcheck_SE_Object_Too_Large -- 35 428 (File : System.Address; Line : Integer); 429 procedure Rcheck_PE_Stream_Operation_Not_Allowed -- 36 430 (File : System.Address; Line : Integer); 431 432 procedure Rcheck_PE_Finalize_Raised_Exception -- 23 433 (File : System.Address; Line : Integer); 434 -- This routine is separated out because it has quite different behavior 435 -- from the others. This is the "finalize/adjust raised exception". This 436 -- subprogram is always called with abort deferred, unlike all other 437 -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. 438 439 pragma Export (C, Rcheck_CE_Access_Check, 440 "__gnat_rcheck_CE_Access_Check"); 441 pragma Export (C, Rcheck_CE_Null_Access_Parameter, 442 "__gnat_rcheck_CE_Null_Access_Parameter"); 443 pragma Export (C, Rcheck_CE_Discriminant_Check, 444 "__gnat_rcheck_CE_Discriminant_Check"); 445 pragma Export (C, Rcheck_CE_Divide_By_Zero, 446 "__gnat_rcheck_CE_Divide_By_Zero"); 447 pragma Export (C, Rcheck_CE_Explicit_Raise, 448 "__gnat_rcheck_CE_Explicit_Raise"); 449 pragma Export (C, Rcheck_CE_Index_Check, 450 "__gnat_rcheck_CE_Index_Check"); 451 pragma Export (C, Rcheck_CE_Invalid_Data, 452 "__gnat_rcheck_CE_Invalid_Data"); 453 pragma Export (C, Rcheck_CE_Length_Check, 454 "__gnat_rcheck_CE_Length_Check"); 455 pragma Export (C, Rcheck_CE_Null_Exception_Id, 456 "__gnat_rcheck_CE_Null_Exception_Id"); 457 pragma Export (C, Rcheck_CE_Null_Not_Allowed, 458 "__gnat_rcheck_CE_Null_Not_Allowed"); 459 pragma Export (C, Rcheck_CE_Overflow_Check, 460 "__gnat_rcheck_CE_Overflow_Check"); 461 pragma Export (C, Rcheck_CE_Partition_Check, 462 "__gnat_rcheck_CE_Partition_Check"); 463 pragma Export (C, Rcheck_CE_Range_Check, 464 "__gnat_rcheck_CE_Range_Check"); 465 pragma Export (C, Rcheck_CE_Tag_Check, 466 "__gnat_rcheck_CE_Tag_Check"); 467 pragma Export (C, Rcheck_PE_Access_Before_Elaboration, 468 "__gnat_rcheck_PE_Access_Before_Elaboration"); 469 pragma Export (C, Rcheck_PE_Accessibility_Check, 470 "__gnat_rcheck_PE_Accessibility_Check"); 471 pragma Export (C, Rcheck_PE_Address_Of_Intrinsic, 472 "__gnat_rcheck_PE_Address_Of_Intrinsic"); 473 pragma Export (C, Rcheck_PE_Aliased_Parameters, 474 "__gnat_rcheck_PE_Aliased_Parameters"); 475 pragma Export (C, Rcheck_PE_All_Guards_Closed, 476 "__gnat_rcheck_PE_All_Guards_Closed"); 477 pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type, 478 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type"); 479 pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body, 480 "__gnat_rcheck_PE_Current_Task_In_Entry_Body"); 481 pragma Export (C, Rcheck_PE_Duplicated_Entry_Address, 482 "__gnat_rcheck_PE_Duplicated_Entry_Address"); 483 pragma Export (C, Rcheck_PE_Explicit_Raise, 484 "__gnat_rcheck_PE_Explicit_Raise"); 485 pragma Export (C, Rcheck_PE_Finalize_Raised_Exception, 486 "__gnat_rcheck_PE_Finalize_Raised_Exception"); 487 pragma Export (C, Rcheck_PE_Implicit_Return, 488 "__gnat_rcheck_PE_Implicit_Return"); 489 pragma Export (C, Rcheck_PE_Misaligned_Address_Value, 490 "__gnat_rcheck_PE_Misaligned_Address_Value"); 491 pragma Export (C, Rcheck_PE_Missing_Return, 492 "__gnat_rcheck_PE_Missing_Return"); 493 pragma Export (C, Rcheck_PE_Non_Transportable_Actual, 494 "__gnat_rcheck_PE_Non_Transportable_Actual"); 495 pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object, 496 "__gnat_rcheck_PE_Overlaid_Controlled_Object"); 497 pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation, 498 "__gnat_rcheck_PE_Potentially_Blocking_Operation"); 499 pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed, 500 "__gnat_rcheck_PE_Stream_Operation_Not_Allowed"); 501 pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called, 502 "__gnat_rcheck_PE_Stubbed_Subprogram_Called"); 503 pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction, 504 "__gnat_rcheck_PE_Unchecked_Union_Restriction"); 505 pragma Export (C, Rcheck_SE_Empty_Storage_Pool, 506 "__gnat_rcheck_SE_Empty_Storage_Pool"); 507 pragma Export (C, Rcheck_SE_Explicit_Raise, 508 "__gnat_rcheck_SE_Explicit_Raise"); 509 pragma Export (C, Rcheck_SE_Infinite_Recursion, 510 "__gnat_rcheck_SE_Infinite_Recursion"); 511 pragma Export (C, Rcheck_SE_Object_Too_Large, 512 "__gnat_rcheck_SE_Object_Too_Large"); 513 514 -- None of these procedures ever returns (they raise an exception). By 515 -- using pragma No_Return, we ensure that any junk code after the call, 516 -- such as normal return epilogue stuff, can be eliminated). 517 518 pragma No_Return (Rcheck_CE_Access_Check); 519 pragma No_Return (Rcheck_CE_Null_Access_Parameter); 520 pragma No_Return (Rcheck_CE_Discriminant_Check); 521 pragma No_Return (Rcheck_CE_Divide_By_Zero); 522 pragma No_Return (Rcheck_CE_Explicit_Raise); 523 pragma No_Return (Rcheck_CE_Index_Check); 524 pragma No_Return (Rcheck_CE_Invalid_Data); 525 pragma No_Return (Rcheck_CE_Length_Check); 526 pragma No_Return (Rcheck_CE_Null_Exception_Id); 527 pragma No_Return (Rcheck_CE_Null_Not_Allowed); 528 pragma No_Return (Rcheck_CE_Overflow_Check); 529 pragma No_Return (Rcheck_CE_Partition_Check); 530 pragma No_Return (Rcheck_CE_Range_Check); 531 pragma No_Return (Rcheck_CE_Tag_Check); 532 pragma No_Return (Rcheck_PE_Access_Before_Elaboration); 533 pragma No_Return (Rcheck_PE_Accessibility_Check); 534 pragma No_Return (Rcheck_PE_Address_Of_Intrinsic); 535 pragma No_Return (Rcheck_PE_Aliased_Parameters); 536 pragma No_Return (Rcheck_PE_All_Guards_Closed); 537 pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type); 538 pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body); 539 pragma No_Return (Rcheck_PE_Duplicated_Entry_Address); 540 pragma No_Return (Rcheck_PE_Explicit_Raise); 541 pragma No_Return (Rcheck_PE_Implicit_Return); 542 pragma No_Return (Rcheck_PE_Misaligned_Address_Value); 543 pragma No_Return (Rcheck_PE_Missing_Return); 544 pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); 545 pragma No_Return (Rcheck_PE_Non_Transportable_Actual); 546 pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); 547 pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed); 548 pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); 549 pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction); 550 pragma No_Return (Rcheck_PE_Finalize_Raised_Exception); 551 pragma No_Return (Rcheck_SE_Empty_Storage_Pool); 552 pragma No_Return (Rcheck_SE_Explicit_Raise); 553 pragma No_Return (Rcheck_SE_Infinite_Recursion); 554 pragma No_Return (Rcheck_SE_Object_Too_Large); 555 556 -- For compatibility with previous version of GNAT, to preserve bootstrap 557 558 procedure Rcheck_00 (File : System.Address; Line : Integer); 559 procedure Rcheck_01 (File : System.Address; Line : Integer); 560 procedure Rcheck_02 (File : System.Address; Line : Integer); 561 procedure Rcheck_03 (File : System.Address; Line : Integer); 562 procedure Rcheck_04 (File : System.Address; Line : Integer); 563 procedure Rcheck_05 (File : System.Address; Line : Integer); 564 procedure Rcheck_06 (File : System.Address; Line : Integer); 565 procedure Rcheck_07 (File : System.Address; Line : Integer); 566 procedure Rcheck_08 (File : System.Address; Line : Integer); 567 procedure Rcheck_09 (File : System.Address; Line : Integer); 568 procedure Rcheck_10 (File : System.Address; Line : Integer); 569 procedure Rcheck_11 (File : System.Address; Line : Integer); 570 procedure Rcheck_12 (File : System.Address; Line : Integer); 571 procedure Rcheck_13 (File : System.Address; Line : Integer); 572 procedure Rcheck_14 (File : System.Address; Line : Integer); 573 procedure Rcheck_15 (File : System.Address; Line : Integer); 574 procedure Rcheck_16 (File : System.Address; Line : Integer); 575 procedure Rcheck_17 (File : System.Address; Line : Integer); 576 procedure Rcheck_18 (File : System.Address; Line : Integer); 577 procedure Rcheck_19 (File : System.Address; Line : Integer); 578 procedure Rcheck_20 (File : System.Address; Line : Integer); 579 procedure Rcheck_21 (File : System.Address; Line : Integer); 580 procedure Rcheck_22 (File : System.Address; Line : Integer); 581 procedure Rcheck_23 (File : System.Address; Line : Integer); 582 procedure Rcheck_24 (File : System.Address; Line : Integer); 583 procedure Rcheck_25 (File : System.Address; Line : Integer); 584 procedure Rcheck_26 (File : System.Address; Line : Integer); 585 procedure Rcheck_27 (File : System.Address; Line : Integer); 586 procedure Rcheck_28 (File : System.Address; Line : Integer); 587 procedure Rcheck_29 (File : System.Address; Line : Integer); 588 procedure Rcheck_30 (File : System.Address; Line : Integer); 589 procedure Rcheck_31 (File : System.Address; Line : Integer); 590 procedure Rcheck_32 (File : System.Address; Line : Integer); 591 procedure Rcheck_33 (File : System.Address; Line : Integer); 592 procedure Rcheck_34 (File : System.Address; Line : Integer); 593 procedure Rcheck_35 (File : System.Address; Line : Integer); 594 procedure Rcheck_36 (File : System.Address; Line : Integer); 595 596 pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); 597 pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); 598 pragma Export (C, Rcheck_02, "__gnat_rcheck_02"); 599 pragma Export (C, Rcheck_03, "__gnat_rcheck_03"); 600 pragma Export (C, Rcheck_04, "__gnat_rcheck_04"); 601 pragma Export (C, Rcheck_05, "__gnat_rcheck_05"); 602 pragma Export (C, Rcheck_06, "__gnat_rcheck_06"); 603 pragma Export (C, Rcheck_07, "__gnat_rcheck_07"); 604 pragma Export (C, Rcheck_08, "__gnat_rcheck_08"); 605 pragma Export (C, Rcheck_09, "__gnat_rcheck_09"); 606 pragma Export (C, Rcheck_10, "__gnat_rcheck_10"); 607 pragma Export (C, Rcheck_11, "__gnat_rcheck_11"); 608 pragma Export (C, Rcheck_12, "__gnat_rcheck_12"); 609 pragma Export (C, Rcheck_13, "__gnat_rcheck_13"); 610 pragma Export (C, Rcheck_14, "__gnat_rcheck_14"); 611 pragma Export (C, Rcheck_15, "__gnat_rcheck_15"); 612 pragma Export (C, Rcheck_16, "__gnat_rcheck_16"); 613 pragma Export (C, Rcheck_17, "__gnat_rcheck_17"); 614 pragma Export (C, Rcheck_18, "__gnat_rcheck_18"); 615 pragma Export (C, Rcheck_19, "__gnat_rcheck_19"); 616 pragma Export (C, Rcheck_20, "__gnat_rcheck_20"); 617 pragma Export (C, Rcheck_21, "__gnat_rcheck_21"); 618 pragma Export (C, Rcheck_22, "__gnat_rcheck_22"); 619 pragma Export (C, Rcheck_23, "__gnat_rcheck_23"); 620 pragma Export (C, Rcheck_24, "__gnat_rcheck_24"); 621 pragma Export (C, Rcheck_25, "__gnat_rcheck_25"); 622 pragma Export (C, Rcheck_26, "__gnat_rcheck_26"); 623 pragma Export (C, Rcheck_27, "__gnat_rcheck_27"); 624 pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); 625 pragma Export (C, Rcheck_29, "__gnat_rcheck_29"); 626 pragma Export (C, Rcheck_30, "__gnat_rcheck_30"); 627 pragma Export (C, Rcheck_31, "__gnat_rcheck_31"); 628 pragma Export (C, Rcheck_32, "__gnat_rcheck_32"); 629 pragma Export (C, Rcheck_33, "__gnat_rcheck_33"); 630 pragma Export (C, Rcheck_34, "__gnat_rcheck_34"); 631 pragma Export (C, Rcheck_35, "__gnat_rcheck_35"); 632 pragma Export (C, Rcheck_36, "__gnat_rcheck_36"); 633 634 -- None of these procedures ever returns (they raise an exception). By 635 -- using pragma No_Return, we ensure that any junk code after the call, 636 -- such as normal return epilogue stuff, can be eliminated). 637 638 pragma No_Return (Rcheck_00); 639 pragma No_Return (Rcheck_01); 640 pragma No_Return (Rcheck_02); 641 pragma No_Return (Rcheck_03); 642 pragma No_Return (Rcheck_04); 643 pragma No_Return (Rcheck_05); 644 pragma No_Return (Rcheck_06); 645 pragma No_Return (Rcheck_07); 646 pragma No_Return (Rcheck_08); 647 pragma No_Return (Rcheck_09); 648 pragma No_Return (Rcheck_10); 649 pragma No_Return (Rcheck_11); 650 pragma No_Return (Rcheck_12); 651 pragma No_Return (Rcheck_13); 652 pragma No_Return (Rcheck_14); 653 pragma No_Return (Rcheck_15); 654 pragma No_Return (Rcheck_16); 655 pragma No_Return (Rcheck_17); 656 pragma No_Return (Rcheck_18); 657 pragma No_Return (Rcheck_19); 658 pragma No_Return (Rcheck_20); 659 pragma No_Return (Rcheck_21); 660 pragma No_Return (Rcheck_22); 661 pragma No_Return (Rcheck_23); 662 pragma No_Return (Rcheck_24); 663 pragma No_Return (Rcheck_25); 664 pragma No_Return (Rcheck_26); 665 pragma No_Return (Rcheck_27); 666 pragma No_Return (Rcheck_28); 667 pragma No_Return (Rcheck_29); 668 pragma No_Return (Rcheck_30); 669 pragma No_Return (Rcheck_32); 670 pragma No_Return (Rcheck_33); 671 pragma No_Return (Rcheck_34); 672 pragma No_Return (Rcheck_35); 673 pragma No_Return (Rcheck_36); 674 675 --------------------------------------------- 676 -- Reason Strings for Run-Time Check Calls -- 677 --------------------------------------------- 678 679 -- These strings are null-terminated and are used by Rcheck_nn. The 680 -- strings correspond to the definitions for Types.RT_Exception_Code. 681 682 use ASCII; 683 684 Rmsg_00 : constant String := "access check failed" & NUL; 685 Rmsg_01 : constant String := "access parameter is null" & NUL; 686 Rmsg_02 : constant String := "discriminant check failed" & NUL; 687 Rmsg_03 : constant String := "divide by zero" & NUL; 688 Rmsg_04 : constant String := "explicit raise" & NUL; 689 Rmsg_05 : constant String := "index check failed" & NUL; 690 Rmsg_06 : constant String := "invalid data" & NUL; 691 Rmsg_07 : constant String := "length check failed" & NUL; 692 Rmsg_08 : constant String := "null Exception_Id" & NUL; 693 Rmsg_09 : constant String := "null-exclusion check failed" & NUL; 694 Rmsg_10 : constant String := "overflow check failed" & NUL; 695 Rmsg_11 : constant String := "partition check failed" & NUL; 696 Rmsg_12 : constant String := "range check failed" & NUL; 697 Rmsg_13 : constant String := "tag check failed" & NUL; 698 Rmsg_14 : constant String := "access before elaboration" & NUL; 699 Rmsg_15 : constant String := "accessibility check failed" & NUL; 700 Rmsg_16 : constant String := "attempt to take address of" & 701 " intrinsic subprogram" & NUL; 702 Rmsg_17 : constant String := "aliased parameters" & NUL; 703 Rmsg_18 : constant String := "all guards closed" & NUL; 704 Rmsg_19 : constant String := "improper use of generic subtype" & 705 " with predicate" & NUL; 706 Rmsg_20 : constant String := "Current_Task referenced in entry" & 707 " body" & NUL; 708 Rmsg_21 : constant String := "duplicated entry address" & NUL; 709 Rmsg_22 : constant String := "explicit raise" & NUL; 710 Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL; 711 Rmsg_24 : constant String := "implicit return with No_Return" & NUL; 712 Rmsg_25 : constant String := "misaligned address value" & NUL; 713 Rmsg_26 : constant String := "missing return" & NUL; 714 Rmsg_27 : constant String := "overlaid controlled object" & NUL; 715 Rmsg_28 : constant String := "potentially blocking operation" & NUL; 716 Rmsg_29 : constant String := "stubbed subprogram called" & NUL; 717 Rmsg_30 : constant String := "unchecked union restriction" & NUL; 718 Rmsg_31 : constant String := "actual/returned class-wide" & 719 " value not transportable" & NUL; 720 Rmsg_32 : constant String := "empty storage pool" & NUL; 721 Rmsg_33 : constant String := "explicit raise" & NUL; 722 Rmsg_34 : constant String := "infinite recursion" & NUL; 723 Rmsg_35 : constant String := "object too large" & NUL; 724 Rmsg_36 : constant String := "stream operation not allowed" & NUL; 725 726 ----------------------- 727 -- Polling Interface -- 728 ----------------------- 729 730 type Unsigned is mod 2 ** 32; 731 732 Counter : Unsigned := 0; 733 pragma Warnings (Off, Counter); 734 -- This counter is provided for convenience. It can be used in Poll to 735 -- perform periodic but not systematic operations. 736 737 procedure Poll is separate; 738 -- The actual polling routine is separate, so that it can easily be 739 -- replaced with a target dependent version. 740 741 ------------------------------ 742 -- Current_Target_Exception -- 743 ------------------------------ 744 745 function Current_Target_Exception return Exception_Occurrence is 746 begin 747 return Null_Occurrence; 748 end Current_Target_Exception; 749 750 ------------------- 751 -- EId_To_String -- 752 ------------------- 753 754 function EId_To_String (X : Exception_Id) return String 755 renames Stream_Attributes.EId_To_String; 756 757 ------------------ 758 -- EO_To_String -- 759 ------------------ 760 761 -- We use the null string to represent the null occurrence, otherwise we 762 -- output the Untailored_Exception_Information string for the occurrence. 763 764 function EO_To_String (X : Exception_Occurrence) return String 765 renames Stream_Attributes.EO_To_String; 766 767 ------------------------ 768 -- Exception_Identity -- 769 ------------------------ 770 771 function Exception_Identity 772 (X : Exception_Occurrence) return Exception_Id 773 is 774 begin 775 -- Note that the following test used to be here for the original Ada 95 776 -- semantics, but these were modified by AI-241 to require returning 777 -- Null_Id instead of raising Constraint_Error. 778 779 -- if X.Id = Null_Id then 780 -- raise Constraint_Error; 781 -- end if; 782 783 return X.Id; 784 end Exception_Identity; 785 786 --------------------------- 787 -- Exception_Information -- 788 --------------------------- 789 790 function Exception_Information (X : Exception_Occurrence) return String is 791 begin 792 if X.Id = Null_Id then 793 raise Constraint_Error; 794 else 795 return Exception_Data.Exception_Information (X); 796 end if; 797 end Exception_Information; 798 799 ----------------------- 800 -- Exception_Message -- 801 ----------------------- 802 803 function Exception_Message (X : Exception_Occurrence) return String is 804 begin 805 if X.Id = Null_Id then 806 raise Constraint_Error; 807 end if; 808 809 return X.Msg (1 .. X.Msg_Length); 810 end Exception_Message; 811 812 -------------------- 813 -- Exception_Name -- 814 -------------------- 815 816 function Exception_Name (Id : Exception_Id) return String is 817 begin 818 if Id = null then 819 raise Constraint_Error; 820 end if; 821 822 return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); 823 end Exception_Name; 824 825 function Exception_Name (X : Exception_Occurrence) return String is 826 begin 827 return Exception_Name (X.Id); 828 end Exception_Name; 829 830 --------------------------- 831 -- Exception_Name_Simple -- 832 --------------------------- 833 834 function Exception_Name_Simple (X : Exception_Occurrence) return String is 835 Name : constant String := Exception_Name (X); 836 P : Natural; 837 838 begin 839 P := Name'Length; 840 while P > 1 loop 841 exit when Name (P - 1) = '.'; 842 P := P - 1; 843 end loop; 844 845 -- Return result making sure lower bound is 1 846 847 declare 848 subtype Rname is String (1 .. Name'Length - P + 1); 849 begin 850 return Rname (Name (P .. Name'Length)); 851 end; 852 end Exception_Name_Simple; 853 854 -------------------- 855 -- Exception_Data -- 856 -------------------- 857 858 package body Exception_Data is separate; 859 -- This package can be easily dummied out if we do not want the basic 860 -- support for exception messages (such as in Ada 83). 861 862 ---------------------- 863 -- Exception_Traces -- 864 ---------------------- 865 866 package body Exception_Traces is separate; 867 -- Depending on the underlying support for IO the implementation will 868 -- differ. Moreover we would like to dummy out this package in case we do 869 -- not want any exception tracing support. This is why this package is 870 -- separated. 871 872 ----------------------- 873 -- Stream Attributes -- 874 ----------------------- 875 876 package body Stream_Attributes is separate; 877 -- This package can be easily dummied out if we do not want the 878 -- support for streaming Exception_Ids and Exception_Occurrences. 879 880 ----------------------------- 881 -- Process_Raise_Exception -- 882 ----------------------------- 883 884 procedure Process_Raise_Exception (E : Exception_Id) is 885 pragma Inspection_Point (E); 886 -- This is so the debugger can reliably inspect the parameter 887 888 Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; 889 Excep : constant EOA := Get_Current_Excep.all; 890 891 procedure builtin_longjmp (buffer : Address; Flag : Integer); 892 pragma No_Return (builtin_longjmp); 893 pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp"); 894 895 begin 896 -- WARNING: There should be no exception handler for this body because 897 -- this would cause gigi to prepend a setup for a new jmpbuf to the 898 -- sequence of statements in case of built-in sjljl. We would then 899 -- always get this new buf in Jumpbuf_Ptr instead of the one for the 900 -- exception we are handling, which would completely break the whole 901 -- design of this procedure. 902 903 -- If the jump buffer pointer is non-null, transfer control using it. 904 -- Otherwise announce an unhandled exception (note that this means that 905 -- we have no finalizations to do other than at the outer level). 906 -- Perform the necessary notification tasks in both cases. 907 908 if Jumpbuf_Ptr /= Null_Address then 909 if not Excep.Exception_Raised then 910 Excep.Exception_Raised := True; 911 Exception_Traces.Notify_Handled_Exception (Excep); 912 end if; 913 914 builtin_longjmp (Jumpbuf_Ptr, 1); 915 916 else 917 Exception_Traces.Notify_Unhandled_Exception (Excep); 918 Exception_Traces.Unhandled_Exception_Terminate (Excep); 919 end if; 920 end Process_Raise_Exception; 921 922 ---------------------------- 923 -- Raise_Constraint_Error -- 924 ---------------------------- 925 926 procedure Raise_Constraint_Error 927 (File : System.Address; 928 Line : Integer) 929 is 930 begin 931 Raise_With_Location_And_Msg 932 (Constraint_Error_Def'Access, File, Line); 933 end Raise_Constraint_Error; 934 935 -------------------------------- 936 -- Raise_Constraint_Error_Msg -- 937 -------------------------------- 938 939 procedure Raise_Constraint_Error_Msg 940 (File : System.Address; 941 Line : Integer; 942 Msg : System.Address) 943 is 944 begin 945 Raise_With_Location_And_Msg 946 (Constraint_Error_Def'Access, File, Line, Msg); 947 end Raise_Constraint_Error_Msg; 948 949 ------------------------- 950 -- Raise_Current_Excep -- 951 ------------------------- 952 953 procedure Raise_Current_Excep (E : Exception_Id) is 954 955 pragma Inspection_Point (E); 956 -- This is so the debugger can reliably inspect the parameter when 957 -- inserting a breakpoint at the start of this procedure. 958 959 Id : Exception_Id := E; 960 pragma Volatile (Id); 961 pragma Warnings (Off, Id); 962 -- In order to provide support for breakpoints on unhandled exceptions, 963 -- the debugger will also need to be able to inspect the value of E from 964 -- another (inner) frame. So we need to make sure that if E is passed in 965 -- a register, its value is also spilled on stack. For this, we store 966 -- the parameter value in a local variable, and add a pragma Volatile to 967 -- make sure it is spilled. The pragma Warnings (Off) is needed because 968 -- the compiler knows that Id is not referenced and that this use of 969 -- pragma Volatile is peculiar. 970 971 begin 972 Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E)); 973 Process_Raise_Exception (E); 974 end Raise_Current_Excep; 975 976 --------------------- 977 -- Raise_Exception -- 978 --------------------- 979 980 procedure Raise_Exception 981 (E : Exception_Id; 982 Message : String := "") 983 is 984 EF : Exception_Id := E; 985 Excep : constant EOA := Get_Current_Excep.all; 986 begin 987 -- Raise CE if E = Null_ID (AI-446) 988 989 if E = null then 990 EF := Constraint_Error'Identity; 991 end if; 992 993 -- Go ahead and raise appropriate exception 994 995 Exception_Data.Set_Exception_Msg (Excep, EF, Message); 996 Abort_Defer.all; 997 Raise_Current_Excep (EF); 998 end Raise_Exception; 999 1000 ---------------------------- 1001 -- Raise_Exception_Always -- 1002 ---------------------------- 1003 1004 procedure Raise_Exception_Always 1005 (E : Exception_Id; 1006 Message : String := "") 1007 is 1008 Excep : constant EOA := Get_Current_Excep.all; 1009 begin 1010 Exception_Data.Set_Exception_Msg (Excep, E, Message); 1011 Abort_Defer.all; 1012 Raise_Current_Excep (E); 1013 end Raise_Exception_Always; 1014 1015 ------------------------------ 1016 -- Raise_Exception_No_Defer -- 1017 ------------------------------ 1018 1019 procedure Raise_Exception_No_Defer 1020 (E : Exception_Id; 1021 Message : String := "") 1022 is 1023 Excep : constant EOA := Get_Current_Excep.all; 1024 begin 1025 Exception_Data.Set_Exception_Msg (Excep, E, Message); 1026 1027 -- Do not call Abort_Defer.all, as specified by the spec 1028 1029 Raise_Current_Excep (E); 1030 end Raise_Exception_No_Defer; 1031 1032 ------------------------------------- 1033 -- Raise_From_Controlled_Operation -- 1034 ------------------------------------- 1035 1036 procedure Raise_From_Controlled_Operation 1037 (X : Ada.Exceptions.Exception_Occurrence) 1038 is 1039 Prefix : constant String := "adjust/finalize raised "; 1040 Orig_Msg : constant String := Exception_Message (X); 1041 Orig_Prefix_Length : constant Natural := 1042 Integer'Min (Prefix'Length, Orig_Msg'Length); 1043 Orig_Prefix : String renames Orig_Msg 1044 (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); 1045 begin 1046 -- Message already has proper prefix, just re-reraise 1047 1048 if Orig_Prefix = Prefix then 1049 Raise_Exception_No_Defer 1050 (E => Program_Error'Identity, 1051 Message => Orig_Msg); 1052 1053 else 1054 declare 1055 New_Msg : constant String := Prefix & Exception_Name (X); 1056 1057 begin 1058 -- No message present, just provide our own 1059 1060 if Orig_Msg = "" then 1061 Raise_Exception_No_Defer 1062 (E => Program_Error'Identity, 1063 Message => New_Msg); 1064 1065 -- Message present, add informational prefix 1066 1067 else 1068 Raise_Exception_No_Defer 1069 (E => Program_Error'Identity, 1070 Message => New_Msg & ": " & Orig_Msg); 1071 end if; 1072 end; 1073 end if; 1074 end Raise_From_Controlled_Operation; 1075 1076 ------------------------------- 1077 -- Raise_From_Signal_Handler -- 1078 ------------------------------- 1079 1080 procedure Raise_From_Signal_Handler 1081 (E : Exception_Id; 1082 M : System.Address) 1083 is 1084 Excep : constant EOA := Get_Current_Excep.all; 1085 begin 1086 Exception_Data.Set_Exception_C_Msg (Excep, E, M); 1087 Abort_Defer.all; 1088 Process_Raise_Exception (E); 1089 end Raise_From_Signal_Handler; 1090 1091 ------------------------- 1092 -- Raise_Program_Error -- 1093 ------------------------- 1094 1095 procedure Raise_Program_Error 1096 (File : System.Address; 1097 Line : Integer) 1098 is 1099 begin 1100 Raise_With_Location_And_Msg 1101 (Program_Error_Def'Access, File, Line); 1102 end Raise_Program_Error; 1103 1104 ----------------------------- 1105 -- Raise_Program_Error_Msg -- 1106 ----------------------------- 1107 1108 procedure Raise_Program_Error_Msg 1109 (File : System.Address; 1110 Line : Integer; 1111 Msg : System.Address) 1112 is 1113 begin 1114 Raise_With_Location_And_Msg 1115 (Program_Error_Def'Access, File, Line, Msg); 1116 end Raise_Program_Error_Msg; 1117 1118 ------------------------- 1119 -- Raise_Storage_Error -- 1120 ------------------------- 1121 1122 procedure Raise_Storage_Error 1123 (File : System.Address; 1124 Line : Integer) 1125 is 1126 begin 1127 Raise_With_Location_And_Msg 1128 (Storage_Error_Def'Access, File, Line); 1129 end Raise_Storage_Error; 1130 1131 ----------------------------- 1132 -- Raise_Storage_Error_Msg -- 1133 ----------------------------- 1134 1135 procedure Raise_Storage_Error_Msg 1136 (File : System.Address; 1137 Line : Integer; 1138 Msg : System.Address) 1139 is 1140 begin 1141 Raise_With_Location_And_Msg 1142 (Storage_Error_Def'Access, File, Line, Msg); 1143 end Raise_Storage_Error_Msg; 1144 1145 --------------------------------- 1146 -- Raise_With_Location_And_Msg -- 1147 --------------------------------- 1148 1149 procedure Raise_With_Location_And_Msg 1150 (E : Exception_Id; 1151 F : System.Address; 1152 L : Integer; 1153 M : System.Address := System.Null_Address) 1154 is 1155 Excep : constant EOA := Get_Current_Excep.all; 1156 begin 1157 Exception_Data.Set_Exception_C_Msg (Excep, E, F, L, Msg2 => M); 1158 Abort_Defer.all; 1159 Raise_Current_Excep (E); 1160 end Raise_With_Location_And_Msg; 1161 1162 -------------------- 1163 -- Raise_With_Msg -- 1164 -------------------- 1165 1166 procedure Raise_With_Msg (E : Exception_Id) is 1167 Excep : constant EOA := Get_Current_Excep.all; 1168 1169 begin 1170 Excep.Exception_Raised := False; 1171 Excep.Id := E; 1172 Excep.Num_Tracebacks := 0; 1173 Excep.Pid := Local_Partition_ID; 1174 Abort_Defer.all; 1175 Raise_Current_Excep (E); 1176 end Raise_With_Msg; 1177 1178 ----------------------------------------- 1179 -- Calls to Run-Time Check Subprograms -- 1180 ----------------------------------------- 1181 1182 procedure Rcheck_CE_Access_Check 1183 (File : System.Address; Line : Integer) 1184 is 1185 begin 1186 Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address); 1187 end Rcheck_CE_Access_Check; 1188 1189 procedure Rcheck_CE_Null_Access_Parameter 1190 (File : System.Address; Line : Integer) 1191 is 1192 begin 1193 Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address); 1194 end Rcheck_CE_Null_Access_Parameter; 1195 1196 procedure Rcheck_CE_Discriminant_Check 1197 (File : System.Address; Line : Integer) 1198 is 1199 begin 1200 Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address); 1201 end Rcheck_CE_Discriminant_Check; 1202 1203 procedure Rcheck_CE_Divide_By_Zero 1204 (File : System.Address; Line : Integer) 1205 is 1206 begin 1207 Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address); 1208 end Rcheck_CE_Divide_By_Zero; 1209 1210 procedure Rcheck_CE_Explicit_Raise 1211 (File : System.Address; Line : Integer) 1212 is 1213 begin 1214 Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address); 1215 end Rcheck_CE_Explicit_Raise; 1216 1217 procedure Rcheck_CE_Index_Check 1218 (File : System.Address; Line : Integer) 1219 is 1220 begin 1221 Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address); 1222 end Rcheck_CE_Index_Check; 1223 1224 procedure Rcheck_CE_Invalid_Data 1225 (File : System.Address; Line : Integer) 1226 is 1227 begin 1228 Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address); 1229 end Rcheck_CE_Invalid_Data; 1230 1231 procedure Rcheck_CE_Length_Check 1232 (File : System.Address; Line : Integer) 1233 is 1234 begin 1235 Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address); 1236 end Rcheck_CE_Length_Check; 1237 1238 procedure Rcheck_CE_Null_Exception_Id 1239 (File : System.Address; Line : Integer) 1240 is 1241 begin 1242 Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address); 1243 end Rcheck_CE_Null_Exception_Id; 1244 1245 procedure Rcheck_CE_Null_Not_Allowed 1246 (File : System.Address; Line : Integer) 1247 is 1248 begin 1249 Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address); 1250 end Rcheck_CE_Null_Not_Allowed; 1251 1252 procedure Rcheck_CE_Overflow_Check 1253 (File : System.Address; Line : Integer) 1254 is 1255 begin 1256 Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address); 1257 end Rcheck_CE_Overflow_Check; 1258 1259 procedure Rcheck_CE_Partition_Check 1260 (File : System.Address; Line : Integer) 1261 is 1262 begin 1263 Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address); 1264 end Rcheck_CE_Partition_Check; 1265 1266 procedure Rcheck_CE_Range_Check 1267 (File : System.Address; Line : Integer) 1268 is 1269 begin 1270 Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address); 1271 end Rcheck_CE_Range_Check; 1272 1273 procedure Rcheck_CE_Tag_Check 1274 (File : System.Address; Line : Integer) 1275 is 1276 begin 1277 Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address); 1278 end Rcheck_CE_Tag_Check; 1279 1280 procedure Rcheck_PE_Access_Before_Elaboration 1281 (File : System.Address; Line : Integer) 1282 is 1283 begin 1284 Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); 1285 end Rcheck_PE_Access_Before_Elaboration; 1286 1287 procedure Rcheck_PE_Accessibility_Check 1288 (File : System.Address; Line : Integer) 1289 is 1290 begin 1291 Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); 1292 end Rcheck_PE_Accessibility_Check; 1293 1294 procedure Rcheck_PE_Address_Of_Intrinsic 1295 (File : System.Address; Line : Integer) 1296 is 1297 begin 1298 Raise_Program_Error_Msg (File, Line, Rmsg_16'Address); 1299 end Rcheck_PE_Address_Of_Intrinsic; 1300 1301 procedure Rcheck_PE_Aliased_Parameters 1302 (File : System.Address; Line : Integer) 1303 is 1304 begin 1305 Raise_Program_Error_Msg (File, Line, Rmsg_17'Address); 1306 end Rcheck_PE_Aliased_Parameters; 1307 1308 procedure Rcheck_PE_All_Guards_Closed 1309 (File : System.Address; Line : Integer) 1310 is 1311 begin 1312 Raise_Program_Error_Msg (File, Line, Rmsg_18'Address); 1313 end Rcheck_PE_All_Guards_Closed; 1314 1315 procedure Rcheck_PE_Bad_Predicated_Generic_Type 1316 (File : System.Address; Line : Integer) 1317 is 1318 begin 1319 Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); 1320 end Rcheck_PE_Bad_Predicated_Generic_Type; 1321 1322 procedure Rcheck_PE_Current_Task_In_Entry_Body 1323 (File : System.Address; Line : Integer) 1324 is 1325 begin 1326 Raise_Program_Error_Msg (File, Line, Rmsg_20'Address); 1327 end Rcheck_PE_Current_Task_In_Entry_Body; 1328 1329 procedure Rcheck_PE_Duplicated_Entry_Address 1330 (File : System.Address; Line : Integer) 1331 is 1332 begin 1333 Raise_Program_Error_Msg (File, Line, Rmsg_21'Address); 1334 end Rcheck_PE_Duplicated_Entry_Address; 1335 1336 procedure Rcheck_PE_Explicit_Raise 1337 (File : System.Address; Line : Integer) 1338 is 1339 begin 1340 Raise_Program_Error_Msg (File, Line, Rmsg_22'Address); 1341 end Rcheck_PE_Explicit_Raise; 1342 1343 procedure Rcheck_PE_Implicit_Return 1344 (File : System.Address; Line : Integer) 1345 is 1346 begin 1347 Raise_Program_Error_Msg (File, Line, Rmsg_24'Address); 1348 end Rcheck_PE_Implicit_Return; 1349 1350 procedure Rcheck_PE_Misaligned_Address_Value 1351 (File : System.Address; Line : Integer) 1352 is 1353 begin 1354 Raise_Program_Error_Msg (File, Line, Rmsg_25'Address); 1355 end Rcheck_PE_Misaligned_Address_Value; 1356 1357 procedure Rcheck_PE_Missing_Return 1358 (File : System.Address; Line : Integer) 1359 is 1360 begin 1361 Raise_Program_Error_Msg (File, Line, Rmsg_26'Address); 1362 end Rcheck_PE_Missing_Return; 1363 1364 procedure Rcheck_PE_Overlaid_Controlled_Object 1365 (File : System.Address; Line : Integer) 1366 is 1367 begin 1368 Raise_Program_Error_Msg (File, Line, Rmsg_27'Address); 1369 end Rcheck_PE_Overlaid_Controlled_Object; 1370 1371 procedure Rcheck_PE_Potentially_Blocking_Operation 1372 (File : System.Address; Line : Integer) 1373 is 1374 begin 1375 Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); 1376 end Rcheck_PE_Potentially_Blocking_Operation; 1377 1378 procedure Rcheck_PE_Stubbed_Subprogram_Called 1379 (File : System.Address; Line : Integer) 1380 is 1381 begin 1382 Raise_Program_Error_Msg (File, Line, Rmsg_29'Address); 1383 end Rcheck_PE_Stubbed_Subprogram_Called; 1384 1385 procedure Rcheck_PE_Unchecked_Union_Restriction 1386 (File : System.Address; Line : Integer) 1387 is 1388 begin 1389 Raise_Program_Error_Msg (File, Line, Rmsg_30'Address); 1390 end Rcheck_PE_Unchecked_Union_Restriction; 1391 1392 procedure Rcheck_PE_Non_Transportable_Actual 1393 (File : System.Address; Line : Integer) 1394 is 1395 begin 1396 Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); 1397 end Rcheck_PE_Non_Transportable_Actual; 1398 1399 procedure Rcheck_SE_Empty_Storage_Pool 1400 (File : System.Address; Line : Integer) 1401 is 1402 begin 1403 Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address); 1404 end Rcheck_SE_Empty_Storage_Pool; 1405 1406 procedure Rcheck_SE_Explicit_Raise 1407 (File : System.Address; Line : Integer) 1408 is 1409 begin 1410 Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address); 1411 end Rcheck_SE_Explicit_Raise; 1412 1413 procedure Rcheck_SE_Infinite_Recursion 1414 (File : System.Address; Line : Integer) 1415 is 1416 begin 1417 Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address); 1418 end Rcheck_SE_Infinite_Recursion; 1419 1420 procedure Rcheck_SE_Object_Too_Large 1421 (File : System.Address; Line : Integer) 1422 is 1423 begin 1424 Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address); 1425 end Rcheck_SE_Object_Too_Large; 1426 1427 procedure Rcheck_PE_Stream_Operation_Not_Allowed 1428 (File : System.Address; Line : Integer) 1429 is 1430 begin 1431 Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); 1432 end Rcheck_PE_Stream_Operation_Not_Allowed; 1433 1434 procedure Rcheck_PE_Finalize_Raised_Exception 1435 (File : System.Address; Line : Integer) 1436 is 1437 E : constant Exception_Id := Program_Error_Def'Access; 1438 Excep : constant EOA := Get_Current_Excep.all; 1439 1440 begin 1441 -- This is "finalize/adjust raised exception". This subprogram is always 1442 -- called with abort deferred, unlike all other Rcheck_* subprograms, 1443 -- itneeds to call Raise_Exception_No_Defer. 1444 1445 -- This is consistent with Raise_From_Controlled_Operation 1446 1447 Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0, 1448 Rmsg_23'Address); 1449 Raise_Current_Excep (E); 1450 end Rcheck_PE_Finalize_Raised_Exception; 1451 1452 procedure Rcheck_00 (File : System.Address; Line : Integer) 1453 renames Rcheck_CE_Access_Check; 1454 procedure Rcheck_01 (File : System.Address; Line : Integer) 1455 renames Rcheck_CE_Null_Access_Parameter; 1456 procedure Rcheck_02 (File : System.Address; Line : Integer) 1457 renames Rcheck_CE_Discriminant_Check; 1458 procedure Rcheck_03 (File : System.Address; Line : Integer) 1459 renames Rcheck_CE_Divide_By_Zero; 1460 procedure Rcheck_04 (File : System.Address; Line : Integer) 1461 renames Rcheck_CE_Explicit_Raise; 1462 procedure Rcheck_05 (File : System.Address; Line : Integer) 1463 renames Rcheck_CE_Index_Check; 1464 procedure Rcheck_06 (File : System.Address; Line : Integer) 1465 renames Rcheck_CE_Invalid_Data; 1466 procedure Rcheck_07 (File : System.Address; Line : Integer) 1467 renames Rcheck_CE_Length_Check; 1468 procedure Rcheck_08 (File : System.Address; Line : Integer) 1469 renames Rcheck_CE_Null_Exception_Id; 1470 procedure Rcheck_09 (File : System.Address; Line : Integer) 1471 renames Rcheck_CE_Null_Not_Allowed; 1472 procedure Rcheck_10 (File : System.Address; Line : Integer) 1473 renames Rcheck_CE_Overflow_Check; 1474 procedure Rcheck_11 (File : System.Address; Line : Integer) 1475 renames Rcheck_CE_Partition_Check; 1476 procedure Rcheck_12 (File : System.Address; Line : Integer) 1477 renames Rcheck_CE_Range_Check; 1478 procedure Rcheck_13 (File : System.Address; Line : Integer) 1479 renames Rcheck_CE_Tag_Check; 1480 procedure Rcheck_14 (File : System.Address; Line : Integer) 1481 renames Rcheck_PE_Access_Before_Elaboration; 1482 procedure Rcheck_15 (File : System.Address; Line : Integer) 1483 renames Rcheck_PE_Accessibility_Check; 1484 procedure Rcheck_16 (File : System.Address; Line : Integer) 1485 renames Rcheck_PE_Address_Of_Intrinsic; 1486 procedure Rcheck_17 (File : System.Address; Line : Integer) 1487 renames Rcheck_PE_Aliased_Parameters; 1488 procedure Rcheck_18 (File : System.Address; Line : Integer) 1489 renames Rcheck_PE_All_Guards_Closed; 1490 procedure Rcheck_19 (File : System.Address; Line : Integer) 1491 renames Rcheck_PE_Bad_Predicated_Generic_Type; 1492 procedure Rcheck_20 (File : System.Address; Line : Integer) 1493 renames Rcheck_PE_Current_Task_In_Entry_Body; 1494 procedure Rcheck_21 (File : System.Address; Line : Integer) 1495 renames Rcheck_PE_Duplicated_Entry_Address; 1496 procedure Rcheck_22 (File : System.Address; Line : Integer) 1497 renames Rcheck_PE_Explicit_Raise; 1498 procedure Rcheck_23 (File : System.Address; Line : Integer) 1499 renames Rcheck_PE_Finalize_Raised_Exception; 1500 procedure Rcheck_24 (File : System.Address; Line : Integer) 1501 renames Rcheck_PE_Implicit_Return; 1502 procedure Rcheck_25 (File : System.Address; Line : Integer) 1503 renames Rcheck_PE_Misaligned_Address_Value; 1504 procedure Rcheck_26 (File : System.Address; Line : Integer) 1505 renames Rcheck_PE_Missing_Return; 1506 procedure Rcheck_27 (File : System.Address; Line : Integer) 1507 renames Rcheck_PE_Overlaid_Controlled_Object; 1508 procedure Rcheck_28 (File : System.Address; Line : Integer) 1509 renames Rcheck_PE_Potentially_Blocking_Operation; 1510 procedure Rcheck_29 (File : System.Address; Line : Integer) 1511 renames Rcheck_PE_Stubbed_Subprogram_Called; 1512 procedure Rcheck_30 (File : System.Address; Line : Integer) 1513 renames Rcheck_PE_Unchecked_Union_Restriction; 1514 procedure Rcheck_31 (File : System.Address; Line : Integer) 1515 renames Rcheck_PE_Non_Transportable_Actual; 1516 procedure Rcheck_32 (File : System.Address; Line : Integer) 1517 renames Rcheck_SE_Empty_Storage_Pool; 1518 procedure Rcheck_33 (File : System.Address; Line : Integer) 1519 renames Rcheck_SE_Explicit_Raise; 1520 procedure Rcheck_34 (File : System.Address; Line : Integer) 1521 renames Rcheck_SE_Infinite_Recursion; 1522 procedure Rcheck_35 (File : System.Address; Line : Integer) 1523 renames Rcheck_SE_Object_Too_Large; 1524 procedure Rcheck_36 (File : System.Address; Line : Integer) 1525 renames Rcheck_PE_Stream_Operation_Not_Allowed; 1526 1527 ------------- 1528 -- Reraise -- 1529 ------------- 1530 1531 procedure Reraise is 1532 Excep : constant EOA := Get_Current_Excep.all; 1533 1534 begin 1535 Abort_Defer.all; 1536 Raise_Current_Excep (Excep.Id); 1537 end Reraise; 1538 1539 -------------------------------------- 1540 -- Reraise_Library_Exception_If_Any -- 1541 -------------------------------------- 1542 1543 procedure Reraise_Library_Exception_If_Any is 1544 LE : Exception_Occurrence; 1545 begin 1546 if Library_Exception_Set then 1547 LE := Library_Exception; 1548 Raise_From_Controlled_Operation (LE); 1549 end if; 1550 end Reraise_Library_Exception_If_Any; 1551 1552 ------------------------ 1553 -- Reraise_Occurrence -- 1554 ------------------------ 1555 1556 procedure Reraise_Occurrence (X : Exception_Occurrence) is 1557 begin 1558 if X.Id /= null then 1559 Abort_Defer.all; 1560 Save_Occurrence (Get_Current_Excep.all.all, X); 1561 Raise_Current_Excep (X.Id); 1562 end if; 1563 end Reraise_Occurrence; 1564 1565 ------------------------------- 1566 -- Reraise_Occurrence_Always -- 1567 ------------------------------- 1568 1569 procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is 1570 begin 1571 Abort_Defer.all; 1572 Save_Occurrence (Get_Current_Excep.all.all, X); 1573 Raise_Current_Excep (X.Id); 1574 end Reraise_Occurrence_Always; 1575 1576 --------------------------------- 1577 -- Reraise_Occurrence_No_Defer -- 1578 --------------------------------- 1579 1580 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is 1581 begin 1582 Save_Occurrence (Get_Current_Excep.all.all, X); 1583 Raise_Current_Excep (X.Id); 1584 end Reraise_Occurrence_No_Defer; 1585 1586 --------------------- 1587 -- Save_Occurrence -- 1588 --------------------- 1589 1590 procedure Save_Occurrence 1591 (Target : out Exception_Occurrence; 1592 Source : Exception_Occurrence) 1593 is 1594 begin 1595 Target.Id := Source.Id; 1596 Target.Msg_Length := Source.Msg_Length; 1597 Target.Num_Tracebacks := Source.Num_Tracebacks; 1598 Target.Pid := Source.Pid; 1599 1600 Target.Msg (1 .. Target.Msg_Length) := 1601 Source.Msg (1 .. Target.Msg_Length); 1602 1603 Target.Tracebacks (1 .. Target.Num_Tracebacks) := 1604 Source.Tracebacks (1 .. Target.Num_Tracebacks); 1605 end Save_Occurrence; 1606 1607 function Save_Occurrence (Source : Exception_Occurrence) return EOA is 1608 Target : constant EOA := new Exception_Occurrence; 1609 begin 1610 Save_Occurrence (Target.all, Source); 1611 return Target; 1612 end Save_Occurrence; 1613 1614 ------------------- 1615 -- String_To_EId -- 1616 ------------------- 1617 1618 function String_To_EId (S : String) return Exception_Id 1619 renames Stream_Attributes.String_To_EId; 1620 1621 ------------------ 1622 -- String_To_EO -- 1623 ------------------ 1624 1625 function String_To_EO (S : String) return Exception_Occurrence 1626 renames Stream_Attributes.String_To_EO; 1627 1628 --------------- 1629 -- To_Stderr -- 1630 --------------- 1631 1632 procedure To_Stderr (C : Character) is 1633 type int is new Integer; 1634 1635 procedure put_char_stderr (C : int); 1636 pragma Import (C, put_char_stderr, "put_char_stderr"); 1637 1638 begin 1639 put_char_stderr (Character'Pos (C)); 1640 end To_Stderr; 1641 1642 procedure To_Stderr (S : String) is 1643 begin 1644 for J in S'Range loop 1645 if S (J) /= ASCII.CR then 1646 To_Stderr (S (J)); 1647 end if; 1648 end loop; 1649 end To_Stderr; 1650 1651 ------------------------- 1652 -- Transfer_Occurrence -- 1653 ------------------------- 1654 1655 procedure Transfer_Occurrence 1656 (Target : Exception_Occurrence_Access; 1657 Source : Exception_Occurrence) 1658 is 1659 begin 1660 Save_Occurrence (Target.all, Source); 1661 end Transfer_Occurrence; 1662 1663 ------------------------ 1664 -- Triggered_By_Abort -- 1665 ------------------------ 1666 1667 function Triggered_By_Abort return Boolean is 1668 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; 1669 begin 1670 return Ex /= null 1671 and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; 1672 end Triggered_By_Abort; 1673 1674end Ada.Exceptions; 1675