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