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-2012, 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; 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_All_Guards_Closed 398 (File : System.Address; Line : Integer); 399 procedure Rcheck_PE_Bad_Predicated_Generic_Type 400 (File : System.Address; Line : Integer); 401 procedure Rcheck_PE_Current_Task_In_Entry_Body 402 (File : System.Address; Line : Integer); 403 procedure Rcheck_PE_Duplicated_Entry_Address 404 (File : System.Address; Line : Integer); 405 procedure Rcheck_PE_Explicit_Raise 406 (File : System.Address; Line : Integer); 407 procedure Rcheck_PE_Implicit_Return 408 (File : System.Address; Line : Integer); 409 procedure Rcheck_PE_Misaligned_Address_Value 410 (File : System.Address; Line : Integer); 411 procedure Rcheck_PE_Missing_Return 412 (File : System.Address; Line : Integer); 413 procedure Rcheck_PE_Overlaid_Controlled_Object 414 (File : System.Address; Line : Integer); 415 procedure Rcheck_PE_Potentially_Blocking_Operation 416 (File : System.Address; Line : Integer); 417 procedure Rcheck_PE_Stubbed_Subprogram_Called 418 (File : System.Address; Line : Integer); 419 procedure Rcheck_PE_Unchecked_Union_Restriction 420 (File : System.Address; Line : Integer); 421 procedure Rcheck_PE_Non_Transportable_Actual 422 (File : System.Address; Line : Integer); 423 procedure Rcheck_SE_Empty_Storage_Pool 424 (File : System.Address; Line : Integer); 425 procedure Rcheck_SE_Explicit_Raise 426 (File : System.Address; Line : Integer); 427 procedure Rcheck_SE_Infinite_Recursion 428 (File : System.Address; Line : Integer); 429 procedure Rcheck_SE_Object_Too_Large 430 (File : System.Address; Line : Integer); 431 432 procedure Rcheck_PE_Finalize_Raised_Exception 433 (File : System.Address; Line : Integer); 434 -- This routine is separated out because it has quite different behavior 435 -- from the others. This is the "finalize/adjust raised exception". This 436 -- subprogram is always called with abort deferred, unlike all other 437 -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer. 438 439 pragma Export (C, Rcheck_CE_Access_Check, 440 "__gnat_rcheck_CE_Access_Check"); 441 pragma Export (C, Rcheck_CE_Null_Access_Parameter, 442 "__gnat_rcheck_CE_Null_Access_Parameter"); 443 pragma Export (C, Rcheck_CE_Discriminant_Check, 444 "__gnat_rcheck_CE_Discriminant_Check"); 445 pragma Export (C, Rcheck_CE_Divide_By_Zero, 446 "__gnat_rcheck_CE_Divide_By_Zero"); 447 pragma Export (C, Rcheck_CE_Explicit_Raise, 448 "__gnat_rcheck_CE_Explicit_Raise"); 449 pragma Export (C, Rcheck_CE_Index_Check, 450 "__gnat_rcheck_CE_Index_Check"); 451 pragma Export (C, Rcheck_CE_Invalid_Data, 452 "__gnat_rcheck_CE_Invalid_Data"); 453 pragma Export (C, Rcheck_CE_Length_Check, 454 "__gnat_rcheck_CE_Length_Check"); 455 pragma Export (C, Rcheck_CE_Null_Exception_Id, 456 "__gnat_rcheck_CE_Null_Exception_Id"); 457 pragma Export (C, Rcheck_CE_Null_Not_Allowed, 458 "__gnat_rcheck_CE_Null_Not_Allowed"); 459 pragma Export (C, Rcheck_CE_Overflow_Check, 460 "__gnat_rcheck_CE_Overflow_Check"); 461 pragma Export (C, Rcheck_CE_Partition_Check, 462 "__gnat_rcheck_CE_Partition_Check"); 463 pragma Export (C, Rcheck_CE_Range_Check, 464 "__gnat_rcheck_CE_Range_Check"); 465 pragma Export (C, Rcheck_CE_Tag_Check, 466 "__gnat_rcheck_CE_Tag_Check"); 467 pragma Export (C, Rcheck_PE_Access_Before_Elaboration, 468 "__gnat_rcheck_PE_Access_Before_Elaboration"); 469 pragma Export (C, Rcheck_PE_Accessibility_Check, 470 "__gnat_rcheck_PE_Accessibility_Check"); 471 pragma Export (C, Rcheck_PE_Address_Of_Intrinsic, 472 "__gnat_rcheck_PE_Address_Of_Intrinsic"); 473 pragma Export (C, Rcheck_PE_All_Guards_Closed, 474 "__gnat_rcheck_PE_All_Guards_Closed"); 475 pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type, 476 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type"); 477 pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body, 478 "__gnat_rcheck_PE_Current_Task_In_Entry_Body"); 479 pragma Export (C, Rcheck_PE_Duplicated_Entry_Address, 480 "__gnat_rcheck_PE_Duplicated_Entry_Address"); 481 pragma Export (C, Rcheck_PE_Explicit_Raise, 482 "__gnat_rcheck_PE_Explicit_Raise"); 483 pragma Export (C, Rcheck_PE_Finalize_Raised_Exception, 484 "__gnat_rcheck_PE_Finalize_Raised_Exception"); 485 pragma Export (C, Rcheck_PE_Implicit_Return, 486 "__gnat_rcheck_PE_Implicit_Return"); 487 pragma Export (C, Rcheck_PE_Misaligned_Address_Value, 488 "__gnat_rcheck_PE_Misaligned_Address_Value"); 489 pragma Export (C, Rcheck_PE_Missing_Return, 490 "__gnat_rcheck_PE_Missing_Return"); 491 pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object, 492 "__gnat_rcheck_PE_Overlaid_Controlled_Object"); 493 pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation, 494 "__gnat_rcheck_PE_Potentially_Blocking_Operation"); 495 pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called, 496 "__gnat_rcheck_PE_Stubbed_Subprogram_Called"); 497 pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction, 498 "__gnat_rcheck_PE_Unchecked_Union_Restriction"); 499 pragma Export (C, Rcheck_PE_Non_Transportable_Actual, 500 "__gnat_rcheck_PE_Non_Transportable_Actual"); 501 pragma Export (C, Rcheck_SE_Empty_Storage_Pool, 502 "__gnat_rcheck_SE_Empty_Storage_Pool"); 503 pragma Export (C, Rcheck_SE_Explicit_Raise, 504 "__gnat_rcheck_SE_Explicit_Raise"); 505 pragma Export (C, Rcheck_SE_Infinite_Recursion, 506 "__gnat_rcheck_SE_Infinite_Recursion"); 507 pragma Export (C, Rcheck_SE_Object_Too_Large, 508 "__gnat_rcheck_SE_Object_Too_Large"); 509 510 -- None of these procedures ever returns (they raise an exception!). By 511 -- using pragma No_Return, we ensure that any junk code after the call, 512 -- such as normal return epilog stuff, can be eliminated). 513 514 pragma No_Return (Rcheck_CE_Access_Check); 515 pragma No_Return (Rcheck_CE_Null_Access_Parameter); 516 pragma No_Return (Rcheck_CE_Discriminant_Check); 517 pragma No_Return (Rcheck_CE_Divide_By_Zero); 518 pragma No_Return (Rcheck_CE_Explicit_Raise); 519 pragma No_Return (Rcheck_CE_Index_Check); 520 pragma No_Return (Rcheck_CE_Invalid_Data); 521 pragma No_Return (Rcheck_CE_Length_Check); 522 pragma No_Return (Rcheck_CE_Null_Exception_Id); 523 pragma No_Return (Rcheck_CE_Null_Not_Allowed); 524 pragma No_Return (Rcheck_CE_Overflow_Check); 525 pragma No_Return (Rcheck_CE_Partition_Check); 526 pragma No_Return (Rcheck_CE_Range_Check); 527 pragma No_Return (Rcheck_CE_Tag_Check); 528 pragma No_Return (Rcheck_PE_Access_Before_Elaboration); 529 pragma No_Return (Rcheck_PE_Accessibility_Check); 530 pragma No_Return (Rcheck_PE_Address_Of_Intrinsic); 531 pragma No_Return (Rcheck_PE_All_Guards_Closed); 532 pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type); 533 pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body); 534 pragma No_Return (Rcheck_PE_Duplicated_Entry_Address); 535 pragma No_Return (Rcheck_PE_Explicit_Raise); 536 pragma No_Return (Rcheck_PE_Implicit_Return); 537 pragma No_Return (Rcheck_PE_Misaligned_Address_Value); 538 pragma No_Return (Rcheck_PE_Missing_Return); 539 pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); 540 pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); 541 pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); 542 pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction); 543 pragma No_Return (Rcheck_PE_Non_Transportable_Actual); 544 pragma No_Return (Rcheck_PE_Finalize_Raised_Exception); 545 pragma No_Return (Rcheck_SE_Empty_Storage_Pool); 546 pragma No_Return (Rcheck_SE_Explicit_Raise); 547 pragma No_Return (Rcheck_SE_Infinite_Recursion); 548 pragma No_Return (Rcheck_SE_Object_Too_Large); 549 550 -- For compatibility with previous version of GNAT, to preserve bootstrap 551 552 procedure Rcheck_00 (File : System.Address; Line : Integer); 553 procedure Rcheck_01 (File : System.Address; Line : Integer); 554 procedure Rcheck_02 (File : System.Address; Line : Integer); 555 procedure Rcheck_03 (File : System.Address; Line : Integer); 556 procedure Rcheck_04 (File : System.Address; Line : Integer); 557 procedure Rcheck_05 (File : System.Address; Line : Integer); 558 procedure Rcheck_06 (File : System.Address; Line : Integer); 559 procedure Rcheck_07 (File : System.Address; Line : Integer); 560 procedure Rcheck_08 (File : System.Address; Line : Integer); 561 procedure Rcheck_09 (File : System.Address; Line : Integer); 562 procedure Rcheck_10 (File : System.Address; Line : Integer); 563 procedure Rcheck_11 (File : System.Address; Line : Integer); 564 procedure Rcheck_12 (File : System.Address; Line : Integer); 565 procedure Rcheck_13 (File : System.Address; Line : Integer); 566 procedure Rcheck_14 (File : System.Address; Line : Integer); 567 procedure Rcheck_15 (File : System.Address; Line : Integer); 568 procedure Rcheck_16 (File : System.Address; Line : Integer); 569 procedure Rcheck_17 (File : System.Address; Line : Integer); 570 procedure Rcheck_18 (File : System.Address; Line : Integer); 571 procedure Rcheck_19 (File : System.Address; Line : Integer); 572 procedure Rcheck_20 (File : System.Address; Line : Integer); 573 procedure Rcheck_21 (File : System.Address; Line : Integer); 574 procedure Rcheck_23 (File : System.Address; Line : Integer); 575 procedure Rcheck_24 (File : System.Address; Line : Integer); 576 procedure Rcheck_25 (File : System.Address; Line : Integer); 577 procedure Rcheck_26 (File : System.Address; Line : Integer); 578 procedure Rcheck_27 (File : System.Address; Line : Integer); 579 procedure Rcheck_28 (File : System.Address; Line : Integer); 580 procedure Rcheck_29 (File : System.Address; Line : Integer); 581 procedure Rcheck_30 (File : System.Address; Line : Integer); 582 procedure Rcheck_31 (File : System.Address; Line : Integer); 583 procedure Rcheck_32 (File : System.Address; Line : Integer); 584 procedure Rcheck_33 (File : System.Address; Line : Integer); 585 procedure Rcheck_34 (File : System.Address; Line : Integer); 586 587 procedure Rcheck_22 (File : System.Address; Line : Integer); 588 589 pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); 590 pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); 591 pragma Export (C, Rcheck_02, "__gnat_rcheck_02"); 592 pragma Export (C, Rcheck_03, "__gnat_rcheck_03"); 593 pragma Export (C, Rcheck_04, "__gnat_rcheck_04"); 594 pragma Export (C, Rcheck_05, "__gnat_rcheck_05"); 595 pragma Export (C, Rcheck_06, "__gnat_rcheck_06"); 596 pragma Export (C, Rcheck_07, "__gnat_rcheck_07"); 597 pragma Export (C, Rcheck_08, "__gnat_rcheck_08"); 598 pragma Export (C, Rcheck_09, "__gnat_rcheck_09"); 599 pragma Export (C, Rcheck_10, "__gnat_rcheck_10"); 600 pragma Export (C, Rcheck_11, "__gnat_rcheck_11"); 601 pragma Export (C, Rcheck_12, "__gnat_rcheck_12"); 602 pragma Export (C, Rcheck_13, "__gnat_rcheck_13"); 603 pragma Export (C, Rcheck_14, "__gnat_rcheck_14"); 604 pragma Export (C, Rcheck_15, "__gnat_rcheck_15"); 605 pragma Export (C, Rcheck_16, "__gnat_rcheck_16"); 606 pragma Export (C, Rcheck_17, "__gnat_rcheck_17"); 607 pragma Export (C, Rcheck_18, "__gnat_rcheck_18"); 608 pragma Export (C, Rcheck_19, "__gnat_rcheck_19"); 609 pragma Export (C, Rcheck_20, "__gnat_rcheck_20"); 610 pragma Export (C, Rcheck_21, "__gnat_rcheck_21"); 611 pragma Export (C, Rcheck_22, "__gnat_rcheck_22"); 612 pragma Export (C, Rcheck_23, "__gnat_rcheck_23"); 613 pragma Export (C, Rcheck_24, "__gnat_rcheck_24"); 614 pragma Export (C, Rcheck_25, "__gnat_rcheck_25"); 615 pragma Export (C, Rcheck_26, "__gnat_rcheck_26"); 616 pragma Export (C, Rcheck_27, "__gnat_rcheck_27"); 617 pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); 618 pragma Export (C, Rcheck_29, "__gnat_rcheck_29"); 619 pragma Export (C, Rcheck_30, "__gnat_rcheck_30"); 620 pragma Export (C, Rcheck_31, "__gnat_rcheck_31"); 621 pragma Export (C, Rcheck_32, "__gnat_rcheck_32"); 622 pragma Export (C, Rcheck_33, "__gnat_rcheck_33"); 623 pragma Export (C, Rcheck_34, "__gnat_rcheck_34"); 624 625 -- None of these procedures ever returns (they raise an exception!). By 626 -- using pragma No_Return, we ensure that any junk code after the call, 627 -- such as normal return epilog stuff, can be eliminated). 628 629 pragma No_Return (Rcheck_00); 630 pragma No_Return (Rcheck_01); 631 pragma No_Return (Rcheck_02); 632 pragma No_Return (Rcheck_03); 633 pragma No_Return (Rcheck_04); 634 pragma No_Return (Rcheck_05); 635 pragma No_Return (Rcheck_06); 636 pragma No_Return (Rcheck_07); 637 pragma No_Return (Rcheck_08); 638 pragma No_Return (Rcheck_09); 639 pragma No_Return (Rcheck_10); 640 pragma No_Return (Rcheck_11); 641 pragma No_Return (Rcheck_12); 642 pragma No_Return (Rcheck_13); 643 pragma No_Return (Rcheck_14); 644 pragma No_Return (Rcheck_15); 645 pragma No_Return (Rcheck_16); 646 pragma No_Return (Rcheck_17); 647 pragma No_Return (Rcheck_18); 648 pragma No_Return (Rcheck_19); 649 pragma No_Return (Rcheck_20); 650 pragma No_Return (Rcheck_21); 651 pragma No_Return (Rcheck_22); 652 pragma No_Return (Rcheck_23); 653 pragma No_Return (Rcheck_24); 654 pragma No_Return (Rcheck_25); 655 pragma No_Return (Rcheck_26); 656 pragma No_Return (Rcheck_27); 657 pragma No_Return (Rcheck_28); 658 pragma No_Return (Rcheck_29); 659 pragma No_Return (Rcheck_30); 660 pragma No_Return (Rcheck_32); 661 pragma No_Return (Rcheck_33); 662 pragma No_Return (Rcheck_34); 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 := "all guards closed" & NUL; 692 Rmsg_18 : constant String := "improper use of generic subtype" & 693 " with predicate" & NUL; 694 Rmsg_19 : constant String := "Current_Task referenced in entry" & 695 " body" & NUL; 696 Rmsg_20 : constant String := "duplicated entry address" & NUL; 697 Rmsg_21 : constant String := "explicit raise" & NUL; 698 Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL; 699 Rmsg_23 : constant String := "implicit return with No_Return" & NUL; 700 Rmsg_24 : constant String := "misaligned address value" & NUL; 701 Rmsg_25 : constant String := "missing return" & NUL; 702 Rmsg_26 : constant String := "overlaid controlled object" & NUL; 703 Rmsg_27 : constant String := "potentially blocking operation" & NUL; 704 Rmsg_28 : constant String := "stubbed subprogram called" & NUL; 705 Rmsg_29 : constant String := "unchecked union restriction" & NUL; 706 Rmsg_30 : constant String := "actual/returned class-wide" & 707 " value not transportable" & NUL; 708 Rmsg_31 : constant String := "empty storage pool" & NUL; 709 Rmsg_32 : constant String := "explicit raise" & NUL; 710 Rmsg_33 : constant String := "infinite recursion" & NUL; 711 Rmsg_34 : constant String := "object too large" & NUL; 712 713 ----------------------- 714 -- Polling Interface -- 715 ----------------------- 716 717 type Unsigned is mod 2 ** 32; 718 719 Counter : Unsigned := 0; 720 pragma Warnings (Off, Counter); 721 -- This counter is provided for convenience. It can be used in Poll to 722 -- perform periodic but not systematic operations. 723 724 procedure Poll is separate; 725 -- The actual polling routine is separate, so that it can easily be 726 -- replaced with a target dependent version. 727 728 ------------------------------ 729 -- Current_Target_Exception -- 730 ------------------------------ 731 732 function Current_Target_Exception return Exception_Occurrence is 733 begin 734 return Null_Occurrence; 735 end Current_Target_Exception; 736 737 ------------------- 738 -- EId_To_String -- 739 ------------------- 740 741 function EId_To_String (X : Exception_Id) return String 742 renames Stream_Attributes.EId_To_String; 743 744 ------------------ 745 -- EO_To_String -- 746 ------------------ 747 748 -- We use the null string to represent the null occurrence, otherwise we 749 -- output the Exception_Information string for the occurrence. 750 751 function EO_To_String (X : Exception_Occurrence) return String 752 renames Stream_Attributes.EO_To_String; 753 754 ------------------------ 755 -- Exception_Identity -- 756 ------------------------ 757 758 function Exception_Identity 759 (X : Exception_Occurrence) return Exception_Id 760 is 761 begin 762 -- Note that the following test used to be here for the original Ada 95 763 -- semantics, but these were modified by AI-241 to require returning 764 -- Null_Id instead of raising Constraint_Error. 765 766 -- if X.Id = Null_Id then 767 -- raise Constraint_Error; 768 -- end if; 769 770 return X.Id; 771 end Exception_Identity; 772 773 --------------------------- 774 -- Exception_Information -- 775 --------------------------- 776 777 function Exception_Information (X : Exception_Occurrence) return String is 778 begin 779 if X.Id = Null_Id then 780 raise Constraint_Error; 781 end if; 782 783 return Exception_Data.Exception_Information (X); 784 end Exception_Information; 785 786 ----------------------- 787 -- Exception_Message -- 788 ----------------------- 789 790 function Exception_Message (X : Exception_Occurrence) return String is 791 begin 792 if X.Id = Null_Id then 793 raise Constraint_Error; 794 end if; 795 796 return X.Msg (1 .. X.Msg_Length); 797 end Exception_Message; 798 799 -------------------- 800 -- Exception_Name -- 801 -------------------- 802 803 function Exception_Name (Id : Exception_Id) return String is 804 begin 805 if Id = null then 806 raise Constraint_Error; 807 end if; 808 809 return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); 810 end Exception_Name; 811 812 function Exception_Name (X : Exception_Occurrence) return String is 813 begin 814 return Exception_Name (X.Id); 815 end Exception_Name; 816 817 --------------------------- 818 -- Exception_Name_Simple -- 819 --------------------------- 820 821 function Exception_Name_Simple (X : Exception_Occurrence) return String is 822 Name : constant String := Exception_Name (X); 823 P : Natural; 824 825 begin 826 P := Name'Length; 827 while P > 1 loop 828 exit when Name (P - 1) = '.'; 829 P := P - 1; 830 end loop; 831 832 -- Return result making sure lower bound is 1 833 834 declare 835 subtype Rname is String (1 .. Name'Length - P + 1); 836 begin 837 return Rname (Name (P .. Name'Length)); 838 end; 839 end Exception_Name_Simple; 840 841 -------------------- 842 -- Exception_Data -- 843 -------------------- 844 845 package body Exception_Data is separate; 846 -- This package can be easily dummied out if we do not want the basic 847 -- support for exception messages (such as in Ada 83). 848 849 ---------------------- 850 -- Exception_Traces -- 851 ---------------------- 852 853 package body Exception_Traces is separate; 854 -- Depending on the underlying support for IO the implementation will 855 -- differ. Moreover we would like to dummy out this package in case we do 856 -- not want any exception tracing support. This is why this package is 857 -- separated. 858 859 ----------------------- 860 -- Stream Attributes -- 861 ----------------------- 862 863 package body Stream_Attributes is separate; 864 -- This package can be easily dummied out if we do not want the 865 -- support for streaming Exception_Ids and Exception_Occurrences. 866 867 ----------------------------- 868 -- Process_Raise_Exception -- 869 ----------------------------- 870 871 procedure Process_Raise_Exception (E : Exception_Id) is 872 pragma Inspection_Point (E); 873 -- This is so the debugger can reliably inspect the parameter 874 875 Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; 876 Excep : constant EOA := Get_Current_Excep.all; 877 878 procedure builtin_longjmp (buffer : Address; Flag : Integer); 879 pragma No_Return (builtin_longjmp); 880 pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp"); 881 882 begin 883 -- WARNING: There should be no exception handler for this body because 884 -- this would cause gigi to prepend a setup for a new jmpbuf to the 885 -- sequence of statements in case of built-in sjljl. We would then 886 -- always get this new buf in Jumpbuf_Ptr instead of the one for the 887 -- exception we are handling, which would completely break the whole 888 -- design of this procedure. 889 890 -- If the jump buffer pointer is non-null, transfer control using it. 891 -- Otherwise announce an unhandled exception (note that this means that 892 -- we have no finalizations to do other than at the outer level). 893 -- Perform the necessary notification tasks in both cases. 894 895 if Jumpbuf_Ptr /= Null_Address then 896 if not Excep.Exception_Raised then 897 Excep.Exception_Raised := True; 898 Exception_Traces.Notify_Handled_Exception (Excep); 899 end if; 900 901 builtin_longjmp (Jumpbuf_Ptr, 1); 902 903 else 904 Exception_Traces.Notify_Unhandled_Exception (Excep); 905 Exception_Traces.Unhandled_Exception_Terminate (Excep); 906 end if; 907 end Process_Raise_Exception; 908 909 ---------------------------- 910 -- Raise_Constraint_Error -- 911 ---------------------------- 912 913 procedure Raise_Constraint_Error 914 (File : System.Address; 915 Line : Integer) 916 is 917 begin 918 Raise_With_Location_And_Msg 919 (Constraint_Error_Def'Access, File, Line); 920 end Raise_Constraint_Error; 921 922 -------------------------------- 923 -- Raise_Constraint_Error_Msg -- 924 -------------------------------- 925 926 procedure Raise_Constraint_Error_Msg 927 (File : System.Address; 928 Line : Integer; 929 Msg : System.Address) 930 is 931 begin 932 Raise_With_Location_And_Msg 933 (Constraint_Error_Def'Access, File, Line, Msg); 934 end Raise_Constraint_Error_Msg; 935 936 ------------------------- 937 -- Raise_Current_Excep -- 938 ------------------------- 939 940 procedure Raise_Current_Excep (E : Exception_Id) is 941 942 pragma Inspection_Point (E); 943 -- This is so the debugger can reliably inspect the parameter when 944 -- inserting a breakpoint at the start of this procedure. 945 946 Id : Exception_Id := E; 947 pragma Volatile (Id); 948 pragma Warnings (Off, Id); 949 -- In order to provide support for breakpoints on unhandled exceptions, 950 -- the debugger will also need to be able to inspect the value of E from 951 -- another (inner) frame. So we need to make sure that if E is passed in 952 -- a register, its value is also spilled on stack. For this, we store 953 -- the parameter value in a local variable, and add a pragma Volatile to 954 -- make sure it is spilled. The pragma Warnings (Off) is needed because 955 -- the compiler knows that Id is not referenced and that this use of 956 -- pragma Volatile is peculiar! 957 958 begin 959 Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E)); 960 Process_Raise_Exception (E); 961 end Raise_Current_Excep; 962 963 --------------------- 964 -- Raise_Exception -- 965 --------------------- 966 967 procedure Raise_Exception 968 (E : Exception_Id; 969 Message : String := "") 970 is 971 EF : Exception_Id := E; 972 Excep : constant EOA := Get_Current_Excep.all; 973 begin 974 -- Raise CE if E = Null_ID (AI-446) 975 976 if E = null then 977 EF := Constraint_Error'Identity; 978 end if; 979 980 -- Go ahead and raise appropriate exception 981 982 Exception_Data.Set_Exception_Msg (Excep, EF, Message); 983 Abort_Defer.all; 984 Raise_Current_Excep (EF); 985 end Raise_Exception; 986 987 ---------------------------- 988 -- Raise_Exception_Always -- 989 ---------------------------- 990 991 procedure Raise_Exception_Always 992 (E : Exception_Id; 993 Message : String := "") 994 is 995 Excep : constant EOA := Get_Current_Excep.all; 996 begin 997 Exception_Data.Set_Exception_Msg (Excep, E, Message); 998 Abort_Defer.all; 999 Raise_Current_Excep (E); 1000 end Raise_Exception_Always; 1001 1002 ------------------------------ 1003 -- Raise_Exception_No_Defer -- 1004 ------------------------------ 1005 1006 procedure Raise_Exception_No_Defer 1007 (E : Exception_Id; 1008 Message : String := "") 1009 is 1010 Excep : constant EOA := Get_Current_Excep.all; 1011 begin 1012 Exception_Data.Set_Exception_Msg (Excep, E, Message); 1013 1014 -- Do not call Abort_Defer.all, as specified by the spec 1015 1016 Raise_Current_Excep (E); 1017 end Raise_Exception_No_Defer; 1018 1019 ------------------------------------- 1020 -- Raise_From_Controlled_Operation -- 1021 ------------------------------------- 1022 1023 procedure Raise_From_Controlled_Operation 1024 (X : Ada.Exceptions.Exception_Occurrence) 1025 is 1026 Prefix : constant String := "adjust/finalize raised "; 1027 Orig_Msg : constant String := Exception_Message (X); 1028 Orig_Prefix_Length : constant Natural := 1029 Integer'Min (Prefix'Length, Orig_Msg'Length); 1030 Orig_Prefix : String renames Orig_Msg 1031 (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); 1032 begin 1033 -- Message already has proper prefix, just re-reraise 1034 1035 if Orig_Prefix = Prefix then 1036 Raise_Exception_No_Defer 1037 (E => Program_Error'Identity, 1038 Message => Orig_Msg); 1039 1040 else 1041 declare 1042 New_Msg : constant String := Prefix & Exception_Name (X); 1043 1044 begin 1045 -- No message present, just provide our own 1046 1047 if Orig_Msg = "" then 1048 Raise_Exception_No_Defer 1049 (E => Program_Error'Identity, 1050 Message => New_Msg); 1051 1052 -- Message present, add informational prefix 1053 1054 else 1055 Raise_Exception_No_Defer 1056 (E => Program_Error'Identity, 1057 Message => New_Msg & ": " & Orig_Msg); 1058 end if; 1059 end; 1060 end if; 1061 end Raise_From_Controlled_Operation; 1062 1063 ------------------------------- 1064 -- Raise_From_Signal_Handler -- 1065 ------------------------------- 1066 1067 procedure Raise_From_Signal_Handler 1068 (E : Exception_Id; 1069 M : System.Address) 1070 is 1071 Excep : constant EOA := Get_Current_Excep.all; 1072 begin 1073 Exception_Data.Set_Exception_C_Msg (Excep, E, M); 1074 Abort_Defer.all; 1075 Process_Raise_Exception (E); 1076 end Raise_From_Signal_Handler; 1077 1078 ------------------------- 1079 -- Raise_Program_Error -- 1080 ------------------------- 1081 1082 procedure Raise_Program_Error 1083 (File : System.Address; 1084 Line : Integer) 1085 is 1086 begin 1087 Raise_With_Location_And_Msg 1088 (Program_Error_Def'Access, File, Line); 1089 end Raise_Program_Error; 1090 1091 ----------------------------- 1092 -- Raise_Program_Error_Msg -- 1093 ----------------------------- 1094 1095 procedure Raise_Program_Error_Msg 1096 (File : System.Address; 1097 Line : Integer; 1098 Msg : System.Address) 1099 is 1100 begin 1101 Raise_With_Location_And_Msg 1102 (Program_Error_Def'Access, File, Line, Msg); 1103 end Raise_Program_Error_Msg; 1104 1105 ------------------------- 1106 -- Raise_Storage_Error -- 1107 ------------------------- 1108 1109 procedure Raise_Storage_Error 1110 (File : System.Address; 1111 Line : Integer) 1112 is 1113 begin 1114 Raise_With_Location_And_Msg 1115 (Storage_Error_Def'Access, File, Line); 1116 end Raise_Storage_Error; 1117 1118 ----------------------------- 1119 -- Raise_Storage_Error_Msg -- 1120 ----------------------------- 1121 1122 procedure Raise_Storage_Error_Msg 1123 (File : System.Address; 1124 Line : Integer; 1125 Msg : System.Address) 1126 is 1127 begin 1128 Raise_With_Location_And_Msg 1129 (Storage_Error_Def'Access, File, Line, Msg); 1130 end Raise_Storage_Error_Msg; 1131 1132 --------------------------------- 1133 -- Raise_With_Location_And_Msg -- 1134 --------------------------------- 1135 1136 procedure Raise_With_Location_And_Msg 1137 (E : Exception_Id; 1138 F : System.Address; 1139 L : Integer; 1140 M : System.Address := System.Null_Address) 1141 is 1142 Excep : constant EOA := Get_Current_Excep.all; 1143 begin 1144 Exception_Data.Set_Exception_C_Msg (Excep, E, F, L, Msg2 => M); 1145 Abort_Defer.all; 1146 Raise_Current_Excep (E); 1147 end Raise_With_Location_And_Msg; 1148 1149 -------------------- 1150 -- Raise_With_Msg -- 1151 -------------------- 1152 1153 procedure Raise_With_Msg (E : Exception_Id) is 1154 Excep : constant EOA := Get_Current_Excep.all; 1155 1156 begin 1157 Excep.Exception_Raised := False; 1158 Excep.Id := E; 1159 Excep.Num_Tracebacks := 0; 1160 Excep.Pid := Local_Partition_ID; 1161 Abort_Defer.all; 1162 Raise_Current_Excep (E); 1163 end Raise_With_Msg; 1164 1165 -------------------------------------- 1166 -- Calls to Run-Time Check Routines -- 1167 -------------------------------------- 1168 1169 procedure Rcheck_CE_Access_Check 1170 (File : System.Address; Line : Integer) 1171 is 1172 begin 1173 Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address); 1174 end Rcheck_CE_Access_Check; 1175 1176 procedure Rcheck_CE_Null_Access_Parameter 1177 (File : System.Address; Line : Integer) 1178 is 1179 begin 1180 Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address); 1181 end Rcheck_CE_Null_Access_Parameter; 1182 1183 procedure Rcheck_CE_Discriminant_Check 1184 (File : System.Address; Line : Integer) 1185 is 1186 begin 1187 Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address); 1188 end Rcheck_CE_Discriminant_Check; 1189 1190 procedure Rcheck_CE_Divide_By_Zero 1191 (File : System.Address; Line : Integer) 1192 is 1193 begin 1194 Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address); 1195 end Rcheck_CE_Divide_By_Zero; 1196 1197 procedure Rcheck_CE_Explicit_Raise 1198 (File : System.Address; Line : Integer) 1199 is 1200 begin 1201 Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address); 1202 end Rcheck_CE_Explicit_Raise; 1203 1204 procedure Rcheck_CE_Index_Check 1205 (File : System.Address; Line : Integer) 1206 is 1207 begin 1208 Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address); 1209 end Rcheck_CE_Index_Check; 1210 1211 procedure Rcheck_CE_Invalid_Data 1212 (File : System.Address; Line : Integer) 1213 is 1214 begin 1215 Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address); 1216 end Rcheck_CE_Invalid_Data; 1217 1218 procedure Rcheck_CE_Length_Check 1219 (File : System.Address; Line : Integer) 1220 is 1221 begin 1222 Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address); 1223 end Rcheck_CE_Length_Check; 1224 1225 procedure Rcheck_CE_Null_Exception_Id 1226 (File : System.Address; Line : Integer) 1227 is 1228 begin 1229 Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address); 1230 end Rcheck_CE_Null_Exception_Id; 1231 1232 procedure Rcheck_CE_Null_Not_Allowed 1233 (File : System.Address; Line : Integer) 1234 is 1235 begin 1236 Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address); 1237 end Rcheck_CE_Null_Not_Allowed; 1238 1239 procedure Rcheck_CE_Overflow_Check 1240 (File : System.Address; Line : Integer) 1241 is 1242 begin 1243 Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address); 1244 end Rcheck_CE_Overflow_Check; 1245 1246 procedure Rcheck_CE_Partition_Check 1247 (File : System.Address; Line : Integer) 1248 is 1249 begin 1250 Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address); 1251 end Rcheck_CE_Partition_Check; 1252 1253 procedure Rcheck_CE_Range_Check 1254 (File : System.Address; Line : Integer) 1255 is 1256 begin 1257 Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address); 1258 end Rcheck_CE_Range_Check; 1259 1260 procedure Rcheck_CE_Tag_Check 1261 (File : System.Address; Line : Integer) 1262 is 1263 begin 1264 Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address); 1265 end Rcheck_CE_Tag_Check; 1266 1267 procedure Rcheck_PE_Access_Before_Elaboration 1268 (File : System.Address; Line : Integer) 1269 is 1270 begin 1271 Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); 1272 end Rcheck_PE_Access_Before_Elaboration; 1273 1274 procedure Rcheck_PE_Accessibility_Check 1275 (File : System.Address; Line : Integer) 1276 is 1277 begin 1278 Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); 1279 end Rcheck_PE_Accessibility_Check; 1280 1281 procedure Rcheck_PE_Address_Of_Intrinsic 1282 (File : System.Address; Line : Integer) 1283 is 1284 begin 1285 Raise_Program_Error_Msg (File, Line, Rmsg_16'Address); 1286 end Rcheck_PE_Address_Of_Intrinsic; 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_17'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_18'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_19'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_20'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_21'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_23'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_24'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_25'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_26'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_27'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_28'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_29'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_30'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_31'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_32'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_33'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_34'Address); 1405 end Rcheck_SE_Object_Too_Large; 1406 1407 procedure Rcheck_PE_Finalize_Raised_Exception 1408 (File : System.Address; Line : Integer) 1409 is 1410 E : constant Exception_Id := Program_Error_Def'Access; 1411 Excep : constant EOA := Get_Current_Excep.all; 1412 begin 1413 -- This is "finalize/adjust raised exception". This subprogram is always 1414 -- called with abort deferred, unlike all other Rcheck_* routines, it 1415 -- needs to call Raise_Exception_No_Defer. 1416 1417 -- This is consistent with Raise_From_Controlled_Operation 1418 1419 Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0, 1420 Rmsg_22'Address); 1421 Raise_Current_Excep (E); 1422 end Rcheck_PE_Finalize_Raised_Exception; 1423 1424 procedure Rcheck_00 (File : System.Address; Line : Integer) 1425 renames Rcheck_CE_Access_Check; 1426 procedure Rcheck_01 (File : System.Address; Line : Integer) 1427 renames Rcheck_CE_Null_Access_Parameter; 1428 procedure Rcheck_02 (File : System.Address; Line : Integer) 1429 renames Rcheck_CE_Discriminant_Check; 1430 procedure Rcheck_03 (File : System.Address; Line : Integer) 1431 renames Rcheck_CE_Divide_By_Zero; 1432 procedure Rcheck_04 (File : System.Address; Line : Integer) 1433 renames Rcheck_CE_Explicit_Raise; 1434 procedure Rcheck_05 (File : System.Address; Line : Integer) 1435 renames Rcheck_CE_Index_Check; 1436 procedure Rcheck_06 (File : System.Address; Line : Integer) 1437 renames Rcheck_CE_Invalid_Data; 1438 procedure Rcheck_07 (File : System.Address; Line : Integer) 1439 renames Rcheck_CE_Length_Check; 1440 procedure Rcheck_08 (File : System.Address; Line : Integer) 1441 renames Rcheck_CE_Null_Exception_Id; 1442 procedure Rcheck_09 (File : System.Address; Line : Integer) 1443 renames Rcheck_CE_Null_Not_Allowed; 1444 procedure Rcheck_10 (File : System.Address; Line : Integer) 1445 renames Rcheck_CE_Overflow_Check; 1446 procedure Rcheck_11 (File : System.Address; Line : Integer) 1447 renames Rcheck_CE_Partition_Check; 1448 procedure Rcheck_12 (File : System.Address; Line : Integer) 1449 renames Rcheck_CE_Range_Check; 1450 procedure Rcheck_13 (File : System.Address; Line : Integer) 1451 renames Rcheck_CE_Tag_Check; 1452 procedure Rcheck_14 (File : System.Address; Line : Integer) 1453 renames Rcheck_PE_Access_Before_Elaboration; 1454 procedure Rcheck_15 (File : System.Address; Line : Integer) 1455 renames Rcheck_PE_Accessibility_Check; 1456 procedure Rcheck_16 (File : System.Address; Line : Integer) 1457 renames Rcheck_PE_Address_Of_Intrinsic; 1458 procedure Rcheck_17 (File : System.Address; Line : Integer) 1459 renames Rcheck_PE_All_Guards_Closed; 1460 procedure Rcheck_18 (File : System.Address; Line : Integer) 1461 renames Rcheck_PE_Bad_Predicated_Generic_Type; 1462 procedure Rcheck_19 (File : System.Address; Line : Integer) 1463 renames Rcheck_PE_Current_Task_In_Entry_Body; 1464 procedure Rcheck_20 (File : System.Address; Line : Integer) 1465 renames Rcheck_PE_Duplicated_Entry_Address; 1466 procedure Rcheck_21 (File : System.Address; Line : Integer) 1467 renames Rcheck_PE_Explicit_Raise; 1468 procedure Rcheck_23 (File : System.Address; Line : Integer) 1469 renames Rcheck_PE_Implicit_Return; 1470 procedure Rcheck_24 (File : System.Address; Line : Integer) 1471 renames Rcheck_PE_Misaligned_Address_Value; 1472 procedure Rcheck_25 (File : System.Address; Line : Integer) 1473 renames Rcheck_PE_Missing_Return; 1474 procedure Rcheck_26 (File : System.Address; Line : Integer) 1475 renames Rcheck_PE_Overlaid_Controlled_Object; 1476 procedure Rcheck_27 (File : System.Address; Line : Integer) 1477 renames Rcheck_PE_Potentially_Blocking_Operation; 1478 procedure Rcheck_28 (File : System.Address; Line : Integer) 1479 renames Rcheck_PE_Stubbed_Subprogram_Called; 1480 procedure Rcheck_29 (File : System.Address; Line : Integer) 1481 renames Rcheck_PE_Unchecked_Union_Restriction; 1482 procedure Rcheck_30 (File : System.Address; Line : Integer) 1483 renames Rcheck_PE_Non_Transportable_Actual; 1484 procedure Rcheck_31 (File : System.Address; Line : Integer) 1485 renames Rcheck_SE_Empty_Storage_Pool; 1486 procedure Rcheck_32 (File : System.Address; Line : Integer) 1487 renames Rcheck_SE_Explicit_Raise; 1488 procedure Rcheck_33 (File : System.Address; Line : Integer) 1489 renames Rcheck_SE_Infinite_Recursion; 1490 procedure Rcheck_34 (File : System.Address; Line : Integer) 1491 renames Rcheck_SE_Object_Too_Large; 1492 1493 procedure Rcheck_22 (File : System.Address; Line : Integer) 1494 renames Rcheck_PE_Finalize_Raised_Exception; 1495 1496 ------------- 1497 -- Reraise -- 1498 ------------- 1499 1500 procedure Reraise is 1501 Excep : constant EOA := Get_Current_Excep.all; 1502 1503 begin 1504 Abort_Defer.all; 1505 Raise_Current_Excep (Excep.Id); 1506 end Reraise; 1507 1508 -------------------------------------- 1509 -- Reraise_Library_Exception_If_Any -- 1510 -------------------------------------- 1511 1512 procedure Reraise_Library_Exception_If_Any is 1513 LE : Exception_Occurrence; 1514 begin 1515 if Library_Exception_Set then 1516 LE := Library_Exception; 1517 Raise_From_Controlled_Operation (LE); 1518 end if; 1519 end Reraise_Library_Exception_If_Any; 1520 1521 ------------------------ 1522 -- Reraise_Occurrence -- 1523 ------------------------ 1524 1525 procedure Reraise_Occurrence (X : Exception_Occurrence) is 1526 begin 1527 if X.Id /= null then 1528 Abort_Defer.all; 1529 Save_Occurrence (Get_Current_Excep.all.all, X); 1530 Raise_Current_Excep (X.Id); 1531 end if; 1532 end Reraise_Occurrence; 1533 1534 ------------------------------- 1535 -- Reraise_Occurrence_Always -- 1536 ------------------------------- 1537 1538 procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is 1539 begin 1540 Abort_Defer.all; 1541 Save_Occurrence (Get_Current_Excep.all.all, X); 1542 Raise_Current_Excep (X.Id); 1543 end Reraise_Occurrence_Always; 1544 1545 --------------------------------- 1546 -- Reraise_Occurrence_No_Defer -- 1547 --------------------------------- 1548 1549 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is 1550 begin 1551 Save_Occurrence (Get_Current_Excep.all.all, X); 1552 Raise_Current_Excep (X.Id); 1553 end Reraise_Occurrence_No_Defer; 1554 1555 --------------------- 1556 -- Save_Occurrence -- 1557 --------------------- 1558 1559 procedure Save_Occurrence 1560 (Target : out Exception_Occurrence; 1561 Source : Exception_Occurrence) 1562 is 1563 begin 1564 Target.Id := Source.Id; 1565 Target.Msg_Length := Source.Msg_Length; 1566 Target.Num_Tracebacks := Source.Num_Tracebacks; 1567 Target.Pid := Source.Pid; 1568 1569 Target.Msg (1 .. Target.Msg_Length) := 1570 Source.Msg (1 .. Target.Msg_Length); 1571 1572 Target.Tracebacks (1 .. Target.Num_Tracebacks) := 1573 Source.Tracebacks (1 .. Target.Num_Tracebacks); 1574 end Save_Occurrence; 1575 1576 function Save_Occurrence (Source : Exception_Occurrence) return EOA is 1577 Target : constant EOA := new Exception_Occurrence; 1578 begin 1579 Save_Occurrence (Target.all, Source); 1580 return Target; 1581 end Save_Occurrence; 1582 1583 ------------------- 1584 -- String_To_EId -- 1585 ------------------- 1586 1587 function String_To_EId (S : String) return Exception_Id 1588 renames Stream_Attributes.String_To_EId; 1589 1590 ------------------ 1591 -- String_To_EO -- 1592 ------------------ 1593 1594 function String_To_EO (S : String) return Exception_Occurrence 1595 renames Stream_Attributes.String_To_EO; 1596 1597 --------------- 1598 -- To_Stderr -- 1599 --------------- 1600 1601 procedure To_Stderr (C : Character) is 1602 type int is new Integer; 1603 1604 procedure put_char_stderr (C : int); 1605 pragma Import (C, put_char_stderr, "put_char_stderr"); 1606 1607 begin 1608 put_char_stderr (Character'Pos (C)); 1609 end To_Stderr; 1610 1611 procedure To_Stderr (S : String) is 1612 begin 1613 for J in S'Range loop 1614 if S (J) /= ASCII.CR then 1615 To_Stderr (S (J)); 1616 end if; 1617 end loop; 1618 end To_Stderr; 1619 1620 ------------------------- 1621 -- Transfer_Occurrence -- 1622 ------------------------- 1623 1624 procedure Transfer_Occurrence 1625 (Target : Exception_Occurrence_Access; 1626 Source : Exception_Occurrence) 1627 is 1628 begin 1629 Save_Occurrence (Target.all, Source); 1630 end Transfer_Occurrence; 1631 1632 ------------------------ 1633 -- Triggered_By_Abort -- 1634 ------------------------ 1635 1636 function Triggered_By_Abort return Boolean is 1637 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; 1638 begin 1639 return Ex /= null 1640 and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; 1641 end Triggered_By_Abort; 1642 1643end Ada.Exceptions; 1644