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