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