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-2004 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Storage_Elements; use System.Storage_Elements;
  35
  36 separate (Ada.Exceptions)
  37 package body Exception_Data is
  38
  39    --  This unit implements the Exception_Information related services for
  40    --  both the Ada standard requirements and the GNAT.Exception_Traces
  41    --  facility.
  42
  43    --  There are common parts between the contents of Exception_Information
  44    --  (the regular Ada interface) and Tailored_Exception_Information (what
  45    --  the automatic backtracing output includes). The overall structure is
  46    --  sketched below:
  47
  48    --
  49    --                      Exception_Information
  50    --                               |
  51    --                       +-------+--------+
  52    --                       |                |
  53    --                Basic_Exc_Info & Basic_Exc_Tback
  54    --                    (B_E_I)          (B_E_TB)
  55
  56    --           o--
  57    --  (B_E_I)  |  Exception_Name: <exception name> (as in Exception_Name)
  58    --           |  Message: <message> (or a null line if no message)
  59    --           |  PID=nnnn (if != 0)
  60    --           o--
  61    --  (B_E_TB) |  Call stack traceback locations:
  62    --           |  <0xyyyyyyyy 0xyyyyyyyy ...>
  63    --           o--
  64
  65    --                  Tailored_Exception_Information
  66    --                               |
  67    --                    +----------+----------+
  68    --                    |                     |
  69    --             Basic_Exc_Info    &  Tailored_Exc_Tback
  70    --                                          |
  71    --                              +-----------+------------+
  72    --                              |                        |
  73    --                       Basic_Exc_Tback    Or    Tback_Decorator
  74    --                     if no decorator set           otherwise
  75
  76    --  Functions returning String imply secondary stack use, which is a heavy
  77    --  mechanism requiring run-time support. Besides, some of the routines we
  78    --  provide here are to be used by the default Last_Chance_Handler, at the
  79    --  critical point where the runtime is about to be finalized. Since most
  80    --  of the items we have at hand are of bounded length, we also provide a
  81    --  procedural interface able to incrementally append the necessary bits to
  82    --  a preallocated buffer or output them straight to stderr.
  83
  84    --  The procedural interface is composed of two major sections: a neutral
  85    --  section for basic types like Address, Character, Natural or String, and
  86    --  an exception oriented section for the e.g. Basic_Exception_Information.
  87    --  This is the Append_Info family of procedures below.
  88
  89    --  Output to stderr is commanded by passing an empty buffer to update, and
  90    --  care is taken not to overflow otherwise.
  91
  92    --------------------------------------------
  93    -- Procedural Interface - Neutral section --
  94    --------------------------------------------
  95
  96    procedure Append_Info_Address
  97      (A    : Address;
  98       Info : in out String;
  99       Ptr  : in out Natural);
 100
 101    procedure Append_Info_Character
 102      (C    : Character;
 103       Info : in out String;
 104       Ptr  : in out Natural);
 105
 106    procedure Append_Info_Nat
 107      (N    : Natural;
 108       Info : in out String;
 109       Ptr  : in out Natural);
 110
 111    procedure Append_Info_NL
 112      (Info : in out String;
 113       Ptr  : in out Natural);
 114    pragma Inline (Append_Info_NL);
 115
 116    procedure Append_Info_String
 117      (S    : String;
 118       Info : in out String;
 119       Ptr  : in out Natural);
 120
 121    -------------------------------------------------------
 122    -- Procedural Interface - Exception oriented section --
 123    -------------------------------------------------------
 124
 125    procedure Append_Info_Exception_Name
 126      (Id   : Exception_Id;
 127       Info : in out String;
 128       Ptr  : in out Natural);
 129
 130    procedure Append_Info_Exception_Name
 131      (X    : Exception_Occurrence;
 132       Info : in out String;
 133       Ptr  : in out Natural);
 134
 135    procedure Append_Info_Exception_Message
 136      (X    : Exception_Occurrence;
 137       Info : in out String;
 138       Ptr  : in out Natural);
 139
 140    procedure Append_Info_Basic_Exception_Information
 141      (X    : Exception_Occurrence;
 142       Info : in out String;
 143       Ptr  : in out Natural);
 144
 145    procedure Append_Info_Basic_Exception_Traceback
 146      (X    : Exception_Occurrence;
 147       Info : in out String;
 148       Ptr  : in out Natural);
 149
 150    procedure Append_Info_Exception_Information
 151      (X    : Exception_Occurrence;
 152       Info : in out String;
 153       Ptr  : in out Natural);
 154
 155
 156    --  The "functional" interface to the exception information not involving
 157    --  a traceback decorator uses preallocated intermediate buffers to avoid
 158    --  the use of secondary stack. Preallocation requires preliminary length
 159    --  computation, for which a series of functions are introduced:
 160
 161    ---------------------------------
 162    -- Length evaluation utilities --
 163    ---------------------------------
 164
 165    function Basic_Exception_Info_Maxlength
 166      (X : Exception_Occurrence) return Natural;
 167
 168    function Basic_Exception_Tback_Maxlength
 169      (X : Exception_Occurrence) return Natural;
 170
 171    function Exception_Info_Maxlength
 172      (X : Exception_Occurrence) return Natural;
 173
 174    function Exception_Name_Length
 175      (Id : Exception_Id) return Natural;
 176
 177    function Exception_Name_Length
 178      (X : Exception_Occurrence) return Natural;
 179
 180    function Exception_Message_Length
 181      (X : Exception_Occurrence) return Natural;
 182
 183    --------------------------
 184    -- Functional Interface --
 185    --------------------------
 186
 187    function Basic_Exception_Traceback
 188      (X : Exception_Occurrence) return String;
 189    --  Returns an image of the complete call chain associated with an
 190    --  exception occurence in its most basic form, that is as a raw sequence
 191    --  of hexadecimal binary addresses.
 192
 193    function Tailored_Exception_Traceback
 194      (X : Exception_Occurrence) return String;
 195    --  Returns an image of the complete call chain associated with an
 196    --  exception occurrence, either in its basic form if no decorator is
 197    --  in place, or as formatted by the decorator otherwise.
 198
 199    -----------------------------------------------------------------------
 200    -- Services for the default Last_Chance_Handler and the task wrapper --
 201    -----------------------------------------------------------------------
 202
 203    pragma Export
 204      (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
 205
 206    pragma Export
 207      (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info");
 208
 209    pragma Export
 210      (Ada, Exception_Message_Length, "__gnat_exception_msg_len");
 211
 212    -------------------------
 213    -- Append_Info_Address --
 214    -------------------------
 215
 216    procedure Append_Info_Address
 217      (A    : Address;
 218       Info : in out String;
 219       Ptr  : in out Natural)
 220    is
 221       S : String (1 .. 18);
 222       P : Natural;
 223       N : Integer_Address;
 224
 225       H : constant array (Integer range 0 .. 15) of Character :=
 226                                                          "0123456789abcdef";
 227    begin
 228       P := S'Last;
 229       N := To_Integer (A);
 230       loop
 231          S (P) := H (Integer (N mod 16));
 232          P := P - 1;
 233          N := N / 16;
 234          exit when N = 0;
 235       end loop;
 236
 237       S (P - 1) := '0';
 238       S (P) := 'x';
 239
 240       Append_Info_String (S (P - 1 .. S'Last), Info, Ptr);
 241    end Append_Info_Address;
 242
 243    ---------------------------
 244    -- Append_Info_Character --
 245    ---------------------------
 246
 247    procedure Append_Info_Character
 248      (C    : Character;
 249       Info : in out String;
 250       Ptr  : in out Natural)
 251    is
 252    begin
 253       if Info'Length = 0 then
 254          To_Stderr (C);
 255       elsif Ptr < Info'Last then
 256          Ptr := Ptr + 1;
 257          Info (Ptr) := C;
 258       end if;
 259    end Append_Info_Character;
 260
 261    ---------------------
 262    -- Append_Info_Nat --
 263    ---------------------
 264
 265    procedure Append_Info_Nat
 266      (N    : Natural;
 267       Info : in out String;
 268       Ptr  : in out Natural)
 269    is
 270    begin
 271       if N > 9 then
 272          Append_Info_Nat (N / 10, Info, Ptr);
 273       end if;
 274
 275       Append_Info_Character
 276         (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr);
 277    end Append_Info_Nat;
 278
 279    --------------------
 280    -- Append_Info_NL --
 281    --------------------
 282
 283    procedure Append_Info_NL
 284      (Info : in out String;
 285       Ptr  : in out Natural)
 286    is
 287    begin
 288       Append_Info_Character (ASCII.LF, Info, Ptr);
 289    end Append_Info_NL;
 290
 291    ------------------------
 292    -- Append_Info_String --
 293    ------------------------
 294
 295    procedure Append_Info_String
 296      (S    : String;
 297       Info : in out String;
 298       Ptr  : in out Natural)
 299    is
 300    begin
 301       if Info'Length = 0 then
 302          To_Stderr (S);
 303       else
 304          declare
 305             Last : constant Natural :=
 306               Integer'Min (Ptr + S'Length, Info'Last);
 307          begin
 308             Info (Ptr + 1 .. Last) := S;
 309             Ptr := Last;
 310          end;
 311       end if;
 312    end Append_Info_String;
 313
 314    ---------------------------------------------
 315    -- Append_Info_Basic_Exception_Information --
 316    ---------------------------------------------
 317
 318    --  To ease the maximum length computation, we define and pull out a couple
 319    --  of string constants:
 320
 321    BEI_Name_Header : constant String := "Exception name: ";
 322    BEI_Msg_Header  : constant String := "Message: ";
 323    BEI_PID_Header  : constant String := "PID: ";
 324
 325    procedure Append_Info_Basic_Exception_Information
 326      (X    : Exception_Occurrence;
 327       Info : in out String;
 328       Ptr  : in out Natural)
 329    is
 330       Name : String (1 .. Exception_Name_Length (X));
 331       --  Bufer in which to fetch the exception name, in order to check
 332       --  whether this is an internal _ABORT_SIGNAL or a regular occurrence.
 333
 334       Name_Ptr : Natural := Name'First - 1;
 335
 336    begin
 337       --  Output exception name and message except for _ABORT_SIGNAL, where
 338       --  these two lines are omitted.
 339
 340       Append_Info_Exception_Name (X, Name, Name_Ptr);
 341
 342       if Name (Name'First) /= '_' then
 343          Append_Info_String (BEI_Name_Header, Info, Ptr);
 344          Append_Info_String (Name, Info, Ptr);
 345          Append_Info_NL (Info, Ptr);
 346
 347          if Exception_Message_Length (X) /= 0 then
 348             Append_Info_String (BEI_Msg_Header, Info, Ptr);
 349             Append_Info_Exception_Message  (X, Info, Ptr);
 350             Append_Info_NL (Info, Ptr);
 351          end if;
 352       end if;
 353
 354       --  Output PID line if non-zero
 355
 356       if X.Pid /= 0 then
 357          Append_Info_String (BEI_PID_Header, Info, Ptr);
 358          Append_Info_Nat (X.Pid, Info, Ptr);
 359          Append_Info_NL (Info, Ptr);
 360       end if;
 361    end Append_Info_Basic_Exception_Information;
 362
 363    -------------------------------------------
 364    -- Basic_Exception_Information_Maxlength --
 365    -------------------------------------------
 366
 367    function Basic_Exception_Info_Maxlength
 368      (X : Exception_Occurrence) return Natural is
 369    begin
 370       return
 371         BEI_Name_Header'Length + Exception_Name_Length (X) + 1
 372         + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1
 373         + BEI_PID_Header'Length + 15;
 374    end Basic_Exception_Info_Maxlength;
 375
 376    -------------------------------------------
 377    -- Append_Info_Basic_Exception_Traceback --
 378    -------------------------------------------
 379
 380    --  As for Basic_Exception_Information:
 381
 382    BETB_Header : constant String := "Call stack traceback locations:";
 383
 384    procedure Append_Info_Basic_Exception_Traceback
 385      (X    : Exception_Occurrence;
 386       Info : in out String;
 387       Ptr  : in out Natural)
 388    is
 389    begin
 390       if X.Num_Tracebacks <= 0 then
 391          return;
 392       end if;
 393
 394       Append_Info_String (BETB_Header, Info, Ptr);
 395       Append_Info_NL (Info, Ptr);
 396
 397       for J in 1 .. X.Num_Tracebacks loop
 398          Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr);
 399          exit when J = X.Num_Tracebacks;
 400          Append_Info_Character (' ', Info, Ptr);
 401       end loop;
 402
 403       Append_Info_NL (Info, Ptr);
 404    end Append_Info_Basic_Exception_Traceback;
 405
 406    -----------------------------------------
 407    -- Basic_Exception_Traceback_Maxlength --
 408    -----------------------------------------
 409
 410    function Basic_Exception_Tback_Maxlength
 411      (X : Exception_Occurrence) return Natural is
 412    begin
 413       return BETB_Header'Length + 1 + X.Num_Tracebacks * 19 + 1;
 414       --  19 =  2 + 16 + 1 for each address ("0x" + HHHH + " ")
 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) := 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 : Big_String_Ptr;
 561       Line : Integer        := 0;
 562       Msg2 : Big_String_Ptr := null)
 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 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) := 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 /= null
 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 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) := 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;