1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- A D A . E X C E P T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32pragma 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_Current_Task_In_Entry_Body 436 (File : System.Address; Line : Integer); 437 procedure Rcheck_PE_Duplicated_Entry_Address 438 (File : System.Address; Line : Integer); 439 procedure Rcheck_PE_Explicit_Raise 440 (File : System.Address; Line : Integer); 441 procedure Rcheck_PE_Implicit_Return 442 (File : System.Address; Line : Integer); 443 procedure Rcheck_PE_Misaligned_Address_Value 444 (File : System.Address; Line : Integer); 445 procedure Rcheck_PE_Missing_Return 446 (File : System.Address; Line : Integer); 447 procedure Rcheck_PE_Non_Transportable_Actual 448 (File : System.Address; Line : Integer); 449 procedure Rcheck_PE_Overlaid_Controlled_Object 450 (File : System.Address; Line : Integer); 451 procedure Rcheck_PE_Potentially_Blocking_Operation 452 (File : System.Address; Line : Integer); 453 procedure Rcheck_PE_Stubbed_Subprogram_Called 454 (File : System.Address; Line : Integer); 455 procedure Rcheck_PE_Unchecked_Union_Restriction 456 (File : System.Address; Line : Integer); 457 procedure Rcheck_SE_Empty_Storage_Pool 458 (File : System.Address; Line : Integer); 459 procedure Rcheck_SE_Explicit_Raise 460 (File : System.Address; Line : Integer); 461 procedure Rcheck_SE_Infinite_Recursion 462 (File : System.Address; Line : Integer); 463 procedure Rcheck_SE_Object_Too_Large 464 (File : System.Address; Line : Integer); 465 procedure Rcheck_PE_Stream_Operation_Not_Allowed 466 (File : System.Address; Line : Integer); 467 procedure Rcheck_CE_Access_Check_Ext 468 (File : System.Address; Line, Column : Integer); 469 procedure Rcheck_CE_Index_Check_Ext 470 (File : System.Address; Line, Column, Index, First, Last : Integer); 471 procedure Rcheck_CE_Invalid_Data_Ext 472 (File : System.Address; Line, Column, Index, First, Last : Integer); 473 procedure Rcheck_CE_Range_Check_Ext 474 (File : System.Address; Line, Column, Index, First, Last : Integer); 475 476 procedure Rcheck_PE_Finalize_Raised_Exception 477 (File : System.Address; Line : Integer); 478 -- This routine is separated out because it has quite different behavior 479 -- from the others. This is the "finalize/adjust raised exception". This 480 -- subprogram is always called with abort deferred, unlike all other 481 -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. 482 483 pragma Export (C, Rcheck_CE_Access_Check, 484 "__gnat_rcheck_CE_Access_Check"); 485 pragma Export (C, Rcheck_CE_Null_Access_Parameter, 486 "__gnat_rcheck_CE_Null_Access_Parameter"); 487 pragma Export (C, Rcheck_CE_Discriminant_Check, 488 "__gnat_rcheck_CE_Discriminant_Check"); 489 pragma Export (C, Rcheck_CE_Divide_By_Zero, 490 "__gnat_rcheck_CE_Divide_By_Zero"); 491 pragma Export (C, Rcheck_CE_Explicit_Raise, 492 "__gnat_rcheck_CE_Explicit_Raise"); 493 pragma Export (C, Rcheck_CE_Index_Check, 494 "__gnat_rcheck_CE_Index_Check"); 495 pragma Export (C, Rcheck_CE_Invalid_Data, 496 "__gnat_rcheck_CE_Invalid_Data"); 497 pragma Export (C, Rcheck_CE_Length_Check, 498 "__gnat_rcheck_CE_Length_Check"); 499 pragma Export (C, Rcheck_CE_Null_Exception_Id, 500 "__gnat_rcheck_CE_Null_Exception_Id"); 501 pragma Export (C, Rcheck_CE_Null_Not_Allowed, 502 "__gnat_rcheck_CE_Null_Not_Allowed"); 503 pragma Export (C, Rcheck_CE_Overflow_Check, 504 "__gnat_rcheck_CE_Overflow_Check"); 505 pragma Export (C, Rcheck_CE_Partition_Check, 506 "__gnat_rcheck_CE_Partition_Check"); 507 pragma Export (C, Rcheck_CE_Range_Check, 508 "__gnat_rcheck_CE_Range_Check"); 509 pragma Export (C, Rcheck_CE_Tag_Check, 510 "__gnat_rcheck_CE_Tag_Check"); 511 pragma Export (C, Rcheck_PE_Access_Before_Elaboration, 512 "__gnat_rcheck_PE_Access_Before_Elaboration"); 513 pragma Export (C, Rcheck_PE_Accessibility_Check, 514 "__gnat_rcheck_PE_Accessibility_Check"); 515 pragma Export (C, Rcheck_PE_Address_Of_Intrinsic, 516 "__gnat_rcheck_PE_Address_Of_Intrinsic"); 517 pragma Export (C, Rcheck_PE_Aliased_Parameters, 518 "__gnat_rcheck_PE_Aliased_Parameters"); 519 pragma Export (C, Rcheck_PE_All_Guards_Closed, 520 "__gnat_rcheck_PE_All_Guards_Closed"); 521 pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type, 522 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type"); 523 pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body, 524 "__gnat_rcheck_PE_Current_Task_In_Entry_Body"); 525 pragma Export (C, Rcheck_PE_Duplicated_Entry_Address, 526 "__gnat_rcheck_PE_Duplicated_Entry_Address"); 527 pragma Export (C, Rcheck_PE_Explicit_Raise, 528 "__gnat_rcheck_PE_Explicit_Raise"); 529 pragma Export (C, Rcheck_PE_Finalize_Raised_Exception, 530 "__gnat_rcheck_PE_Finalize_Raised_Exception"); 531 pragma Export (C, Rcheck_PE_Implicit_Return, 532 "__gnat_rcheck_PE_Implicit_Return"); 533 pragma Export (C, Rcheck_PE_Misaligned_Address_Value, 534 "__gnat_rcheck_PE_Misaligned_Address_Value"); 535 pragma Export (C, Rcheck_PE_Missing_Return, 536 "__gnat_rcheck_PE_Missing_Return"); 537 pragma Export (C, Rcheck_PE_Non_Transportable_Actual, 538 "__gnat_rcheck_PE_Non_Transportable_Actual"); 539 pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object, 540 "__gnat_rcheck_PE_Overlaid_Controlled_Object"); 541 pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation, 542 "__gnat_rcheck_PE_Potentially_Blocking_Operation"); 543 pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed, 544 "__gnat_rcheck_PE_Stream_Operation_Not_Allowed"); 545 pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called, 546 "__gnat_rcheck_PE_Stubbed_Subprogram_Called"); 547 pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction, 548 "__gnat_rcheck_PE_Unchecked_Union_Restriction"); 549 pragma Export (C, Rcheck_SE_Empty_Storage_Pool, 550 "__gnat_rcheck_SE_Empty_Storage_Pool"); 551 pragma Export (C, Rcheck_SE_Explicit_Raise, 552 "__gnat_rcheck_SE_Explicit_Raise"); 553 pragma Export (C, Rcheck_SE_Infinite_Recursion, 554 "__gnat_rcheck_SE_Infinite_Recursion"); 555 pragma Export (C, Rcheck_SE_Object_Too_Large, 556 "__gnat_rcheck_SE_Object_Too_Large"); 557 558 pragma Export (C, Rcheck_CE_Access_Check_Ext, 559 "__gnat_rcheck_CE_Access_Check_ext"); 560 pragma Export (C, Rcheck_CE_Index_Check_Ext, 561 "__gnat_rcheck_CE_Index_Check_ext"); 562 pragma Export (C, Rcheck_CE_Invalid_Data_Ext, 563 "__gnat_rcheck_CE_Invalid_Data_ext"); 564 pragma Export (C, Rcheck_CE_Range_Check_Ext, 565 "__gnat_rcheck_CE_Range_Check_ext"); 566 567 -- None of these procedures ever returns (they raise an exception). By 568 -- using pragma No_Return, we ensure that any junk code after the call, 569 -- such as normal return epilogue stuff, can be eliminated). 570 571 pragma No_Return (Rcheck_CE_Access_Check); 572 pragma No_Return (Rcheck_CE_Null_Access_Parameter); 573 pragma No_Return (Rcheck_CE_Discriminant_Check); 574 pragma No_Return (Rcheck_CE_Divide_By_Zero); 575 pragma No_Return (Rcheck_CE_Explicit_Raise); 576 pragma No_Return (Rcheck_CE_Index_Check); 577 pragma No_Return (Rcheck_CE_Invalid_Data); 578 pragma No_Return (Rcheck_CE_Length_Check); 579 pragma No_Return (Rcheck_CE_Null_Exception_Id); 580 pragma No_Return (Rcheck_CE_Null_Not_Allowed); 581 pragma No_Return (Rcheck_CE_Overflow_Check); 582 pragma No_Return (Rcheck_CE_Partition_Check); 583 pragma No_Return (Rcheck_CE_Range_Check); 584 pragma No_Return (Rcheck_CE_Tag_Check); 585 pragma No_Return (Rcheck_PE_Access_Before_Elaboration); 586 pragma No_Return (Rcheck_PE_Accessibility_Check); 587 pragma No_Return (Rcheck_PE_Address_Of_Intrinsic); 588 pragma No_Return (Rcheck_PE_Aliased_Parameters); 589 pragma No_Return (Rcheck_PE_All_Guards_Closed); 590 pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type); 591 pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body); 592 pragma No_Return (Rcheck_PE_Duplicated_Entry_Address); 593 pragma No_Return (Rcheck_PE_Explicit_Raise); 594 pragma No_Return (Rcheck_PE_Implicit_Return); 595 pragma No_Return (Rcheck_PE_Misaligned_Address_Value); 596 pragma No_Return (Rcheck_PE_Missing_Return); 597 pragma No_Return (Rcheck_PE_Non_Transportable_Actual); 598 pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); 599 pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); 600 pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed); 601 pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); 602 pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction); 603 pragma No_Return (Rcheck_PE_Finalize_Raised_Exception); 604 pragma No_Return (Rcheck_SE_Empty_Storage_Pool); 605 pragma No_Return (Rcheck_SE_Explicit_Raise); 606 pragma No_Return (Rcheck_SE_Infinite_Recursion); 607 pragma No_Return (Rcheck_SE_Object_Too_Large); 608 609 pragma No_Return (Rcheck_CE_Access_Check_Ext); 610 pragma No_Return (Rcheck_CE_Index_Check_Ext); 611 pragma No_Return (Rcheck_CE_Invalid_Data_Ext); 612 pragma No_Return (Rcheck_CE_Range_Check_Ext); 613 614 --------------------------------------------- 615 -- Reason Strings for Run-Time Check Calls -- 616 --------------------------------------------- 617 618 -- These strings are null-terminated and are used by Rcheck_nn. The 619 -- strings correspond to the definitions for Types.RT_Exception_Code. 620 621 use ASCII; 622 623 Rmsg_00 : constant String := "access check failed" & NUL; 624 Rmsg_01 : constant String := "access parameter is null" & NUL; 625 Rmsg_02 : constant String := "discriminant check failed" & NUL; 626 Rmsg_03 : constant String := "divide by zero" & NUL; 627 Rmsg_04 : constant String := "explicit raise" & NUL; 628 Rmsg_05 : constant String := "index check failed" & NUL; 629 Rmsg_06 : constant String := "invalid data" & NUL; 630 Rmsg_07 : constant String := "length check failed" & NUL; 631 Rmsg_08 : constant String := "null Exception_Id" & NUL; 632 Rmsg_09 : constant String := "null-exclusion check failed" & NUL; 633 Rmsg_10 : constant String := "overflow check failed" & NUL; 634 Rmsg_11 : constant String := "partition check failed" & NUL; 635 Rmsg_12 : constant String := "range check failed" & NUL; 636 Rmsg_13 : constant String := "tag check failed" & NUL; 637 Rmsg_14 : constant String := "access before elaboration" & NUL; 638 Rmsg_15 : constant String := "accessibility check failed" & NUL; 639 Rmsg_16 : constant String := "attempt to take address of" & 640 " intrinsic subprogram" & NUL; 641 Rmsg_17 : constant String := "aliased parameters" & NUL; 642 Rmsg_18 : constant String := "all guards closed" & NUL; 643 Rmsg_19 : constant String := "improper use of generic subtype" & 644 " with predicate" & NUL; 645 Rmsg_20 : constant String := "Current_Task referenced in entry" & 646 " body" & NUL; 647 Rmsg_21 : constant String := "duplicated entry address" & NUL; 648 Rmsg_22 : constant String := "explicit raise" & NUL; 649 Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL; 650 Rmsg_24 : constant String := "implicit return with No_Return" & NUL; 651 Rmsg_25 : constant String := "misaligned address value" & NUL; 652 Rmsg_26 : constant String := "missing return" & NUL; 653 Rmsg_27 : constant String := "overlaid controlled object" & NUL; 654 Rmsg_28 : constant String := "potentially blocking operation" & NUL; 655 Rmsg_29 : constant String := "stubbed subprogram called" & NUL; 656 Rmsg_30 : constant String := "unchecked union restriction" & NUL; 657 Rmsg_31 : constant String := "actual/returned class-wide" & 658 " value not transportable" & NUL; 659 Rmsg_32 : constant String := "empty storage pool" & NUL; 660 Rmsg_33 : constant String := "explicit raise" & NUL; 661 Rmsg_34 : constant String := "infinite recursion" & NUL; 662 Rmsg_35 : constant String := "object too large" & NUL; 663 Rmsg_36 : constant String := "stream operation not allowed" & NUL; 664 665 ----------------------- 666 -- Polling Interface -- 667 ----------------------- 668 669 type Unsigned is mod 2 ** 32; 670 671 Counter : Unsigned := 0; 672 pragma Warnings (Off, Counter); 673 -- This counter is provided for convenience. It can be used in Poll to 674 -- perform periodic but not systematic operations. 675 676 procedure Poll is separate; 677 -- The actual polling routine is separate, so that it can easily be 678 -- replaced with a target dependent version. 679 680 -------------------------- 681 -- Code_Address_For_AAA -- 682 -------------------------- 683 684 -- This function gives us the start of the PC range for addresses within 685 -- the exception unit itself. We hope that gigi/gcc keep all the procedures 686 -- in their original order. 687 688 function Code_Address_For_AAA return System.Address is 689 begin 690 -- We are using a label instead of Code_Address_For_AAA'Address because 691 -- on some platforms the latter does not yield the address we want, but 692 -- the address of a stub or of a descriptor instead. This is the case at 693 -- least on PA-HPUX. 694 695 <<Start_Of_AAA>> 696 return Start_Of_AAA'Address; 697 end Code_Address_For_AAA; 698 699 ---------------- 700 -- Call_Chain -- 701 ---------------- 702 703 procedure Call_Chain (Excep : EOA) is separate; 704 -- The actual Call_Chain routine is separate, so that it can easily 705 -- be dummied out when no exception traceback information is needed. 706 707 ------------------- 708 -- EId_To_String -- 709 ------------------- 710 711 function EId_To_String (X : Exception_Id) return String 712 renames Stream_Attributes.EId_To_String; 713 714 ------------------ 715 -- EO_To_String -- 716 ------------------ 717 718 -- We use the null string to represent the null occurrence, otherwise we 719 -- output the Untailored_Exception_Information string for the occurrence. 720 721 function EO_To_String (X : Exception_Occurrence) return String 722 renames Stream_Attributes.EO_To_String; 723 724 ------------------------ 725 -- Exception_Identity -- 726 ------------------------ 727 728 function Exception_Identity 729 (X : Exception_Occurrence) return Exception_Id 730 is 731 begin 732 -- Note that the following test used to be here for the original 733 -- Ada 95 semantics, but these were modified by AI-241 to require 734 -- returning Null_Id instead of raising Constraint_Error. 735 736 -- if X.Id = Null_Id then 737 -- raise Constraint_Error; 738 -- end if; 739 740 return X.Id; 741 end Exception_Identity; 742 743 --------------------------- 744 -- Exception_Information -- 745 --------------------------- 746 747 function Exception_Information (X : Exception_Occurrence) return String is 748 begin 749 if X.Id = Null_Id then 750 raise Constraint_Error; 751 else 752 return Exception_Data.Exception_Information (X); 753 end if; 754 end Exception_Information; 755 756 ----------------------- 757 -- Exception_Message -- 758 ----------------------- 759 760 function Exception_Message (X : Exception_Occurrence) return String is 761 begin 762 if X.Id = Null_Id then 763 raise Constraint_Error; 764 else 765 return X.Msg (1 .. X.Msg_Length); 766 end if; 767 end Exception_Message; 768 769 -------------------- 770 -- Exception_Name -- 771 -------------------- 772 773 function Exception_Name (Id : Exception_Id) return String is 774 begin 775 if Id = null then 776 raise Constraint_Error; 777 else 778 return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); 779 end if; 780 end Exception_Name; 781 782 function Exception_Name (X : Exception_Occurrence) return String is 783 begin 784 return Exception_Name (X.Id); 785 end Exception_Name; 786 787 --------------------------- 788 -- Exception_Name_Simple -- 789 --------------------------- 790 791 function Exception_Name_Simple (X : Exception_Occurrence) return String is 792 Name : constant String := Exception_Name (X); 793 P : Natural; 794 795 begin 796 P := Name'Length; 797 while P > 1 loop 798 exit when Name (P - 1) = '.'; 799 P := P - 1; 800 end loop; 801 802 -- Return result making sure lower bound is 1 803 804 declare 805 subtype Rname is String (1 .. Name'Length - P + 1); 806 begin 807 return Rname (Name (P .. Name'Length)); 808 end; 809 end Exception_Name_Simple; 810 811 -------------------- 812 -- Exception_Data -- 813 -------------------- 814 815 package body Exception_Data is separate; 816 -- This package can be easily dummied out if we do not want the basic 817 -- support for exception messages (such as in Ada 83). 818 819 --------------------------- 820 -- Exception_Propagation -- 821 --------------------------- 822 823 package body Exception_Propagation is separate; 824 -- Depending on the actual exception mechanism used (front-end or 825 -- back-end based), the implementation will differ, which is why this 826 -- package is separated. 827 828 ---------------------- 829 -- Exception_Traces -- 830 ---------------------- 831 832 package body Exception_Traces is separate; 833 -- Depending on the underlying support for IO the implementation will 834 -- differ. Moreover we would like to dummy out this package in case we 835 -- do not want any exception tracing support. This is why this package 836 -- is separated. 837 838 -------------------------------------- 839 -- Get_Exception_Machine_Occurrence -- 840 -------------------------------------- 841 842 function Get_Exception_Machine_Occurrence 843 (X : Exception_Occurrence) return System.Address 844 is 845 begin 846 return X.Machine_Occurrence; 847 end Get_Exception_Machine_Occurrence; 848 849 ----------- 850 -- Image -- 851 ----------- 852 853 function Image (Index : Integer) return String is 854 Result : constant String := Integer'Image (Index); 855 begin 856 if Result (1) = ' ' then 857 return Result (2 .. Result'Last); 858 else 859 return Result; 860 end if; 861 end Image; 862 863 ----------------------- 864 -- Stream Attributes -- 865 ----------------------- 866 867 package body Stream_Attributes is separate; 868 -- This package can be easily dummied out if we do not want the 869 -- support for streaming Exception_Ids and Exception_Occurrences. 870 871 ---------------------------- 872 -- Raise_Constraint_Error -- 873 ---------------------------- 874 875 procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is 876 begin 877 Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line); 878 end Raise_Constraint_Error; 879 880 -------------------------------- 881 -- Raise_Constraint_Error_Msg -- 882 -------------------------------- 883 884 procedure Raise_Constraint_Error_Msg 885 (File : System.Address; 886 Line : Integer; 887 Column : Integer; 888 Msg : System.Address) 889 is 890 begin 891 Raise_With_Location_And_Msg 892 (Constraint_Error_Def'Access, File, Line, Column, Msg); 893 end Raise_Constraint_Error_Msg; 894 895 ------------------------- 896 -- Complete_Occurrence -- 897 ------------------------- 898 899 procedure Complete_Occurrence (X : EOA) is 900 begin 901 -- Compute the backtrace for this occurrence if the corresponding 902 -- binder option has been set. Call_Chain takes care of the reraise 903 -- case. 904 905 -- ??? Using Call_Chain here means we are going to walk up the stack 906 -- once only for backtracing purposes before doing it again for the 907 -- propagation per se. 908 909 -- The first inspection is much lighter, though, as it only requires 910 -- partial unwinding of each frame. Additionally, although we could use 911 -- the personality routine to record the addresses while propagating, 912 -- this method has two drawbacks: 913 914 -- 1) the trace is incomplete if the exception is handled since we 915 -- don't walk past the frame with the handler, 916 917 -- and 918 919 -- 2) we would miss the frames for which our personality routine is not 920 -- called, e.g. if C or C++ calls are on the way. 921 922 Call_Chain (X); 923 924 -- Notify the debugger 925 Debug_Raise_Exception 926 (E => SSL.Exception_Data_Ptr (X.Id), 927 Message => X.Msg (1 .. X.Msg_Length)); 928 end Complete_Occurrence; 929 930 --------------------------------------- 931 -- Complete_And_Propagate_Occurrence -- 932 --------------------------------------- 933 934 procedure Complete_And_Propagate_Occurrence (X : EOA) is 935 begin 936 Complete_Occurrence (X); 937 Exception_Propagation.Propagate_Exception (X); 938 end Complete_And_Propagate_Occurrence; 939 940 --------------------- 941 -- Raise_Exception -- 942 --------------------- 943 944 procedure Raise_Exception 945 (E : Exception_Id; 946 Message : String := "") 947 is 948 EF : Exception_Id := E; 949 begin 950 -- Raise CE if E = Null_ID (AI-446) 951 952 if E = null then 953 EF := Constraint_Error'Identity; 954 end if; 955 956 -- Go ahead and raise appropriate exception 957 958 Raise_Exception_Always (EF, Message); 959 end Raise_Exception; 960 961 ---------------------------- 962 -- Raise_Exception_Always -- 963 ---------------------------- 964 965 procedure Raise_Exception_Always 966 (E : Exception_Id; 967 Message : String := "") 968 is 969 X : constant EOA := Exception_Propagation.Allocate_Occurrence; 970 971 begin 972 Exception_Data.Set_Exception_Msg (X, E, Message); 973 974 if not ZCX_By_Default then 975 Abort_Defer.all; 976 end if; 977 978 Complete_And_Propagate_Occurrence (X); 979 end Raise_Exception_Always; 980 981 ------------------------------ 982 -- Raise_Exception_No_Defer -- 983 ------------------------------ 984 985 procedure Raise_Exception_No_Defer 986 (E : Exception_Id; 987 Message : String := "") 988 is 989 X : constant EOA := Exception_Propagation.Allocate_Occurrence; 990 991 begin 992 Exception_Data.Set_Exception_Msg (X, E, Message); 993 994 -- Do not call Abort_Defer.all, as specified by the spec 995 996 Complete_And_Propagate_Occurrence (X); 997 end Raise_Exception_No_Defer; 998 999 ------------------------------------- 1000 -- Raise_From_Controlled_Operation -- 1001 ------------------------------------- 1002 1003 procedure Raise_From_Controlled_Operation 1004 (X : Ada.Exceptions.Exception_Occurrence) 1005 is 1006 Prefix : constant String := "adjust/finalize raised "; 1007 Orig_Msg : constant String := Exception_Message (X); 1008 Orig_Prefix_Length : constant Natural := 1009 Integer'Min (Prefix'Length, Orig_Msg'Length); 1010 1011 Orig_Prefix : String renames 1012 Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); 1013 1014 begin 1015 -- Message already has the proper prefix, just re-raise 1016 1017 if Orig_Prefix = Prefix then 1018 Raise_Exception_No_Defer 1019 (E => Program_Error'Identity, 1020 Message => Orig_Msg); 1021 1022 else 1023 declare 1024 New_Msg : constant String := Prefix & Exception_Name (X); 1025 1026 begin 1027 -- No message present, just provide our own 1028 1029 if Orig_Msg = "" then 1030 Raise_Exception_No_Defer 1031 (E => Program_Error'Identity, 1032 Message => New_Msg); 1033 1034 -- Message present, add informational prefix 1035 1036 else 1037 Raise_Exception_No_Defer 1038 (E => Program_Error'Identity, 1039 Message => New_Msg & ": " & Orig_Msg); 1040 end if; 1041 end; 1042 end if; 1043 end Raise_From_Controlled_Operation; 1044 1045 ------------------------------------------- 1046 -- Create_Occurrence_From_Signal_Handler -- 1047 ------------------------------------------- 1048 1049 function Create_Occurrence_From_Signal_Handler 1050 (E : Exception_Id; 1051 M : System.Address) return EOA 1052 is 1053 X : constant EOA := Exception_Propagation.Allocate_Occurrence; 1054 1055 begin 1056 Exception_Data.Set_Exception_C_Msg (X, E, M); 1057 1058 if not ZCX_By_Default then 1059 Abort_Defer.all; 1060 end if; 1061 1062 Complete_Occurrence (X); 1063 return X; 1064 end Create_Occurrence_From_Signal_Handler; 1065 1066 --------------------------------------------------- 1067 -- Create_Machine_Occurrence_From_Signal_Handler -- 1068 --------------------------------------------------- 1069 1070 function Create_Machine_Occurrence_From_Signal_Handler 1071 (E : Exception_Id; 1072 M : System.Address) return System.Address 1073 is 1074 begin 1075 return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence; 1076 end Create_Machine_Occurrence_From_Signal_Handler; 1077 1078 ------------------------------- 1079 -- Raise_From_Signal_Handler -- 1080 ------------------------------- 1081 1082 procedure Raise_From_Signal_Handler 1083 (E : Exception_Id; 1084 M : System.Address) 1085 is 1086 begin 1087 Exception_Propagation.Propagate_Exception 1088 (Create_Occurrence_From_Signal_Handler (E, M)); 1089 end Raise_From_Signal_Handler; 1090 1091 ------------------------- 1092 -- Raise_Program_Error -- 1093 ------------------------- 1094 1095 procedure Raise_Program_Error 1096 (File : System.Address; 1097 Line : Integer) 1098 is 1099 begin 1100 Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line); 1101 end Raise_Program_Error; 1102 1103 ----------------------------- 1104 -- Raise_Program_Error_Msg -- 1105 ----------------------------- 1106 1107 procedure Raise_Program_Error_Msg 1108 (File : System.Address; 1109 Line : Integer; 1110 Msg : System.Address) 1111 is 1112 begin 1113 Raise_With_Location_And_Msg 1114 (Program_Error_Def'Access, File, Line, M => Msg); 1115 end Raise_Program_Error_Msg; 1116 1117 ------------------------- 1118 -- Raise_Storage_Error -- 1119 ------------------------- 1120 1121 procedure Raise_Storage_Error 1122 (File : System.Address; 1123 Line : Integer) 1124 is 1125 begin 1126 Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line); 1127 end Raise_Storage_Error; 1128 1129 ----------------------------- 1130 -- Raise_Storage_Error_Msg -- 1131 ----------------------------- 1132 1133 procedure Raise_Storage_Error_Msg 1134 (File : System.Address; 1135 Line : Integer; 1136 Msg : System.Address) 1137 is 1138 begin 1139 Raise_With_Location_And_Msg 1140 (Storage_Error_Def'Access, File, Line, M => Msg); 1141 end Raise_Storage_Error_Msg; 1142 1143 --------------------------------- 1144 -- Raise_With_Location_And_Msg -- 1145 --------------------------------- 1146 1147 procedure Raise_With_Location_And_Msg 1148 (E : Exception_Id; 1149 F : System.Address; 1150 L : Integer; 1151 C : Integer := 0; 1152 M : System.Address := System.Null_Address) 1153 is 1154 X : constant EOA := Exception_Propagation.Allocate_Occurrence; 1155 begin 1156 Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M); 1157 1158 if not ZCX_By_Default then 1159 Abort_Defer.all; 1160 end if; 1161 1162 Complete_And_Propagate_Occurrence (X); 1163 end Raise_With_Location_And_Msg; 1164 1165 -------------------- 1166 -- Raise_With_Msg -- 1167 -------------------- 1168 1169 procedure Raise_With_Msg (E : Exception_Id) is 1170 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; 1171 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; 1172 begin 1173 Excep.Exception_Raised := False; 1174 Excep.Id := E; 1175 Excep.Num_Tracebacks := 0; 1176 Excep.Pid := Local_Partition_ID; 1177 1178 -- Copy the message from the current exception 1179 -- Change the interface to be called with an occurrence ??? 1180 1181 Excep.Msg_Length := Ex.Msg_Length; 1182 Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length); 1183 1184 -- The following is a common pattern, should be abstracted 1185 -- into a procedure call ??? 1186 1187 if not ZCX_By_Default then 1188 Abort_Defer.all; 1189 end if; 1190 1191 Complete_And_Propagate_Occurrence (Excep); 1192 end Raise_With_Msg; 1193 1194 ----------------------------------------- 1195 -- Calls to Run-Time Check Subprograms -- 1196 ----------------------------------------- 1197 1198 procedure Rcheck_CE_Access_Check 1199 (File : System.Address; Line : Integer) 1200 is 1201 begin 1202 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address); 1203 end Rcheck_CE_Access_Check; 1204 1205 procedure Rcheck_CE_Null_Access_Parameter 1206 (File : System.Address; Line : Integer) 1207 is 1208 begin 1209 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address); 1210 end Rcheck_CE_Null_Access_Parameter; 1211 1212 procedure Rcheck_CE_Discriminant_Check 1213 (File : System.Address; Line : Integer) 1214 is 1215 begin 1216 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address); 1217 end Rcheck_CE_Discriminant_Check; 1218 1219 procedure Rcheck_CE_Divide_By_Zero 1220 (File : System.Address; Line : Integer) 1221 is 1222 begin 1223 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address); 1224 end Rcheck_CE_Divide_By_Zero; 1225 1226 procedure Rcheck_CE_Explicit_Raise 1227 (File : System.Address; Line : Integer) 1228 is 1229 begin 1230 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address); 1231 end Rcheck_CE_Explicit_Raise; 1232 1233 procedure Rcheck_CE_Index_Check 1234 (File : System.Address; Line : Integer) 1235 is 1236 begin 1237 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address); 1238 end Rcheck_CE_Index_Check; 1239 1240 procedure Rcheck_CE_Invalid_Data 1241 (File : System.Address; Line : Integer) 1242 is 1243 begin 1244 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address); 1245 end Rcheck_CE_Invalid_Data; 1246 1247 procedure Rcheck_CE_Length_Check 1248 (File : System.Address; Line : Integer) 1249 is 1250 begin 1251 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address); 1252 end Rcheck_CE_Length_Check; 1253 1254 procedure Rcheck_CE_Null_Exception_Id 1255 (File : System.Address; Line : Integer) 1256 is 1257 begin 1258 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address); 1259 end Rcheck_CE_Null_Exception_Id; 1260 1261 procedure Rcheck_CE_Null_Not_Allowed 1262 (File : System.Address; Line : Integer) 1263 is 1264 begin 1265 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address); 1266 end Rcheck_CE_Null_Not_Allowed; 1267 1268 procedure Rcheck_CE_Overflow_Check 1269 (File : System.Address; Line : Integer) 1270 is 1271 begin 1272 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address); 1273 end Rcheck_CE_Overflow_Check; 1274 1275 procedure Rcheck_CE_Partition_Check 1276 (File : System.Address; Line : Integer) 1277 is 1278 begin 1279 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address); 1280 end Rcheck_CE_Partition_Check; 1281 1282 procedure Rcheck_CE_Range_Check 1283 (File : System.Address; Line : Integer) 1284 is 1285 begin 1286 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address); 1287 end Rcheck_CE_Range_Check; 1288 1289 procedure Rcheck_CE_Tag_Check 1290 (File : System.Address; Line : Integer) 1291 is 1292 begin 1293 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address); 1294 end Rcheck_CE_Tag_Check; 1295 1296 procedure Rcheck_PE_Access_Before_Elaboration 1297 (File : System.Address; Line : Integer) 1298 is 1299 begin 1300 Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); 1301 end Rcheck_PE_Access_Before_Elaboration; 1302 1303 procedure Rcheck_PE_Accessibility_Check 1304 (File : System.Address; Line : Integer) 1305 is 1306 begin 1307 Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); 1308 end Rcheck_PE_Accessibility_Check; 1309 1310 procedure Rcheck_PE_Address_Of_Intrinsic 1311 (File : System.Address; Line : Integer) 1312 is 1313 begin 1314 Raise_Program_Error_Msg (File, Line, Rmsg_16'Address); 1315 end Rcheck_PE_Address_Of_Intrinsic; 1316 1317 procedure Rcheck_PE_Aliased_Parameters 1318 (File : System.Address; Line : Integer) 1319 is 1320 begin 1321 Raise_Program_Error_Msg (File, Line, Rmsg_17'Address); 1322 end Rcheck_PE_Aliased_Parameters; 1323 1324 procedure Rcheck_PE_All_Guards_Closed 1325 (File : System.Address; Line : Integer) 1326 is 1327 begin 1328 Raise_Program_Error_Msg (File, Line, Rmsg_18'Address); 1329 end Rcheck_PE_All_Guards_Closed; 1330 1331 procedure Rcheck_PE_Bad_Predicated_Generic_Type 1332 (File : System.Address; Line : Integer) 1333 is 1334 begin 1335 Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); 1336 end Rcheck_PE_Bad_Predicated_Generic_Type; 1337 1338 procedure Rcheck_PE_Current_Task_In_Entry_Body 1339 (File : System.Address; Line : Integer) 1340 is 1341 begin 1342 Raise_Program_Error_Msg (File, Line, Rmsg_20'Address); 1343 end Rcheck_PE_Current_Task_In_Entry_Body; 1344 1345 procedure Rcheck_PE_Duplicated_Entry_Address 1346 (File : System.Address; Line : Integer) 1347 is 1348 begin 1349 Raise_Program_Error_Msg (File, Line, Rmsg_21'Address); 1350 end Rcheck_PE_Duplicated_Entry_Address; 1351 1352 procedure Rcheck_PE_Explicit_Raise 1353 (File : System.Address; Line : Integer) 1354 is 1355 begin 1356 Raise_Program_Error_Msg (File, Line, Rmsg_22'Address); 1357 end Rcheck_PE_Explicit_Raise; 1358 1359 procedure Rcheck_PE_Implicit_Return 1360 (File : System.Address; Line : Integer) 1361 is 1362 begin 1363 Raise_Program_Error_Msg (File, Line, Rmsg_24'Address); 1364 end Rcheck_PE_Implicit_Return; 1365 1366 procedure Rcheck_PE_Misaligned_Address_Value 1367 (File : System.Address; Line : Integer) 1368 is 1369 begin 1370 Raise_Program_Error_Msg (File, Line, Rmsg_25'Address); 1371 end Rcheck_PE_Misaligned_Address_Value; 1372 1373 procedure Rcheck_PE_Missing_Return 1374 (File : System.Address; Line : Integer) 1375 is 1376 begin 1377 Raise_Program_Error_Msg (File, Line, Rmsg_26'Address); 1378 end Rcheck_PE_Missing_Return; 1379 1380 procedure Rcheck_PE_Non_Transportable_Actual 1381 (File : System.Address; Line : Integer) 1382 is 1383 begin 1384 Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); 1385 end Rcheck_PE_Non_Transportable_Actual; 1386 1387 procedure Rcheck_PE_Overlaid_Controlled_Object 1388 (File : System.Address; Line : Integer) 1389 is 1390 begin 1391 Raise_Program_Error_Msg (File, Line, Rmsg_27'Address); 1392 end Rcheck_PE_Overlaid_Controlled_Object; 1393 1394 procedure Rcheck_PE_Potentially_Blocking_Operation 1395 (File : System.Address; Line : Integer) 1396 is 1397 begin 1398 Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); 1399 end Rcheck_PE_Potentially_Blocking_Operation; 1400 1401 procedure Rcheck_PE_Stream_Operation_Not_Allowed 1402 (File : System.Address; Line : Integer) 1403 is 1404 begin 1405 Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); 1406 end Rcheck_PE_Stream_Operation_Not_Allowed; 1407 1408 procedure Rcheck_PE_Stubbed_Subprogram_Called 1409 (File : System.Address; Line : Integer) 1410 is 1411 begin 1412 Raise_Program_Error_Msg (File, Line, Rmsg_29'Address); 1413 end Rcheck_PE_Stubbed_Subprogram_Called; 1414 1415 procedure Rcheck_PE_Unchecked_Union_Restriction 1416 (File : System.Address; Line : Integer) 1417 is 1418 begin 1419 Raise_Program_Error_Msg (File, Line, Rmsg_30'Address); 1420 end Rcheck_PE_Unchecked_Union_Restriction; 1421 1422 procedure Rcheck_SE_Empty_Storage_Pool 1423 (File : System.Address; Line : Integer) 1424 is 1425 begin 1426 Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address); 1427 end Rcheck_SE_Empty_Storage_Pool; 1428 1429 procedure Rcheck_SE_Explicit_Raise 1430 (File : System.Address; Line : Integer) 1431 is 1432 begin 1433 Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address); 1434 end Rcheck_SE_Explicit_Raise; 1435 1436 procedure Rcheck_SE_Infinite_Recursion 1437 (File : System.Address; Line : Integer) 1438 is 1439 begin 1440 Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address); 1441 end Rcheck_SE_Infinite_Recursion; 1442 1443 procedure Rcheck_SE_Object_Too_Large 1444 (File : System.Address; Line : Integer) 1445 is 1446 begin 1447 Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address); 1448 end Rcheck_SE_Object_Too_Large; 1449 1450 procedure Rcheck_CE_Access_Check_Ext 1451 (File : System.Address; Line, Column : Integer) 1452 is 1453 begin 1454 Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address); 1455 end Rcheck_CE_Access_Check_Ext; 1456 1457 procedure Rcheck_CE_Index_Check_Ext 1458 (File : System.Address; Line, Column, Index, First, Last : Integer) 1459 is 1460 Msg : constant String := 1461 Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF 1462 & "index " & Image (Index) & " not in " & Image (First) 1463 & ".." & Image (Last) & ASCII.NUL; 1464 begin 1465 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); 1466 end Rcheck_CE_Index_Check_Ext; 1467 1468 procedure Rcheck_CE_Invalid_Data_Ext 1469 (File : System.Address; Line, Column, Index, First, Last : Integer) 1470 is 1471 Msg : constant String := 1472 Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF 1473 & "value " & Image (Index) & " not in " & Image (First) 1474 & ".." & Image (Last) & ASCII.NUL; 1475 begin 1476 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); 1477 end Rcheck_CE_Invalid_Data_Ext; 1478 1479 procedure Rcheck_CE_Range_Check_Ext 1480 (File : System.Address; Line, Column, Index, First, Last : Integer) 1481 is 1482 Msg : constant String := 1483 Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF 1484 & "value " & Image (Index) & " not in " & Image (First) 1485 & ".." & Image (Last) & ASCII.NUL; 1486 begin 1487 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); 1488 end Rcheck_CE_Range_Check_Ext; 1489 1490 procedure Rcheck_PE_Finalize_Raised_Exception 1491 (File : System.Address; Line : Integer) 1492 is 1493 X : constant EOA := Exception_Propagation.Allocate_Occurrence; 1494 1495 begin 1496 -- This is "finalize/adjust raised exception". This subprogram is always 1497 -- called with abort deferred, unlike all other Rcheck_* subprograms, it 1498 -- needs to call Raise_Exception_No_Defer. 1499 1500 -- This is consistent with Raise_From_Controlled_Operation 1501 1502 Exception_Data.Set_Exception_C_Msg 1503 (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address); 1504 Complete_And_Propagate_Occurrence (X); 1505 end Rcheck_PE_Finalize_Raised_Exception; 1506 1507 ------------- 1508 -- Reraise -- 1509 ------------- 1510 1511 procedure Reraise is 1512 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; 1513 Saved_MO : constant System.Address := Excep.Machine_Occurrence; 1514 1515 begin 1516 if not ZCX_By_Default then 1517 Abort_Defer.all; 1518 end if; 1519 1520 Save_Occurrence (Excep.all, Get_Current_Excep.all.all); 1521 Excep.Machine_Occurrence := Saved_MO; 1522 Complete_And_Propagate_Occurrence (Excep); 1523 end Reraise; 1524 1525 -------------------------------------- 1526 -- Reraise_Library_Exception_If_Any -- 1527 -------------------------------------- 1528 1529 procedure Reraise_Library_Exception_If_Any is 1530 LE : Exception_Occurrence; 1531 1532 begin 1533 if Library_Exception_Set then 1534 LE := Library_Exception; 1535 1536 if LE.Id = Null_Id then 1537 Raise_Exception_No_Defer 1538 (E => Program_Error'Identity, 1539 Message => "finalize/adjust raised exception"); 1540 else 1541 Raise_From_Controlled_Operation (LE); 1542 end if; 1543 end if; 1544 end Reraise_Library_Exception_If_Any; 1545 1546 ------------------------ 1547 -- Reraise_Occurrence -- 1548 ------------------------ 1549 1550 procedure Reraise_Occurrence (X : Exception_Occurrence) is 1551 begin 1552 if X.Id = null then 1553 return; 1554 else 1555 Reraise_Occurrence_Always (X); 1556 end if; 1557 end Reraise_Occurrence; 1558 1559 ------------------------------- 1560 -- Reraise_Occurrence_Always -- 1561 ------------------------------- 1562 1563 procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is 1564 begin 1565 if not ZCX_By_Default then 1566 Abort_Defer.all; 1567 end if; 1568 1569 Reraise_Occurrence_No_Defer (X); 1570 end Reraise_Occurrence_Always; 1571 1572 --------------------------------- 1573 -- Reraise_Occurrence_No_Defer -- 1574 --------------------------------- 1575 1576 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is 1577 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; 1578 Saved_MO : constant System.Address := Excep.Machine_Occurrence; 1579 begin 1580 Save_Occurrence (Excep.all, X); 1581 Excep.Machine_Occurrence := Saved_MO; 1582 Complete_And_Propagate_Occurrence (Excep); 1583 end Reraise_Occurrence_No_Defer; 1584 1585 --------------------- 1586 -- Save_Occurrence -- 1587 --------------------- 1588 1589 procedure Save_Occurrence 1590 (Target : out Exception_Occurrence; 1591 Source : Exception_Occurrence) 1592 is 1593 begin 1594 -- As the machine occurrence might be a data that must be finalized 1595 -- (outside any Ada mechanism), do not copy it 1596 1597 Target.Id := Source.Id; 1598 Target.Machine_Occurrence := System.Null_Address; 1599 Target.Msg_Length := Source.Msg_Length; 1600 Target.Num_Tracebacks := Source.Num_Tracebacks; 1601 Target.Pid := Source.Pid; 1602 1603 Target.Msg (1 .. Target.Msg_Length) := 1604 Source.Msg (1 .. Target.Msg_Length); 1605 1606 Target.Tracebacks (1 .. Target.Num_Tracebacks) := 1607 Source.Tracebacks (1 .. Target.Num_Tracebacks); 1608 end Save_Occurrence; 1609 1610 function Save_Occurrence (Source : Exception_Occurrence) return EOA is 1611 Target : constant EOA := new Exception_Occurrence; 1612 begin 1613 Save_Occurrence (Target.all, Source); 1614 return Target; 1615 end Save_Occurrence; 1616 1617 ------------------- 1618 -- String_To_EId -- 1619 ------------------- 1620 1621 function String_To_EId (S : String) return Exception_Id 1622 renames Stream_Attributes.String_To_EId; 1623 1624 ------------------ 1625 -- String_To_EO -- 1626 ------------------ 1627 1628 function String_To_EO (S : String) return Exception_Occurrence 1629 renames Stream_Attributes.String_To_EO; 1630 1631 --------------- 1632 -- To_Stderr -- 1633 --------------- 1634 1635 procedure To_Stderr (C : Character) is 1636 procedure Put_Char_Stderr (C : Character); 1637 pragma Import (C, Put_Char_Stderr, "put_char_stderr"); 1638 begin 1639 Put_Char_Stderr (C); 1640 end To_Stderr; 1641 1642 procedure To_Stderr (S : String) is 1643 begin 1644 for J in S'Range loop 1645 if S (J) /= ASCII.CR then 1646 To_Stderr (S (J)); 1647 end if; 1648 end loop; 1649 end To_Stderr; 1650 1651 ------------------------- 1652 -- Transfer_Occurrence -- 1653 ------------------------- 1654 1655 procedure Transfer_Occurrence 1656 (Target : Exception_Occurrence_Access; 1657 Source : Exception_Occurrence) 1658 is 1659 begin 1660 Save_Occurrence (Target.all, Source); 1661 end Transfer_Occurrence; 1662 1663 ------------------------ 1664 -- Triggered_By_Abort -- 1665 ------------------------ 1666 1667 function Triggered_By_Abort return Boolean is 1668 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; 1669 begin 1670 return Ex /= null 1671 and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; 1672 end Triggered_By_Abort; 1673 1674 ------------------------- 1675 -- Wide_Exception_Name -- 1676 ------------------------- 1677 1678 WC_Encoding : Character; 1679 pragma Import (C, WC_Encoding, "__gl_wc_encoding"); 1680 -- Encoding method for source, as exported by binder 1681 1682 function Wide_Exception_Name 1683 (Id : Exception_Id) return Wide_String 1684 is 1685 S : constant String := Exception_Name (Id); 1686 W : Wide_String (1 .. S'Length); 1687 L : Natural; 1688 begin 1689 String_To_Wide_String 1690 (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); 1691 return W (1 .. L); 1692 end Wide_Exception_Name; 1693 1694 function Wide_Exception_Name 1695 (X : Exception_Occurrence) return Wide_String 1696 is 1697 S : constant String := Exception_Name (X); 1698 W : Wide_String (1 .. S'Length); 1699 L : Natural; 1700 begin 1701 String_To_Wide_String 1702 (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); 1703 return W (1 .. L); 1704 end Wide_Exception_Name; 1705 1706 ---------------------------- 1707 -- Wide_Wide_Exception_Name -- 1708 ----------------------------- 1709 1710 function Wide_Wide_Exception_Name 1711 (Id : Exception_Id) return Wide_Wide_String 1712 is 1713 S : constant String := Exception_Name (Id); 1714 W : Wide_Wide_String (1 .. S'Length); 1715 L : Natural; 1716 begin 1717 String_To_Wide_Wide_String 1718 (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); 1719 return W (1 .. L); 1720 end Wide_Wide_Exception_Name; 1721 1722 function Wide_Wide_Exception_Name 1723 (X : Exception_Occurrence) return Wide_Wide_String 1724 is 1725 S : constant String := Exception_Name (X); 1726 W : Wide_Wide_String (1 .. S'Length); 1727 L : Natural; 1728 begin 1729 String_To_Wide_Wide_String 1730 (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); 1731 return W (1 .. L); 1732 end Wide_Wide_Exception_Name; 1733 1734 -------------------------- 1735 -- Code_Address_For_ZZZ -- 1736 -------------------------- 1737 1738 -- This function gives us the end of the PC range for addresses 1739 -- within the exception unit itself. We hope that gigi/gcc keeps all the 1740 -- procedures in their original order. 1741 1742 function Code_Address_For_ZZZ return System.Address is 1743 begin 1744 <<Start_Of_ZZZ>> 1745 return Start_Of_ZZZ'Address; 1746 end Code_Address_For_ZZZ; 1747 1748end Ada.Exceptions; 1749