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