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-2015, 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 nonzero)
  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_Basic_Exception_Information --
 249    ---------------------------------------------
 250
 251    --  To ease the maximum length computation, we define and pull out some
 252    --  string constants:
 253
 254    BEI_Name_Header : constant String := "raised ";
 255    BEI_Msg_Header  : constant String := " : ";
 256    BEI_PID_Header  : constant String := "PID: ";
 257
 258    procedure Append_Info_Basic_Exception_Information
 259      (X    : Exception_Occurrence;
 260       Info : in out String;
 261       Ptr  : in out Natural)
 262    is
 263       Name : String (1 .. Exception_Name_Length (X));
 264       --  Buffer in which to fetch the exception name, in order to check
 265       --  whether this is an internal _ABORT_SIGNAL or a regular occurrence.
 266
 267       Name_Ptr : Natural := Name'First - 1;
 268
 269    begin
 270       --  Output exception name and message except for _ABORT_SIGNAL, where
 271       --  these two lines are omitted.
 272
 273       Append_Info_Exception_Name (X, Name, Name_Ptr);
 274
 275       if Name (Name'First) /= '_' then
 276          Append_Info_String (BEI_Name_Header, Info, Ptr);
 277          Append_Info_String (Name, Info, Ptr);
 278
 279          if Exception_Message_Length (X) /= 0 then
 280             Append_Info_String (BEI_Msg_Header, Info, Ptr);
 281             Append_Info_Exception_Message  (X, Info, Ptr);
 282          end if;
 283
 284          Append_Info_NL (Info, Ptr);
 285       end if;
 286
 287       --  Output PID line if nonzero
 288
 289       if X.Pid /= 0 then
 290          Append_Info_String (BEI_PID_Header, Info, Ptr);
 291          Append_Info_Nat (X.Pid, Info, Ptr);
 292          Append_Info_NL (Info, Ptr);
 293       end if;
 294    end Append_Info_Basic_Exception_Information;
 295
 296    ---------------------------
 297    -- Append_Info_Character --
 298    ---------------------------
 299
 300    procedure Append_Info_Character
 301      (C    : Character;
 302       Info : in out String;
 303       Ptr  : in out Natural)
 304    is
 305    begin
 306       if Info'Length = 0 then
 307          To_Stderr (C);
 308       elsif Ptr < Info'Last then
 309          Ptr := Ptr + 1;
 310          Info (Ptr) := C;
 311       end if;
 312    end Append_Info_Character;
 313
 314    -----------------------------------
 315    -- Append_Info_Exception_Message --
 316    -----------------------------------
 317
 318    procedure Append_Info_Exception_Message
 319      (X    : Exception_Occurrence;
 320       Info : in out String;
 321       Ptr  : in out Natural)
 322    is
 323    begin
 324       if X.Id = Null_Id then
 325          raise Constraint_Error;
 326       end if;
 327
 328       declare
 329          Len : constant Natural           := Exception_Message_Length (X);
 330          Msg : constant String (1 .. Len) := X.Msg (1 .. Len);
 331       begin
 332          Append_Info_String (Msg, Info, Ptr);
 333       end;
 334    end Append_Info_Exception_Message;
 335
 336    --------------------------------
 337    -- Append_Info_Exception_Name --
 338    --------------------------------
 339
 340    procedure Append_Info_Exception_Name
 341      (Id   : Exception_Id;
 342       Info : in out String;
 343       Ptr  : in out Natural)
 344    is
 345    begin
 346       if Id = Null_Id then
 347          raise Constraint_Error;
 348       end if;
 349
 350       declare
 351          Len  : constant Natural           := Exception_Name_Length (Id);
 352          Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len);
 353       begin
 354          Append_Info_String (Name, Info, Ptr);
 355       end;
 356    end Append_Info_Exception_Name;
 357
 358    procedure Append_Info_Exception_Name
 359      (X    : Exception_Occurrence;
 360       Info : in out String;
 361       Ptr  : in out Natural)
 362    is
 363    begin
 364       Append_Info_Exception_Name (X.Id, Info, Ptr);
 365    end Append_Info_Exception_Name;
 366
 367    ------------------------------
 368    -- Exception_Info_Maxlength --
 369    ------------------------------
 370
 371    function Exception_Info_Maxlength
 372      (X : Exception_Occurrence) return Natural
 373    is
 374    begin
 375       return
 376         Basic_Exception_Info_Maxlength (X)
 377         + Untailored_Exception_Traceback_Maxlength (X);
 378    end Exception_Info_Maxlength;
 379
 380    ---------------------
 381    -- Append_Info_Nat --
 382    ---------------------
 383
 384    procedure Append_Info_Nat
 385      (N    : Natural;
 386       Info : in out String;
 387       Ptr  : in out Natural)
 388    is
 389    begin
 390       if N > 9 then
 391          Append_Info_Nat (N / 10, Info, Ptr);
 392       end if;
 393
 394       Append_Info_Character
 395         (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr);
 396    end Append_Info_Nat;
 397
 398    --------------------
 399    -- Append_Info_NL --
 400    --------------------
 401
 402    procedure Append_Info_NL
 403      (Info : in out String;
 404       Ptr  : in out Natural)
 405    is
 406    begin
 407       Append_Info_Character (ASCII.LF, Info, Ptr);
 408    end Append_Info_NL;
 409
 410    ------------------------
 411    -- Append_Info_String --
 412    ------------------------
 413
 414    procedure Append_Info_String
 415      (S    : String;
 416       Info : in out String;
 417       Ptr  : in out Natural)
 418    is
 419    begin
 420       if Info'Length = 0 then
 421          To_Stderr (S);
 422       else
 423          declare
 424             Last : constant Natural :=
 425               Integer'Min (Ptr + S'Length, Info'Last);
 426          begin
 427             Info (Ptr + 1 .. Last) := S;
 428             Ptr := Last;
 429          end;
 430       end if;
 431    end Append_Info_String;
 432
 433    --------------------------------------------------
 434    -- Append_Info_Untailored_Exception_Information --
 435    --------------------------------------------------
 436
 437    procedure Append_Info_Untailored_Exception_Information
 438      (X    : Exception_Occurrence;
 439       Info : in out String;
 440       Ptr  : in out Natural)
 441    is
 442    begin
 443       Append_Info_Basic_Exception_Information (X, Info, Ptr);
 444       Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
 445    end Append_Info_Untailored_Exception_Information;
 446
 447    ------------------------------------------------
 448    -- Append_Info_Untailored_Exception_Traceback --
 449    ------------------------------------------------
 450
 451    --  As for Basic_Exception_Information:
 452
 453    BETB_Header : constant String := "Call stack traceback locations:";
 454    LDAD_Header : constant String := "Load address: ";
 455
 456    procedure Append_Info_Untailored_Exception_Traceback
 457      (X    : Exception_Occurrence;
 458       Info : in out String;
 459       Ptr  : in out Natural)
 460    is
 461       Load_Address : Address;
 462
 463    begin
 464       if X.Num_Tracebacks = 0 then
 465          return;
 466       end if;
 467
 468       --  The executable load address line
 469
 470       Load_Address := Get_Executable_Load_Address;
 471
 472       if Load_Address /= Null_Address then
 473          Append_Info_String (LDAD_Header, Info, Ptr);
 474          Append_Info_Address (Load_Address, Info, Ptr);
 475          Append_Info_NL (Info, Ptr);
 476       end if;
 477
 478       --  The traceback lines
 479
 480       Append_Info_String (BETB_Header, Info, Ptr);
 481       Append_Info_NL (Info, Ptr);
 482
 483       for J in 1 .. X.Num_Tracebacks loop
 484          Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr);
 485          exit when J = X.Num_Tracebacks;
 486          Append_Info_Character (' ', Info, Ptr);
 487       end loop;
 488
 489       Append_Info_NL (Info, Ptr);
 490    end Append_Info_Untailored_Exception_Traceback;
 491
 492    -------------------------------------------
 493    -- Basic_Exception_Information_Maxlength --
 494    -------------------------------------------
 495
 496    function Basic_Exception_Info_Maxlength
 497      (X : Exception_Occurrence) return Natural
 498    is
 499    begin
 500       return
 501         BEI_Name_Header'Length + Exception_Name_Length (X)
 502         + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1
 503         + BEI_PID_Header'Length + 15;
 504    end Basic_Exception_Info_Maxlength;
 505
 506    ---------------------------
 507    -- Exception_Information --
 508    ---------------------------
 509
 510    function Exception_Information (X : Exception_Occurrence) return String is
 511       --  The tailored exception information is the basic information
 512       --  associated with the tailored call chain backtrace.
 513
 514       Tback_Info : constant String  := Tailored_Exception_Traceback (X);
 515       Tback_Len  : constant Natural := Tback_Info'Length;
 516
 517       Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len);
 518       Ptr  : Natural := Info'First - 1;
 519
 520    begin
 521       Append_Info_Basic_Exception_Information (X, Info, Ptr);
 522       Append_Info_String (Tback_Info, Info, Ptr);
 523       return Info (Info'First .. Ptr);
 524    end Exception_Information;
 525
 526    ------------------------------
 527    -- Exception_Message_Length --
 528    ------------------------------
 529
 530    function Exception_Message_Length
 531      (X : Exception_Occurrence) return Natural
 532    is
 533    begin
 534       return X.Msg_Length;
 535    end Exception_Message_Length;
 536
 537    ---------------------------
 538    -- Exception_Name_Length --
 539    ---------------------------
 540
 541    function Exception_Name_Length (Id : Exception_Id) return Natural is
 542    begin
 543       --  What is stored in the internal Name buffer includes a terminating
 544       --  null character that we never care about.
 545
 546       return Id.Name_Length - 1;
 547    end Exception_Name_Length;
 548
 549    function Exception_Name_Length (X : Exception_Occurrence) return Natural is
 550    begin
 551       return Exception_Name_Length (X.Id);
 552    end Exception_Name_Length;
 553
 554    -------------------------------
 555    -- Untailored_Exception_Traceback --
 556    -------------------------------
 557
 558    function Untailored_Exception_Traceback
 559      (X : Exception_Occurrence) return String
 560    is
 561       Info : aliased String
 562                        (1 .. Untailored_Exception_Traceback_Maxlength (X));
 563       Ptr  : Natural := Info'First - 1;
 564    begin
 565       Append_Info_Untailored_Exception_Traceback (X, Info, Ptr);
 566       return Info (Info'First .. Ptr);
 567    end Untailored_Exception_Traceback;
 568
 569    --------------------------------------
 570    -- Untailored_Exception_Information --
 571    --------------------------------------
 572
 573    function Untailored_Exception_Information
 574      (X : Exception_Occurrence) return String
 575    is
 576       Info : String (1 .. Exception_Info_Maxlength (X));
 577       Ptr  : Natural := Info'First - 1;
 578    begin
 579       Append_Info_Untailored_Exception_Information (X, Info, Ptr);
 580       return Info (Info'First .. Ptr);
 581    end Untailored_Exception_Information;
 582
 583    -------------------------
 584    -- Set_Exception_C_Msg --
 585    -------------------------
 586
 587    procedure Set_Exception_C_Msg
 588      (Excep  : EOA;
 589       Id     : Exception_Id;
 590       Msg1   : System.Address;
 591       Line   : Integer        := 0;
 592       Column : Integer        := 0;
 593       Msg2   : System.Address := System.Null_Address)
 594    is
 595       Remind : Integer;
 596       Ptr    : Natural;
 597
 598       procedure Append_Number (Number : Integer);
 599       --  Append given number to Excep.Msg
 600
 601       -------------------
 602       -- Append_Number --
 603       -------------------
 604
 605       procedure Append_Number (Number : Integer) is
 606          Val  : Integer;
 607          Size : Integer;
 608
 609       begin
 610          if Number <= 0 then
 611             return;
 612          end if;
 613
 614          --  Compute the number of needed characters
 615
 616          Size := 1;
 617          Val := Number;
 618          while Val > 0 loop
 619             Val := Val / 10;
 620             Size := Size + 1;
 621          end loop;
 622
 623          --  If enough characters are available, put the line number
 624
 625          if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
 626             Excep.Msg (Excep.Msg_Length + 1) := ':';
 627             Excep.Msg_Length := Excep.Msg_Length + Size;
 628
 629             Val := Number;
 630             Size := 0;
 631             while Val > 0 loop
 632                Remind := Val rem 10;
 633                Val := Val / 10;
 634                Excep.Msg (Excep.Msg_Length - Size) :=
 635                  Character'Val (Remind + Character'Pos ('0'));
 636                Size := Size + 1;
 637             end loop;
 638          end if;
 639       end Append_Number;
 640
 641    --  Start of processing for Set_Exception_C_Msg
 642
 643    begin
 644       Excep.Exception_Raised := False;
 645       Excep.Id               := Id;
 646       Excep.Num_Tracebacks   := 0;
 647       Excep.Pid              := Local_Partition_ID;
 648       Excep.Msg_Length       := 0;
 649
 650       while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL
 651         and then Excep.Msg_Length < Exception_Msg_Max_Length
 652       loop
 653          Excep.Msg_Length := Excep.Msg_Length + 1;
 654          Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length);
 655       end loop;
 656
 657       Append_Number (Line);
 658       Append_Number (Column);
 659
 660       --  Append second message if present
 661
 662       if Msg2 /= System.Null_Address
 663         and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
 664       then
 665          Excep.Msg_Length := Excep.Msg_Length + 1;
 666          Excep.Msg (Excep.Msg_Length) := ' ';
 667
 668          Ptr := 1;
 669          while To_Ptr (Msg2) (Ptr) /= ASCII.NUL
 670            and then Excep.Msg_Length < Exception_Msg_Max_Length
 671          loop
 672             Excep.Msg_Length := Excep.Msg_Length + 1;
 673             Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr);
 674             Ptr := Ptr + 1;
 675          end loop;
 676       end if;
 677    end Set_Exception_C_Msg;
 678
 679    -----------------------
 680    -- Set_Exception_Msg --
 681    -----------------------
 682
 683    procedure Set_Exception_Msg
 684      (Excep   : EOA;
 685       Id      : Exception_Id;
 686       Message : String)
 687    is
 688       Len : constant Natural :=
 689               Natural'Min (Message'Length, Exception_Msg_Max_Length);
 690       First : constant Integer := Message'First;
 691    begin
 692       Excep.Exception_Raised := False;
 693       Excep.Msg_Length       := Len;
 694       Excep.Msg (1 .. Len)   := Message (First .. First + Len - 1);
 695       Excep.Id               := Id;
 696       Excep.Num_Tracebacks   := 0;
 697       Excep.Pid              := Local_Partition_ID;
 698    end Set_Exception_Msg;
 699
 700    ----------------------------------
 701    -- Tailored_Exception_Traceback --
 702    ----------------------------------
 703
 704    function Tailored_Exception_Traceback
 705      (X : Exception_Occurrence) return String
 706    is
 707       --  We reference the decorator *wrapper* here and not the decorator
 708       --  itself. The purpose of the local variable Wrapper is to prevent a
 709       --  potential race condition in the code below. The atomicity of this
 710       --  assignment is enforced by pragma Atomic in System.Soft_Links.
 711
 712       --  The potential race condition here, if no local variable was used,
 713       --  relates to the test upon the wrapper's value and the call, which
 714       --  are not performed atomically. With the local variable, potential
 715       --  changes of the wrapper's global value between the test and the
 716       --  call become inoffensive.
 717
 718       Wrapper : constant Traceback_Decorator_Wrapper_Call :=
 719                   Traceback_Decorator_Wrapper;
 720
 721    begin
 722       if Wrapper = null then
 723          return Untailored_Exception_Traceback (X);
 724       else
 725          return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
 726       end if;
 727    end Tailored_Exception_Traceback;
 728
 729    ----------------------------------------------
 730    -- Untailored_Exception_Traceback_Maxlength --
 731    ----------------------------------------------
 732
 733    function Untailored_Exception_Traceback_Maxlength
 734      (X : Exception_Occurrence) return Natural
 735    is
 736       Space_Per_Address : constant := 2 + 16 + 1;
 737       --  Space for "0x" + HHHHHHHHHHHHHHHH + " "
 738    begin
 739       return
 740         LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 +
 741           X.Num_Tracebacks * Space_Per_Address + 1;
 742    end Untailored_Exception_Traceback_Maxlength;
 743
 744 end Exception_Data;