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-2012, 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
 437    is
 438    begin
 439       return
 440         Basic_Exception_Info_Maxlength (X)
 441         + Basic_Exception_Tback_Maxlength (X);
 442    end Exception_Info_Maxlength;
 443
 444    -----------------------------------
 445    -- Append_Info_Exception_Message --
 446    -----------------------------------
 447
 448    procedure Append_Info_Exception_Message
 449      (X    : Exception_Occurrence;
 450       Info : in out String;
 451       Ptr  : in out Natural)
 452    is
 453    begin
 454       if X.Id = Null_Id then
 455          raise Constraint_Error;
 456       end if;
 457
 458       declare
 459          Len : constant Natural           := Exception_Message_Length (X);
 460          Msg : constant String (1 .. Len) := X.Msg (1 .. Len);
 461       begin
 462          Append_Info_String (Msg, Info, Ptr);
 463       end;
 464    end Append_Info_Exception_Message;
 465
 466    --------------------------------
 467    -- Append_Info_Exception_Name --
 468    --------------------------------
 469
 470    procedure Append_Info_Exception_Name
 471      (Id   : Exception_Id;
 472       Info : in out String;
 473       Ptr  : in out Natural)
 474    is
 475    begin
 476       if Id = Null_Id then
 477          raise Constraint_Error;
 478       end if;
 479
 480       declare
 481          Len  : constant Natural           := Exception_Name_Length (Id);
 482          Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len);
 483       begin
 484          Append_Info_String (Name, Info, Ptr);
 485       end;
 486    end Append_Info_Exception_Name;
 487
 488    procedure Append_Info_Exception_Name
 489      (X    : Exception_Occurrence;
 490       Info : in out String;
 491       Ptr  : in out Natural)
 492    is
 493    begin
 494       Append_Info_Exception_Name (X.Id, Info, Ptr);
 495    end Append_Info_Exception_Name;
 496
 497    ---------------------------
 498    -- Exception_Name_Length --
 499    ---------------------------
 500
 501    function Exception_Name_Length
 502      (Id : Exception_Id) return Natural
 503    is
 504    begin
 505       --  What is stored in the internal Name buffer includes a terminating
 506       --  null character that we never care about.
 507
 508       return Id.Name_Length - 1;
 509    end Exception_Name_Length;
 510
 511    function Exception_Name_Length
 512      (X : Exception_Occurrence) return Natural is
 513    begin
 514       return Exception_Name_Length (X.Id);
 515    end Exception_Name_Length;
 516
 517    ------------------------------
 518    -- Exception_Message_Length --
 519    ------------------------------
 520
 521    function Exception_Message_Length
 522      (X : Exception_Occurrence) return Natural
 523    is
 524    begin
 525       return X.Msg_Length;
 526    end Exception_Message_Length;
 527
 528    -------------------------------
 529    -- Basic_Exception_Traceback --
 530    -------------------------------
 531
 532    function Basic_Exception_Traceback
 533      (X : Exception_Occurrence) return String
 534    is
 535       Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X));
 536       Ptr  : Natural := Info'First - 1;
 537    begin
 538       Append_Info_Basic_Exception_Traceback (X, Info, Ptr);
 539       return Info (Info'First .. Ptr);
 540    end Basic_Exception_Traceback;
 541
 542    ---------------------------
 543    -- Exception_Information --
 544    ---------------------------
 545
 546    function Exception_Information
 547      (X : Exception_Occurrence) return String
 548    is
 549       Info : String (1 .. Exception_Info_Maxlength (X));
 550       Ptr  : Natural := Info'First - 1;
 551    begin
 552       Append_Info_Exception_Information (X, Info, Ptr);
 553       return Info (Info'First .. Ptr);
 554    end Exception_Information;
 555
 556    -------------------------
 557    -- Set_Exception_C_Msg --
 558    -------------------------
 559
 560    procedure Set_Exception_C_Msg
 561      (Excep  : EOA;
 562       Id     : Exception_Id;
 563       Msg1   : System.Address;
 564       Line   : Integer        := 0;
 565       Column : Integer        := 0;
 566       Msg2   : System.Address := System.Null_Address)
 567    is
 568       Remind : Integer;
 569       Ptr    : Natural;
 570
 571       procedure Append_Number (Number : Integer);
 572       --  Append given number to Excep.Msg
 573
 574       -------------------
 575       -- Append_Number --
 576       -------------------
 577
 578       procedure Append_Number (Number : Integer) is
 579          Val  : Integer;
 580          Size : Integer;
 581
 582       begin
 583          if Number <= 0 then
 584             return;
 585          end if;
 586
 587          --  Compute the number of needed characters
 588
 589          Size := 1;
 590          Val := Number;
 591          while Val > 0 loop
 592             Val := Val / 10;
 593             Size := Size + 1;
 594          end loop;
 595
 596          --  If enough characters are available, put the line number
 597
 598          if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then
 599             Excep.Msg (Excep.Msg_Length + 1) := ':';
 600             Excep.Msg_Length := Excep.Msg_Length + Size;
 601
 602             Val := Number;
 603             Size := 0;
 604             while Val > 0 loop
 605                Remind := Val rem 10;
 606                Val := Val / 10;
 607                Excep.Msg (Excep.Msg_Length - Size) :=
 608                  Character'Val (Remind + Character'Pos ('0'));
 609                Size := Size + 1;
 610             end loop;
 611          end if;
 612       end Append_Number;
 613
 614    --  Start of processing for Set_Exception_C_Msg
 615
 616    begin
 617       Excep.Exception_Raised := False;
 618       Excep.Id               := Id;
 619       Excep.Num_Tracebacks   := 0;
 620       Excep.Pid              := Local_Partition_ID;
 621       Excep.Msg_Length       := 0;
 622
 623       while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL
 624         and then Excep.Msg_Length < Exception_Msg_Max_Length
 625       loop
 626          Excep.Msg_Length := Excep.Msg_Length + 1;
 627          Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length);
 628       end loop;
 629
 630       Append_Number (Line);
 631       Append_Number (Column);
 632
 633       --  Append second message if present
 634
 635       if Msg2 /= System.Null_Address
 636         and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length
 637       then
 638          Excep.Msg_Length := Excep.Msg_Length + 1;
 639          Excep.Msg (Excep.Msg_Length) := ' ';
 640
 641          Ptr := 1;
 642          while To_Ptr (Msg2) (Ptr) /= ASCII.NUL
 643            and then Excep.Msg_Length < Exception_Msg_Max_Length
 644          loop
 645             Excep.Msg_Length := Excep.Msg_Length + 1;
 646             Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr);
 647             Ptr := Ptr + 1;
 648          end loop;
 649       end if;
 650    end Set_Exception_C_Msg;
 651
 652    -----------------------
 653    -- Set_Exception_Msg --
 654    -----------------------
 655
 656    procedure Set_Exception_Msg
 657      (Excep   : EOA;
 658       Id      : Exception_Id;
 659       Message : String)
 660    is
 661       Len   : constant Natural :=
 662         Natural'Min (Message'Length, Exception_Msg_Max_Length);
 663       First : constant Integer := Message'First;
 664    begin
 665       Excep.Exception_Raised := False;
 666       Excep.Msg_Length       := Len;
 667       Excep.Msg (1 .. Len)   := Message (First .. First + Len - 1);
 668       Excep.Id               := Id;
 669       Excep.Num_Tracebacks   := 0;
 670       Excep.Pid              := Local_Partition_ID;
 671    end Set_Exception_Msg;
 672
 673    ----------------------------------
 674    -- Tailored_Exception_Traceback --
 675    ----------------------------------
 676
 677    function Tailored_Exception_Traceback
 678      (X : Exception_Occurrence) return String
 679    is
 680       --  We reference the decorator *wrapper* here and not the decorator
 681       --  itself. The purpose of the local variable Wrapper is to prevent a
 682       --  potential race condition in the code below. The atomicity of this
 683       --  assignment is enforced by pragma Atomic in System.Soft_Links.
 684
 685       --  The potential race condition here, if no local variable was used,
 686       --  relates to the test upon the wrapper's value and the call, which
 687       --  are not performed atomically. With the local variable, potential
 688       --  changes of the wrapper's global value between the test and the
 689       --  call become inoffensive.
 690
 691       Wrapper : constant Traceback_Decorator_Wrapper_Call :=
 692         Traceback_Decorator_Wrapper;
 693
 694    begin
 695       if Wrapper = null then
 696          return Basic_Exception_Traceback (X);
 697       else
 698          return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks);
 699       end if;
 700    end Tailored_Exception_Traceback;
 701
 702    ------------------------------------
 703    -- Tailored_Exception_Information --
 704    ------------------------------------
 705
 706    function Tailored_Exception_Information
 707      (X : Exception_Occurrence) return String
 708    is
 709       --  The tailored exception information is the basic information
 710       --  associated with the tailored call chain backtrace.
 711
 712       Tback_Info : constant String  := Tailored_Exception_Traceback (X);
 713       Tback_Len  : constant Natural := Tback_Info'Length;
 714
 715       Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len);
 716       Ptr  : Natural := Info'First - 1;
 717
 718    begin
 719       Append_Info_Basic_Exception_Information (X, Info, Ptr);
 720       Append_Info_String (Tback_Info, Info, Ptr);
 721       return Info (Info'First .. Ptr);
 722    end Tailored_Exception_Information;
 723
 724 end Exception_Data;