gcc/ada/a-exexda.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       ADA.EXCEPTIONS.EXCEPTION_DATA                      --
   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 with System.Storage_Elements; use System.Storage_Elements;
  33
  34 separate (Ada.Exceptions)
  35 package body Exception_Data is
  36
  37    --  This unit implements the Exception_Information related services for
  38    --  both the Ada standard requirements and the GNAT.Exception_Traces
  39    --  facility. This is also used by the implementation of the stream
  40    --  attributes of types Exception_Id and Exception_Occurrence.
  41
  42    --  There are common parts between the contents of Exception_Information
  43    --  (the regular Ada interface) and Untailored_Exception_Information (used
  44    --  for streaming, and when there is no symbolic traceback available) The
  45    --  overall structure is sketched below:
  46
  47    --
  48    --                 Untailored_Exception_Information
  49    --                               |
  50    --                       +-------+--------+
  51    --                       |                |
  52    --                Basic_Exc_Info & Untailored_Exc_Tback
  53    --                    (B_E_I)         (U_E_TB)
  54
  55    --           o--
  56    --  (B_E_I)  |  Exception_Name: <exception name> (as in Exception_Name)
  57    --           |  Message: <message> (or a null line if no message)
  58    --           |  PID=nnnn (if != 0)
  59    --           o--
  60    --  (U_E_TB) |  Call stack traceback locations:
  61    --           |  <0xyyyyyyyy 0xyyyyyyyy ...>
  62    --           o--
  63
  64    --                     Exception_Information
  65    --                               |
  66    --                    +----------+----------+
  67    --                    |                     |
  68    --             Basic_Exc_Info    &      traceback
  69    --                                          |
  70    --                              +-----------+------------+
  71    --                              |                        |
  72    --                     Untailored_Exc_Tback    Or    Tback_Decorator
  73    --                     if no decorator set           otherwise
  74
  75    --  Functions returning String imply secondary stack use, which is a heavy
  76    --  mechanism requiring run-time support. Besides, some of the routines we
  77    --  provide here are to be used by the default Last_Chance_Handler, at the
  78    --  critical point where the runtime is about to be finalized. Since most
  79    --  of the items we have at hand are of bounded length, we also provide a
  80    --  procedural interface able to incrementally append the necessary bits to
  81    --  a preallocated buffer or output them straight to stderr.
  82
  83    --  The procedural interface is composed of two major sections: a neutral
  84    --  section for basic types like Address, Character, Natural or String, and
  85    --  an exception oriented section for the exception names, messages, and
  86    --  information. This is the Append_Info family of procedures below.
  87
  88    --  Output to stderr is commanded by passing an empty buffer to update, and
  89    --  care is taken not to overflow otherwise.
  90
  91    --------------------------------------------
  92    -- Procedural Interface - Neutral section --
  93    --------------------------------------------
  94
  95    procedure Append_Info_Address
  96      (A    : Address;
  97       Info : in out String;
  98       Ptr  : in out Natural);
  99
 100    procedure Append_Info_Character
 101      (C    : Character;
 102       Info : in out String;
 103       Ptr  : in out Natural);
 104
 105    procedure Append_Info_Nat
 106      (N    : Natural;
 107       Info : in out String;
 108       Ptr  : in out Natural);
 109
 110    procedure Append_Info_NL
 111      (Info : in out String;
 112       Ptr  : in out Natural);
 113    pragma Inline (Append_Info_NL);
 114
 115    procedure Append_Info_String
 116      (S    : String;
 117       Info : in out String;
 118       Ptr  : in out Natural);
 119
 120    -------------------------------------------------------
 121    -- Procedural Interface - Exception oriented section --
 122    -------------------------------------------------------
 123
 124    procedure Append_Info_Exception_Name
 125      (Id   : Exception_Id;
 126       Info : in out String;
 127       Ptr  : in out Natural);
 128
 129    procedure Append_Info_Exception_Name
 130      (X    : Exception_Occurrence;
 131       Info : in out String;
 132       Ptr  : in out Natural);
 133
 134    procedure Append_Info_Exception_Message
 135      (X    : Exception_Occurrence;
 136       Info : in out String;
 137       Ptr  : in out Natural);
 138
 139    procedure Append_Info_Basic_Exception_Information
 140      (X    : Exception_Occurrence;
 141       Info : in out String;
 142       Ptr  : in out Natural);
 143
 144    procedure Append_Info_Untailored_Exception_Traceback
 145      (X    : Exception_Occurrence;
 146       Info : in out String;
 147       Ptr  : in out Natural);
 148
 149    procedure Append_Info_Untailored_Exception_Information
 150      (X    : Exception_Occurrence;
 151       Info : in out String;
 152       Ptr  : in out Natural);
 153
 154    --  The "functional" interface to the exception information not involving
 155    --  a traceback decorator uses preallocated intermediate buffers to avoid
 156    --  the use of secondary stack. Preallocation requires preliminary length
 157    --  computation, for which a series of functions are introduced:
 158
 159    ---------------------------------
 160    -- Length evaluation utilities --
 161    ---------------------------------
 162
 163    function Basic_Exception_Info_Maxlength
 164      (X : Exception_Occurrence) return Natural;
 165
 166    function Untailored_Exception_Traceback_Maxlength
 167      (X : Exception_Occurrence) return Natural;
 168
 169    function Exception_Info_Maxlength
 170      (X : Exception_Occurrence) return Natural;
 171
 172    function Exception_Name_Length
 173      (Id : Exception_Id) return Natural;
 174
 175    function Exception_Name_Length
 176      (X : Exception_Occurrence) return Natural;
 177
 178    function Exception_Message_Length
 179      (X : Exception_Occurrence) return Natural;
 180
 181    --------------------------
 182    -- Functional Interface --
 183    --------------------------
 184
 185    function Untailored_Exception_Traceback
 186      (X : Exception_Occurrence) return String;
 187    --  Returns an image of the complete call chain associated with an
 188    --  exception occurrence in its most basic form, that is as a raw sequence
 189    --  of hexadecimal addresses.
 190
 191    function Tailored_Exception_Traceback
 192      (X : Exception_Occurrence) return String;
 193    --  Returns an image of the complete call chain associated with an
 194    --  exception occurrence, either in its basic form if no decorator is
 195    --  in place, or as formatted by the decorator otherwise.
 196
 197    -----------------------------------------------------------------------
 198    -- Services for the default Last_Chance_Handler and the task wrapper --
 199    -----------------------------------------------------------------------
 200
 201    pragma Export
 202      (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
 203
 204    pragma Export
 205      (Ada, Append_Info_Untailored_Exception_Information,
 206       "__gnat_append_info_u_e_info");
 207
 208    pragma Export
 209      (Ada, Exception_Message_Length, "__gnat_exception_msg_len");
 210
 211    function Get_Executable_Load_Address return System.Address;
 212    pragma Import (C, Get_Executable_Load_Address,
 213                   "__gnat_get_executable_load_address");
 214    --  Get the load address of the executable, or Null_Address if not known
 215
 216    -------------------------
 217    -- Append_Info_Address --
 218    -------------------------
 219
 220    procedure Append_Info_Address
 221      (A    : Address;
 222       Info : in out String;
 223       Ptr  : in out Natural)
 224    is
 225       S : String (1 .. 18);
 226       P : Natural;
 227       N : Integer_Address;
 228
 229       H : constant array (Integer range 0 .. 15) of Character :=
 230         "0123456789abcdef";
 231    begin
 232       P := S'Last;
 233       N := To_Integer (A);
 234       loop
 235          S (P) := H (Integer (N mod 16));
 236          P := P - 1;
 237          N := N / 16;
 238          exit when N = 0;
 239       end loop;
 240
 241       S (P - 1) := '0';
 242       S (P) := 'x';
 243
 244       Append_Info_String (S (P - 1 .. S'Last), Info, Ptr);
 245    end Append_Info_Address;
 246
 247    ---------------------------
 248    -- Append_Info_Character --
 249    ---------------------------
 250
 251    procedure Append_Info_Character
 252      (C    : Character;
 253       Info : in out String;
 254       Ptr  : in out Natural)
 255    is
 256    begin
 257       if Info'Length = 0 then
 258          To_Stderr (C);
 259       elsif Ptr < Info'Last then
 260          Ptr := Ptr + 1;
 261          Info (Ptr) := C;
 262       end if;
 263    end Append_Info_Character;
 264
 265    ---------------------
 266    -- Append_Info_Nat --
 267    ---------------------
 268
 269    procedure Append_Info_Nat
 270      (N    : Natural;
 271       Info : in out String;
 272       Ptr  : in out Natural)
 273    is
 274    begin
 275       if N > 9 then
 276          Append_Info_Nat (N / 10, Info, Ptr);
 277       end if;
 278
 279       Append_Info_Character
 280         (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr);
 281    end Append_Info_Nat;
 282
 283    --------------------
 284    -- Append_Info_NL --
 285    --------------------
 286
 287    procedure Append_Info_NL
 288      (Info : in out String;
 289       Ptr  : in out Natural)
 290    is
 291    begin
 292       Append_Info_Character (ASCII.LF, Info, Ptr);
 293    end Append_Info_NL;
 294
 295    ------------------------
 296    -- Append_Info_String --
 297    ------------------------
 298
 299    procedure Append_Info_String
 300      (S    : String;
 301       Info : in out String;
 302       Ptr  : in out Natural)
 303    is
 304    begin
 305       if Info'Length = 0 then
 306          To_Stderr (S);
 307       else
 308          declare
 309             Last : constant Natural :=
 310               Integer'Min (Ptr + S'Length, Info'Last);
 311          begin
 312             Info (Ptr + 1 .. Last) := S;
 313             Ptr := Last;
 314          end;
 315       end if;
 316    end Append_Info_String;
 317
 318    ---------------------------------------------
 319    -- Append_Info_Basic_Exception_Information --
 320    ---------------------------------------------
 321
 322    --  To ease the maximum length computation, we define and pull out a couple
 323    --  of string constants:
 324
 325    BEI_Name_Header : constant String := "Exception name: ";
 326    BEI_Msg_Header  : constant String := "Message: ";
 327    BEI_PID_Header  : constant String := "PID: ";
 328
 329    procedure Append_Info_Basic_Exception_Information
 330      (X    : Exception_Occurrence;
 331       Info : in out String;
 332       Ptr  : in out Natural)
 333    is
 334       Name : String (1 .. Exception_Name_Length (X));
 335       --  Buffer in which to fetch the exception name, in order to check
 336       --  whether this is an internal _ABORT_SIGNAL or a regular occurrence.
 337
 338       Name_Ptr : Natural := Name'First - 1;
 339
 340    begin
 341       --  Output exception name and message except for _ABORT_SIGNAL, where
 342       --  these two lines are omitted.
 343
 344       Append_Info_Exception_Name (X, Name, Name_Ptr);
 345
 346       if Name (Name'First) /= '_' then
 347          Append_Info_String (BEI_Name_Header, Info, Ptr);
 348          Append_Info_String (Name, Info, Ptr);
 349          Append_Info_NL (Info, Ptr);
 350
 351          if Exception_Message_Length (X) /= 0 then
 352             Append_Info_String (BEI_Msg_Header, Info, Ptr);
 353             Append_Info_Exception_Message  (X, Info, Ptr);
 354             Append_Info_NL (Info, Ptr);
 355          end if;
 356       end if;
 357
 358       --  Output PID line if non-zero
 359
 360       if X.Pid /= 0 then
 361          Append_Info_String (BEI_PID_Header, Info, Ptr);
 362          Append_Info_Nat (X.Pid, Info, Ptr);
 363          Append_Info_NL (Info, Ptr);
 364       end if;
 365    end Append_Info_Basic_Exception_Information;
 366
 367    -------------------------------------------
 368    -- Basic_Exception_Information_Maxlength --
 369    -------------------------------------------
 370
 371    function Basic_Exception_Info_Maxlength
 372      (X : Exception_Occurrence) return Natural is
 373    begin
 374       return
 375         BEI_Name_Header'Length + Exception_Name_Length (X) + 1
 376         + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1
 377         + BEI_PID_Header'Length + 15;
 378    end Basic_Exception_Info_Maxlength;
 379
 380    ------------------------------------------------
 381    -- Append_Info_Untailored_Exception_Traceback --
 382    ------------------------------------------------
 383
 384    --  As for Basic_Exception_Information:
 385
 386    BETB_Header : constant String := "Call stack traceback locations:";
 387    LDAD_Header : constant String := "Load address: ";
 388
 389    procedure Append_Info_Untailored_Exception_Traceback
 390      (X    : Exception_Occurrence;
 391       Info : in out String;
 392       Ptr  : in out Natural)
 393    is
 394       Load_Address : Address;
 395
 396    begin
 397       if X.Num_Tracebacks = 0 then
 398          return;
 399       end if;
 400
 401       --  The executable load address line
 402
 403       Load_Address := Get_Executable_Load_Address;
 404
 405       if Load_Address /= Null_Address then
 406          Append_Info_String (LDAD_Header, Info, Ptr);
 407          Append_Info_Address (Load_Address, Info, Ptr);
 408          Append_Info_NL (Info, Ptr);
 409       end if;
 410
 411       --  The traceback lines
 412       Append_Info_String (BETB_Header, Info, Ptr);
 413       Append_Info_NL (Info, Ptr);
 414
 415       for J in 1 .. X.Num_Tracebacks loop
 416          Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr);
 417          exit when J = X.Num_Tracebacks;
 418          Append_Info_Character (' ', Info, Ptr);
 419       end loop;
 420
 421       Append_Info_NL (Info, Ptr);
 422    end Append_Info_Untailored_Exception_Traceback;
 423
 424    ----------------------------------------------
 425    -- Untailored_Exception_Traceback_Maxlength --
 426    ----------------------------------------------
 427
 428    function Untailored_Exception_Traceback_Maxlength
 429      (X : Exception_Occurrence) return Natural
 430    is
 431       Space_Per_Address : constant := 2 + 16 + 1;
 432       --  Space for "0x" + HHHHHHHHHHHHHHHH + " "
 433    begin
 434       return
 435         LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 +
 436           X.Num_Tracebacks * Space_Per_Address + 1;
 437    end Untailored_Exception_Traceback_Maxlength;
 438
 439    --------------------------------------------------
 440    -- Append_Info_Untailored_Exception_Information --
 441    --------------------------------------------------
 442
 443    procedure Append_Info_Untailored_Exception_Information
 444      (X    : Exception_Occurrence;
 445       Info : in out String;
 446       Ptr  : in out Natural)
 447    is
 448    begin
 449       Append_Info_Basic_Exception_Information (X, Info, Ptr);
 450       Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
 451    end Append_Info_Untailored_Exception_Information;
 452
 453    ------------------------------
 454    -- Exception_Info_Maxlength --
 455    ------------------------------
 456
 457    function Exception_Info_Maxlength
 458      (X : Exception_Occurrence) return Natural
 459    is
 460    begin
 461       return
 462         Basic_Exception_Info_Maxlength (X)
 463         + Untailored_Exception_Traceback_Maxlength (X);
 464    end Exception_Info_Maxlength;
 465
 466    -----------------------------------
 467    -- Append_Info_Exception_Message --
 468    -----------------------------------
 469
 470    procedure Append_Info_Exception_Message
 471      (X    : Exception_Occurrence;
 472       Info : in out String;
 473       Ptr  : in out Natural)
 474    is
 475    begin
 476       if X.Id = Null_Id then
 477          raise Constraint_Error;
 478       end if;
 479
 480       declare
 481          Len : constant Natural           := Exception_Message_Length (X);
 482          Msg : constant String (1 .. Len) := X.Msg (1 .. Len);
 483       begin
 484          Append_Info_String (Msg, Info, Ptr);
 485       end;
 486    end Append_Info_Exception_Message;
 487
 488    --------------------------------
 489    -- Append_Info_Exception_Name --
 490    --------------------------------
 491
 492    procedure Append_Info_Exception_Name
 493      (Id   : Exception_Id;
 494       Info : in out String;
 495       Ptr  : in out Natural)
 496    is
 497    begin
 498       if Id = Null_Id then
 499          raise Constraint_Error;
 500       end if;
 501
 502       declare
 503          Len  : constant Natural           := Exception_Name_Length (Id);
 504          Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len);
 505       begin
 506          Append_Info_String (Name, Info, Ptr);
 507       end;
 508    end Append_Info_Exception_Name;
 509
 510    procedure Append_Info_Exception_Name
 511      (X    : Exception_Occurrence;
 512       Info : in out String;
 513       Ptr  : in out Natural)
 514    is
 515    begin
 516       Append_Info_Exception_Name (X.Id, Info, Ptr);
 517    end Append_Info_Exception_Name;
 518
 519    ---------------------------
 520    -- Exception_Name_Length --
 521    ---------------------------
 522
 523    function Exception_Name_Length
 524      (Id : Exception_Id) return Natural
 525    is
 526    begin
 527       --  What is stored in the internal Name buffer includes a terminating
 528       --  null character that we never care about.
 529
 530       return Id.Name_Length - 1;
 531    end Exception_Name_Length;
 532
 533    function Exception_Name_Length
 534      (X : Exception_Occurrence) return Natural is
 535    begin
 536       return Exception_Name_Length (X.Id);
 537    end Exception_Name_Length;
 538
 539    ------------------------------
 540    -- Exception_Message_Length --
 541    ------------------------------
 542
 543    function Exception_Message_Length
 544      (X : Exception_Occurrence) return Natural
 545    is
 546    begin
 547       return X.Msg_Length;
 548    end Exception_Message_Length;
 549
 550    -------------------------------
 551    -- Untailored_Exception_Traceback --
 552    -------------------------------
 553
 554    function Untailored_Exception_Traceback
 555      (X : Exception_Occurrence) return String
 556    is
 557       Info : aliased String
 558                        (1 .. Untailored_Exception_Traceback_Maxlength (X));
 559       Ptr  : Natural := Info'First - 1;
 560    begin
 561       Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
 562       return Info (Info'First .. Ptr);
 563    end Untailored_Exception_Traceback;
 564
 565    --------------------------------------
 566    -- Untailored_Exception_Information --
 567    --------------------------------------
 568
 569    function Untailored_Exception_Information
 570      (X : Exception_Occurrence) return String
 571    is
 572       Info : String (1 .. Exception_Info_Maxlength (X));
 573       Ptr  : Natural := Info'First - 1;
 574    begin
 575       Append_Info_Untailored_Exception_Information (X, Info, Ptr);
 576       return Info (Info'First .. Ptr);
 577    end Untailored_Exception_Information;
 578
 579    -------------------------
 580    -- Set_Exception_C_Msg --
 581    -------------------------
 582
 583    procedure Set_Exception_C_Msg
 584      (Excep  : EOA;
 585       Id     : Exception_Id;
 586       Msg1   : System.Address;
 587       Line   : Integer        := 0;
 588       Column : Integer        := 0;
 589       Msg2   : System.Address := System.Null_Address)
 590    is
 591       Remind : Integer;
 592       Ptr    : Natural;
 593
 594       procedure Append_Number (Number : Integer);
 595       --  Append given number to Excep.Msg
 596
 597       -------------------
 598       -- Append_Number --
 599       -------------------
 600
 601       procedure Append_Number (Number : Integer) is
 602          Val  : Integer;
 603          Size : Integer;
 604
 605       begin
 606          if Number <= 0 then
 607             return;
 608          end if;
 609
 610          --  Compute the number of needed characters
 611
 612          Size := 1;
 613          Val := Number;
 614          while Val > 0 loop
 615             Val := Val / 10;
 616             Size := Size + 1;
 617          end loop;
 618
 619          --  If enough characters are available, put the line number
 620
 621          if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
 622             Excep.Msg (Excep.Msg_Length + 1) := ':';
 623             Excep.Msg_Length := Excep.Msg_Length + Size;
 624
 625             Val := Number;
 626             Size := 0;
 627             while Val > 0 loop
 628                Remind := Val rem 10;
 629                Val := Val / 10;
 630                Excep.Msg (Excep.Msg_Length - Size) :=
 631                  Character'Val (Remind + Character'Pos ('0'));
 632                Size := Size + 1;
 633             end loop;
 634          end if;
 635       end Append_Number;
 636
 637    --  Start of processing for Set_Exception_C_Msg
 638
 639    begin
 640       Excep.Exception_Raised := False;
 641       Excep.Id               := Id;
 642       Excep.Num_Tracebacks   := 0;
 643       Excep.Pid              := Local_Partition_ID;
 644       Excep.Msg_Length       := 0;
 645
 646       while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL
 647         and then Excep.Msg_Length < Exception_Msg_Max_Length
 648       loop
 649          Excep.Msg_Length := Excep.Msg_Length + 1;
 650          Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length);
 651       end loop;
 652
 653       Append_Number (Line);
 654       Append_Number (Column);
 655
 656       --  Append second message if present
 657
 658       if Msg2 /= System.Null_Address
 659         and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
 660       then
 661          Excep.Msg_Length := Excep.Msg_Length + 1;
 662          Excep.Msg (Excep.Msg_Length) := ' ';
 663
 664          Ptr := 1;
 665          while To_Ptr (Msg2) (Ptr) /= ASCII.NUL
 666            and then Excep.Msg_Length < Exception_Msg_Max_Length
 667          loop
 668             Excep.Msg_Length := Excep.Msg_Length + 1;
 669             Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr);
 670             Ptr := Ptr + 1;
 671          end loop;
 672       end if;
 673    end Set_Exception_C_Msg;
 674
 675    -----------------------
 676    -- Set_Exception_Msg --
 677    -----------------------
 678
 679    procedure Set_Exception_Msg
 680      (Excep   : EOA;
 681       Id      : Exception_Id;
 682       Message : String)
 683    is
 684       Len   : constant Natural :=
 685         Natural'Min (Message'Length, Exception_Msg_Max_Length);
 686       First : constant Integer := Message'First;
 687    begin
 688       Excep.Exception_Raised := False;
 689       Excep.Msg_Length       := Len;
 690       Excep.Msg (1 .. Len)   := Message (First .. First + Len - 1);
 691       Excep.Id               := Id;
 692       Excep.Num_Tracebacks   := 0;
 693       Excep.Pid              := Local_Partition_ID;
 694    end Set_Exception_Msg;
 695
 696    ----------------------------------
 697    -- Tailored_Exception_Traceback --
 698    ----------------------------------
 699
 700    function Tailored_Exception_Traceback
 701      (X : Exception_Occurrence) return String
 702    is
 703       --  We reference the decorator *wrapper* here and not the decorator
 704       --  itself. The purpose of the local variable Wrapper is to prevent a
 705       --  potential race condition in the code below. The atomicity of this
 706       --  assignment is enforced by pragma Atomic in System.Soft_Links.
 707
 708       --  The potential race condition here, if no local variable was used,
 709       --  relates to the test upon the wrapper's value and the call, which
 710       --  are not performed atomically. With the local variable, potential
 711       --  changes of the wrapper's global value between the test and the
 712       --  call become inoffensive.
 713
 714       Wrapper : constant Traceback_Decorator_Wrapper_Call :=
 715         Traceback_Decorator_Wrapper;
 716
 717    begin
 718       if Wrapper = null then
 719          return Untailored_Exception_Traceback (X);
 720       else
 721          return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
 722       end if;
 723    end Tailored_Exception_Traceback;
 724
 725    ---------------------------
 726    -- Exception_Information --
 727    ---------------------------
 728
 729    function Exception_Information
 730      (X : Exception_Occurrence) return String
 731    is
 732       --  The tailored exception information is the basic information
 733       --  associated with the tailored call chain backtrace.
 734
 735       Tback_Info : constant String  := Tailored_Exception_Traceback (X);
 736       Tback_Len  : constant Natural := Tback_Info'Length;
 737
 738       Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len);
 739       Ptr  : Natural := Info'First - 1;
 740
 741    begin
 742       Append_Info_Basic_Exception_Information (X, Info, Ptr);
 743       Append_Info_String (Tback_Info, Info, Ptr);
 744       return Info (Info'First .. Ptr);
 745    end Exception_Information;
 746
 747 end Exception_Data;