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