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