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