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