gcc/ada/sinput.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               S I N P U T                                --
   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 pragma Style_Checks (All_Checks);
  35 --  Subprograms not all in alpha order
  36
  37 with Debug;   use Debug;
  38 with Namet;   use Namet;
  39 with Opt;     use Opt;
  40 with Output;  use Output;
  41 with Tree_IO; use Tree_IO;
  42 with System;  use System;
  43
  44 with System.Memory;
  45
  46 with Unchecked_Conversion;
  47 with Unchecked_Deallocation;
  48
  49 package body Sinput is
  50
  51    use ASCII;
  52    --  Make control characters visible
  53
  54    First_Time_Around : Boolean := True;
  55
  56    --  Routines to support conversion between types Lines_Table_Ptr,
  57    --  Logical_Lines_Table_Ptr and System.Address.
  58
  59    pragma Warnings (Off);
  60    --  These unchecked conversions are aliasing safe, since they are never
  61    --  used to construct improperly aliased pointer values.
  62
  63    function To_Address is
  64      new Unchecked_Conversion (Lines_Table_Ptr, Address);
  65
  66    function To_Address is
  67      new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
  68
  69    function To_Pointer is
  70      new Unchecked_Conversion (Address, Lines_Table_Ptr);
  71
  72    function To_Pointer is
  73      new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
  74
  75    pragma Warnings (On);
  76
  77    ---------------------------
  78    -- Add_Line_Tables_Entry --
  79    ---------------------------
  80
  81    procedure Add_Line_Tables_Entry
  82      (S : in out Source_File_Record;
  83       P : Source_Ptr)
  84    is
  85       LL : Physical_Line_Number;
  86
  87    begin
  88       --  Reallocate the lines tables if necessary.
  89
  90       --  Note: the reason we do not use the normal Table package
  91       --  mechanism is that we have several of these tables. We could
  92       --  use the new GNAT.Dynamic_Tables package and that would probably
  93       --  be a good idea ???
  94
  95       if S.Last_Source_Line = S.Lines_Table_Max then
  96          Alloc_Line_Tables
  97            (S,
  98             Int (S.Last_Source_Line) *
  99               ((100 + Alloc.Lines_Increment) / 100));
 100
 101          if Debug_Flag_D then
 102             Write_Str ("--> Reallocating lines table, size = ");
 103             Write_Int (Int (S.Lines_Table_Max));
 104             Write_Eol;
 105          end if;
 106       end if;
 107
 108       S.Last_Source_Line := S.Last_Source_Line + 1;
 109       LL := S.Last_Source_Line;
 110
 111       S.Lines_Table (LL) := P;
 112
 113       --  Deal with setting new entry in logical lines table if one is
 114       --  present. Note that there is always space (because the call to
 115       --  Alloc_Line_Tables makes sure both tables are the same length),
 116
 117       if S.Logical_Lines_Table /= null then
 118
 119          --  We can always set the entry from the previous one, because
 120          --  the processing for a Source_Reference pragma ensures that
 121          --  at least one entry following the pragma is set up correctly.
 122
 123          S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
 124       end if;
 125    end Add_Line_Tables_Entry;
 126
 127    -----------------------
 128    -- Alloc_Line_Tables --
 129    -----------------------
 130
 131    procedure Alloc_Line_Tables
 132      (S       : in out Source_File_Record;
 133       New_Max : Nat)
 134    is
 135       subtype size_t is Memory.size_t;
 136
 137       New_Table : Lines_Table_Ptr;
 138
 139       New_Logical_Table : Logical_Lines_Table_Ptr;
 140
 141       New_Size : constant size_t :=
 142                    size_t (New_Max * Lines_Table_Type'Component_Size /
 143                                                              Storage_Unit);
 144
 145    begin
 146       if S.Lines_Table = null then
 147          New_Table := To_Pointer (Memory.Alloc (New_Size));
 148
 149       else
 150          New_Table :=
 151            To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
 152       end if;
 153
 154       if New_Table = null then
 155          raise Storage_Error;
 156       else
 157          S.Lines_Table     := New_Table;
 158          S.Lines_Table_Max := Physical_Line_Number (New_Max);
 159       end if;
 160
 161       if S.Num_SRef_Pragmas /= 0 then
 162          if S.Logical_Lines_Table = null then
 163             New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
 164          else
 165             New_Logical_Table := To_Pointer
 166               (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
 167          end if;
 168
 169          if New_Logical_Table = null then
 170             raise Storage_Error;
 171          else
 172             S.Logical_Lines_Table := New_Logical_Table;
 173          end if;
 174       end if;
 175    end Alloc_Line_Tables;
 176
 177    -----------------
 178    -- Backup_Line --
 179    -----------------
 180
 181    procedure Backup_Line (P : in out Source_Ptr) is
 182       Sindex : constant Source_File_Index := Get_Source_File_Index (P);
 183       Src    : constant Source_Buffer_Ptr :=
 184                  Source_File.Table (Sindex).Source_Text;
 185       Sfirst : constant Source_Ptr :=
 186                  Source_File.Table (Sindex).Source_First;
 187
 188    begin
 189       P := P - 1;
 190
 191       if P = Sfirst then
 192          return;
 193       end if;
 194
 195       if Src (P) = CR then
 196          if Src (P - 1) = LF then
 197             P := P - 1;
 198          end if;
 199
 200       else -- Src (P) = LF
 201          if Src (P - 1) = CR then
 202             P := P - 1;
 203          end if;
 204       end if;
 205
 206       --  Now find first character of the previous line
 207
 208       while P > Sfirst
 209         and then Src (P - 1) /= LF
 210         and then Src (P - 1) /= CR
 211       loop
 212          P := P - 1;
 213       end loop;
 214    end Backup_Line;
 215
 216    ---------------------------
 217    -- Build_Location_String --
 218    ---------------------------
 219
 220    procedure Build_Location_String (Loc : Source_Ptr) is
 221       Ptr : Source_Ptr;
 222
 223    begin
 224       Name_Len := 0;
 225
 226       --  Loop through instantiations
 227
 228       Ptr := Loc;
 229       loop
 230          Get_Name_String_And_Append
 231            (Reference_Name (Get_Source_File_Index (Ptr)));
 232          Add_Char_To_Name_Buffer (':');
 233          Add_Nat_To_Name_Buffer
 234            (Nat (Get_Logical_Line_Number (Ptr)));
 235
 236          Ptr := Instantiation_Location (Ptr);
 237          exit when Ptr = No_Location;
 238          Add_Str_To_Name_Buffer (" instantiated at ");
 239       end loop;
 240
 241       Name_Buffer (Name_Len + 1) := NUL;
 242       return;
 243    end Build_Location_String;
 244
 245    -----------------------
 246    -- Get_Column_Number --
 247    -----------------------
 248
 249    function Get_Column_Number (P : Source_Ptr) return Column_Number is
 250       S      : Source_Ptr;
 251       C      : Column_Number;
 252       Sindex : Source_File_Index;
 253       Src    : Source_Buffer_Ptr;
 254
 255    begin
 256       --  If the input source pointer is not a meaningful value then return
 257       --  at once with column number 1. This can happen for a file not found
 258       --  condition for a file loaded indirectly by RTE, and also perhaps on
 259       --  some unknown internal error conditions. In either case we certainly
 260       --  don't want to blow up.
 261
 262       if P < 1 then
 263          return 1;
 264
 265       else
 266          Sindex := Get_Source_File_Index (P);
 267          Src := Source_File.Table (Sindex).Source_Text;
 268          S := Line_Start (P);
 269          C := 1;
 270
 271          while S < P loop
 272             if Src (S) = HT then
 273                C := (C - 1) / 8 * 8 + (8 + 1);
 274             else
 275                C := C + 1;
 276             end if;
 277
 278             S := S + 1;
 279          end loop;
 280
 281          return C;
 282       end if;
 283    end Get_Column_Number;
 284
 285    -----------------------------
 286    -- Get_Logical_Line_Number --
 287    -----------------------------
 288
 289    function Get_Logical_Line_Number
 290      (P    : Source_Ptr)
 291       return Logical_Line_Number
 292    is
 293       SFR : Source_File_Record
 294               renames Source_File.Table (Get_Source_File_Index (P));
 295
 296       L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
 297
 298    begin
 299       if SFR.Num_SRef_Pragmas = 0 then
 300          return Logical_Line_Number (L);
 301       else
 302          return SFR.Logical_Lines_Table (L);
 303       end if;
 304    end Get_Logical_Line_Number;
 305
 306    ------------------------------
 307    -- Get_Physical_Line_Number --
 308    ------------------------------
 309
 310    function Get_Physical_Line_Number
 311      (P    : Source_Ptr)
 312       return Physical_Line_Number
 313    is
 314       Sfile : Source_File_Index;
 315       Table : Lines_Table_Ptr;
 316       Lo    : Physical_Line_Number;
 317       Hi    : Physical_Line_Number;
 318       Mid   : Physical_Line_Number;
 319       Loc   : Source_Ptr;
 320
 321    begin
 322       --  If the input source pointer is not a meaningful value then return
 323       --  at once with line number 1. This can happen for a file not found
 324       --  condition for a file loaded indirectly by RTE, and also perhaps on
 325       --  some unknown internal error conditions. In either case we certainly
 326       --  don't want to blow up.
 327
 328       if P < 1 then
 329          return 1;
 330
 331       --  Otherwise we can do the binary search
 332
 333       else
 334          Sfile := Get_Source_File_Index (P);
 335          Loc   := P + Source_File.Table (Sfile).Sloc_Adjust;
 336          Table := Source_File.Table (Sfile).Lines_Table;
 337          Lo    := 1;
 338          Hi    := Source_File.Table (Sfile).Last_Source_Line;
 339
 340          loop
 341             Mid := (Lo + Hi) / 2;
 342
 343             if Loc < Table (Mid) then
 344                Hi := Mid - 1;
 345
 346             else -- Loc >= Table (Mid)
 347
 348                if Mid = Hi or else
 349                   Loc < Table (Mid + 1)
 350                then
 351                   return Mid;
 352                else
 353                   Lo := Mid + 1;
 354                end if;
 355
 356             end if;
 357
 358          end loop;
 359       end if;
 360    end Get_Physical_Line_Number;
 361
 362    ---------------------------
 363    -- Get_Source_File_Index --
 364    ---------------------------
 365
 366    Source_Cache_First : Source_Ptr := 1;
 367    Source_Cache_Last  : Source_Ptr := 0;
 368    --  Records the First and Last subscript values for the most recently
 369    --  referenced entry in the source table, to optimize the common case
 370    --  of repeated references to the same entry. The initial values force
 371    --  an initial search to set the cache value.
 372
 373    Source_Cache_Index : Source_File_Index := No_Source_File;
 374    --  Contains the index of the entry corresponding to Source_Cache
 375
 376    function Get_Source_File_Index
 377      (S    : Source_Ptr)
 378       return Source_File_Index
 379    is
 380    begin
 381       if S in Source_Cache_First .. Source_Cache_Last then
 382          return Source_Cache_Index;
 383
 384       else
 385          for J in Source_File_Index_Table (Int (S) / Chunk_Size)
 386                                                     .. Source_File.Last
 387          loop
 388             if S in Source_File.Table (J).Source_First ..
 389                     Source_File.Table (J).Source_Last
 390             then
 391                Source_Cache_Index := J;
 392                Source_Cache_First :=
 393                  Source_File.Table (Source_Cache_Index).Source_First;
 394                Source_Cache_Last :=
 395                  Source_File.Table (Source_Cache_Index).Source_Last;
 396                return Source_Cache_Index;
 397             end if;
 398          end loop;
 399       end if;
 400
 401       --  We must find a matching entry in the above loop!
 402
 403       raise Program_Error;
 404    end Get_Source_File_Index;
 405
 406    ----------------
 407    -- Initialize --
 408    ----------------
 409
 410    procedure Initialize is
 411    begin
 412       Source_Cache_First := 1;
 413       Source_Cache_Last  := 0;
 414       Source_Cache_Index := No_Source_File;
 415       Source_gnat_adc    := No_Source_File;
 416       First_Time_Around  := True;
 417
 418       Source_File.Init;
 419    end Initialize;
 420
 421    -------------------------
 422    -- Instantiation_Depth --
 423    -------------------------
 424
 425    function Instantiation_Depth (S : Source_Ptr) return Nat is
 426       Sind  : Source_File_Index;
 427       Sval  : Source_Ptr;
 428       Depth : Nat;
 429
 430    begin
 431       Sval := S;
 432       Depth := 0;
 433
 434       loop
 435          Sind := Get_Source_File_Index (Sval);
 436          Sval := Instantiation (Sind);
 437          exit when Sval = No_Location;
 438          Depth := Depth + 1;
 439       end loop;
 440
 441       return Depth;
 442    end Instantiation_Depth;
 443
 444    ----------------------------
 445    -- Instantiation_Location --
 446    ----------------------------
 447
 448    function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
 449    begin
 450       return Instantiation (Get_Source_File_Index (S));
 451    end Instantiation_Location;
 452
 453    ----------------------
 454    -- Last_Source_File --
 455    ----------------------
 456
 457    function Last_Source_File return Source_File_Index is
 458    begin
 459       return Source_File.Last;
 460    end Last_Source_File;
 461
 462    ----------------
 463    -- Line_Start --
 464    ----------------
 465
 466    function Line_Start (P : Source_Ptr) return Source_Ptr is
 467       Sindex : constant Source_File_Index := Get_Source_File_Index (P);
 468       Src    : constant Source_Buffer_Ptr :=
 469                  Source_File.Table (Sindex).Source_Text;
 470       Sfirst : constant Source_Ptr :=
 471                  Source_File.Table (Sindex).Source_First;
 472       S      : Source_Ptr;
 473
 474    begin
 475       S := P;
 476
 477       while S > Sfirst
 478         and then Src (S - 1) /= CR
 479         and then Src (S - 1) /= LF
 480       loop
 481          S := S - 1;
 482       end loop;
 483
 484       return S;
 485    end Line_Start;
 486
 487    function Line_Start
 488      (L    : Physical_Line_Number;
 489       S    : Source_File_Index)
 490       return Source_Ptr
 491    is
 492    begin
 493       return Source_File.Table (S).Lines_Table (L);
 494    end Line_Start;
 495
 496    ----------
 497    -- Lock --
 498    ----------
 499
 500    procedure Lock is
 501    begin
 502       Source_File.Locked := True;
 503       Source_File.Release;
 504    end Lock;
 505
 506    ----------------------
 507    -- Num_Source_Files --
 508    ----------------------
 509
 510    function Num_Source_Files return Nat is
 511    begin
 512       return Int (Source_File.Last) - Int (Source_File.First) + 1;
 513    end Num_Source_Files;
 514
 515    ----------------------
 516    -- Num_Source_Lines --
 517    ----------------------
 518
 519    function Num_Source_Lines (S : Source_File_Index) return Nat is
 520    begin
 521       return Nat (Source_File.Table (S).Last_Source_Line);
 522    end Num_Source_Lines;
 523
 524    -----------------------
 525    -- Original_Location --
 526    -----------------------
 527
 528    function Original_Location (S : Source_Ptr) return Source_Ptr is
 529       Sindex : Source_File_Index;
 530       Tindex : Source_File_Index;
 531
 532    begin
 533       if S <= No_Location then
 534          return S;
 535
 536       else
 537          Sindex := Get_Source_File_Index (S);
 538
 539          if Instantiation (Sindex) = No_Location then
 540             return S;
 541
 542          else
 543             Tindex := Template (Sindex);
 544             while Instantiation (Tindex) /= No_Location loop
 545                Tindex := Template (Tindex);
 546             end loop;
 547
 548             return S - Source_First (Sindex) + Source_First (Tindex);
 549          end if;
 550       end if;
 551    end Original_Location;
 552
 553    -------------------------
 554    -- Physical_To_Logical --
 555    -------------------------
 556
 557    function Physical_To_Logical
 558      (Line : Physical_Line_Number;
 559       S    : Source_File_Index)
 560       return Logical_Line_Number
 561    is
 562       SFR : Source_File_Record renames Source_File.Table (S);
 563
 564    begin
 565       if SFR.Num_SRef_Pragmas = 0 then
 566          return Logical_Line_Number (Line);
 567       else
 568          return SFR.Logical_Lines_Table (Line);
 569       end if;
 570    end Physical_To_Logical;
 571
 572    --------------------------------
 573    -- Register_Source_Ref_Pragma --
 574    --------------------------------
 575
 576    procedure Register_Source_Ref_Pragma
 577      (File_Name          : Name_Id;
 578       Stripped_File_Name : Name_Id;
 579       Mapped_Line        : Nat;
 580       Line_After_Pragma  : Physical_Line_Number)
 581    is
 582       subtype size_t is Memory.size_t;
 583
 584       SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
 585
 586       ML : Logical_Line_Number;
 587
 588    begin
 589       if File_Name /= No_Name then
 590          SFR.Reference_Name := Stripped_File_Name;
 591          SFR.Full_Ref_Name  := File_Name;
 592
 593          if not Debug_Generated_Code then
 594             SFR.Debug_Source_Name := Stripped_File_Name;
 595             SFR.Full_Debug_Name   := File_Name;
 596          end if;
 597
 598          SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
 599       end if;
 600
 601       if SFR.Num_SRef_Pragmas = 1 then
 602          SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
 603       end if;
 604
 605       if SFR.Logical_Lines_Table = null then
 606          SFR.Logical_Lines_Table := To_Pointer
 607            (Memory.Alloc
 608              (size_t (SFR.Lines_Table_Max *
 609                         Logical_Lines_Table_Type'Component_Size /
 610                                                         Storage_Unit)));
 611       end if;
 612
 613       SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
 614
 615       ML := Logical_Line_Number (Mapped_Line);
 616       for J in Line_After_Pragma .. SFR.Last_Source_Line loop
 617          SFR.Logical_Lines_Table (J) := ML;
 618          ML := ML + 1;
 619       end loop;
 620    end Register_Source_Ref_Pragma;
 621
 622    ---------------------------------
 623    -- Set_Source_File_Index_Table --
 624    ---------------------------------
 625
 626    procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
 627       Ind : Int;
 628       SP  : Source_Ptr;
 629       SL  : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
 630
 631    begin
 632       SP  := (Source_File.Table (Xnew).Source_First + Chunk_Size - 1)
 633                                                     / Chunk_Size * Chunk_Size;
 634       Ind := Int (SP) / Chunk_Size;
 635
 636       while SP <= SL loop
 637          Source_File_Index_Table (Ind) := Xnew;
 638          SP := SP + Chunk_Size;
 639          Ind := Ind + 1;
 640       end loop;
 641    end Set_Source_File_Index_Table;
 642
 643    ---------------------------
 644    -- Skip_Line_Terminators --
 645    ---------------------------
 646
 647    --  There are two distinct concepts of line terminator in GNAT
 648
 649    --    A logical line terminator is what corresponds to the "end of a line"
 650    --    as described in RM 2.2 (13). Any of the characters FF, LF, CR or VT
 651    --    acts as an end of logical line in this sense, and it is essentially
 652    --    irrelevant whether one or more appears in sequence (since if a
 653    --    sequence of such characters is regarded as separate ends of line,
 654    --    then the intervening logical lines are null in any case).
 655
 656    --    A physical line terminator is a sequence of format effectors that
 657    --    is treated as ending a physical line. Physical lines have no Ada
 658    --    semantic significance, but they are significant for error reporting
 659    --    purposes, since errors are identified by line and column location.
 660
 661    --  In GNAT, a physical line is ended by any of the sequences LF, CR/LF,
 662    --  CR or LF/CR. LF is used in typical Unix systems, CR/LF in DOS systems,
 663    --  and CR alone in System 7. We don't know of any system using LF/CR, but
 664    --  it seems reasonable to include this case for consistency. In addition,
 665    --  we recognize any of these sequences in any of the operating systems,
 666    --  for better behavior in treating foreign files (e.g. a Unix file with
 667    --  LF terminators transferred to a DOS system).
 668
 669    procedure Skip_Line_Terminators
 670      (P        : in out Source_Ptr;
 671       Physical : out Boolean)
 672    is
 673    begin
 674       pragma Assert (Source (P) in Line_Terminator);
 675
 676       if Source (P) = CR then
 677          if Source (P + 1) = LF then
 678             P := P + 2;
 679          else
 680             P := P + 1;
 681          end if;
 682
 683       elsif Source (P) = LF then
 684          if Source (P + 1) = CR then
 685             P := P + 2;
 686          else
 687             P := P + 1;
 688          end if;
 689
 690       else -- Source (P) = FF or else Source (P) = VT
 691          P := P + 1;
 692          Physical := False;
 693          return;
 694       end if;
 695
 696       --  Fall through in the physical line terminator case. First deal with
 697       --  making a possible entry into the lines table if one is needed.
 698
 699       --  Note: we are dealing with a real source file here, this cannot be
 700       --  the instantiation case, so we need not worry about Sloc adjustment.
 701
 702       declare
 703          S : Source_File_Record
 704                renames Source_File.Table (Current_Source_File);
 705
 706       begin
 707          Physical := True;
 708
 709          --  Make entry in lines table if not already made (in some scan backup
 710          --  cases, we will be rescanning previously scanned source, so the
 711          --  entry may have already been made on the previous forward scan).
 712
 713          if Source (P) /= EOF
 714            and then P > S.Lines_Table (S.Last_Source_Line)
 715          then
 716             Add_Line_Tables_Entry (S, P);
 717          end if;
 718       end;
 719    end Skip_Line_Terminators;
 720
 721    -------------------
 722    -- Source_Offset --
 723    -------------------
 724
 725    function Source_Offset (S : Source_Ptr) return Nat is
 726       Sindex : constant Source_File_Index := Get_Source_File_Index (S);
 727       Sfirst : constant Source_Ptr :=
 728                  Source_File.Table (Sindex).Source_First;
 729
 730    begin
 731       return Nat (S - Sfirst);
 732    end Source_Offset;
 733
 734    ------------------------
 735    -- Top_Level_Location --
 736    ------------------------
 737
 738    function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
 739       Oldloc : Source_Ptr;
 740       Newloc : Source_Ptr;
 741
 742    begin
 743       Newloc := S;
 744       loop
 745          Oldloc := Newloc;
 746          Newloc := Instantiation_Location (Oldloc);
 747          exit when Newloc = No_Location;
 748       end loop;
 749
 750       return Oldloc;
 751    end Top_Level_Location;
 752
 753    ---------------
 754    -- Tree_Read --
 755    ---------------
 756
 757    procedure Tree_Read is
 758    begin
 759       --  First we must free any old source buffer pointers
 760
 761       if not First_Time_Around then
 762          for J in Source_File.First .. Source_File.Last loop
 763             declare
 764                S : Source_File_Record renames Source_File.Table (J);
 765
 766                procedure Free_Ptr is new Unchecked_Deallocation
 767                  (Big_Source_Buffer, Source_Buffer_Ptr);
 768
 769                pragma Warnings (Off);
 770                --  This unchecked conversion is aliasing safe, since it is not
 771                --  used to create improperly aliased pointer values.
 772
 773                function To_Source_Buffer_Ptr is new
 774                  Unchecked_Conversion (Address, Source_Buffer_Ptr);
 775
 776                pragma Warnings (On);
 777
 778                Tmp1 : Source_Buffer_Ptr;
 779
 780             begin
 781                if S.Instantiation /= No_Location then
 782                   null;
 783
 784                else
 785                   --  We have to recreate a proper pointer to the actual array
 786                   --  from the zero origin pointer stored in the source table.
 787
 788                   Tmp1 :=
 789                     To_Source_Buffer_Ptr
 790                       (S.Source_Text (S.Source_First)'Address);
 791                   Free_Ptr (Tmp1);
 792
 793                   --  Note: we are using free here, because we used malloc
 794                   --  or realloc directly to allocate the tables. That is
 795                   --  because we were playing the big array trick.
 796
 797                   if S.Lines_Table /= null then
 798                      Memory.Free (To_Address (S.Lines_Table));
 799                      S.Lines_Table := null;
 800                   end if;
 801
 802                   if S.Logical_Lines_Table /= null then
 803                      Memory.Free (To_Address (S.Logical_Lines_Table));
 804                      S.Logical_Lines_Table := null;
 805                   end if;
 806                end if;
 807             end;
 808          end loop;
 809       end if;
 810
 811       --  Reset source cache pointers to force new read
 812
 813       Source_Cache_First := 1;
 814       Source_Cache_Last  := 0;
 815
 816       --  Read in source file table
 817
 818       Source_File.Tree_Read;
 819
 820       --  The pointers we read in there for the source buffer and lines
 821       --  table pointers are junk. We now read in the actual data that
 822       --  is referenced by these two fields.
 823
 824       for J in Source_File.First .. Source_File.Last loop
 825          declare
 826             S : Source_File_Record renames Source_File.Table (J);
 827
 828          begin
 829             --  For the instantiation case, we do not read in any data. Instead
 830             --  we share the data for the generic template entry. Since the
 831             --  template always occurs first, we can safetly refer to its data.
 832
 833             if S.Instantiation /= No_Location then
 834                declare
 835                   ST : Source_File_Record renames
 836                          Source_File.Table (S.Template);
 837
 838                begin
 839                   --  The lines tables are copied from the template entry
 840
 841                   S.Lines_Table :=
 842                     Source_File.Table (S.Template).Lines_Table;
 843                   S.Logical_Lines_Table :=
 844                     Source_File.Table (S.Template).Logical_Lines_Table;
 845
 846                   --  In the case of the source table pointer, we share the
 847                   --  same data as the generic template, but the virtual origin
 848                   --  is adjusted. For example, if the first subscript of the
 849                   --  template is 100, and that of the instantiation is 200,
 850                   --  then the instantiation pointer is obtained by subtracting
 851                   --  100 from the template pointer.
 852
 853                   declare
 854                      pragma Suppress (All_Checks);
 855
 856                      pragma Warnings (Off);
 857                      --  This unchecked conversion is aliasing safe since it
 858                      --  not used to create improperly aliased pointer values.
 859
 860                      function To_Source_Buffer_Ptr is new
 861                        Unchecked_Conversion (Address, Source_Buffer_Ptr);
 862
 863                      pragma Warnings (On);
 864
 865                   begin
 866                      S.Source_Text :=
 867                        To_Source_Buffer_Ptr
 868                           (ST.Source_Text
 869                             (ST.Source_First - S.Source_First)'Address);
 870                   end;
 871                end;
 872
 873             --  Normal case (non-instantiation)
 874
 875             else
 876                First_Time_Around := False;
 877                S.Lines_Table := null;
 878                S.Logical_Lines_Table := null;
 879                Alloc_Line_Tables (S, Int (S.Last_Source_Line));
 880
 881                for J in 1 .. S.Last_Source_Line loop
 882                   Tree_Read_Int (Int (S.Lines_Table (J)));
 883                end loop;
 884
 885                if S.Num_SRef_Pragmas /= 0 then
 886                   for J in 1 .. S.Last_Source_Line loop
 887                      Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
 888                   end loop;
 889                end if;
 890
 891                --  Allocate source buffer and read in the data and then set the
 892                --  virtual origin to point to the logical zero'th element. This
 893                --  address must be computed with subscript checks turned off.
 894
 895                declare
 896                   subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
 897                   type Text_Buffer_Ptr is access B;
 898                   T : Text_Buffer_Ptr;
 899
 900                   pragma Suppress (All_Checks);
 901
 902                   pragma Warnings (Off);
 903                   --  This unchecked conversion is aliasing safe, since it is
 904                   --  never used to create improperly aliased pointer values.
 905
 906                   function To_Source_Buffer_Ptr is new
 907                     Unchecked_Conversion (Address, Source_Buffer_Ptr);
 908
 909                   pragma Warnings (On);
 910
 911                begin
 912                   T := new B;
 913
 914                   Tree_Read_Data (T (S.Source_First)'Address,
 915                      Int (S.Source_Last) - Int (S.Source_First) + 1);
 916
 917                   S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
 918                end;
 919             end if;
 920          end;
 921
 922          Set_Source_File_Index_Table (J);
 923       end loop;
 924    end Tree_Read;
 925
 926    ----------------
 927    -- Tree_Write --
 928    ----------------
 929
 930    procedure Tree_Write is
 931    begin
 932       Source_File.Tree_Write;
 933
 934       --  The pointers we wrote out there for the source buffer and lines
 935       --  table pointers are junk, we now write out the actual data that
 936       --  is referenced by these two fields.
 937
 938       for J in Source_File.First .. Source_File.Last loop
 939          declare
 940             S : Source_File_Record renames Source_File.Table (J);
 941
 942          begin
 943             --  For instantiations, there is nothing to do, since the data is
 944             --  shared with the generic template. When the tree is read, the
 945             --  pointers must be set, but no extra data needs to be written.
 946
 947             if S.Instantiation /= No_Location then
 948                null;
 949
 950             --  For the normal case, write out the data of the tables
 951
 952             else
 953                --  Lines table
 954
 955                for J in 1 .. S.Last_Source_Line loop
 956                   Tree_Write_Int (Int (S.Lines_Table (J)));
 957                end loop;
 958
 959                --  Logical lines table if present
 960
 961                if S.Num_SRef_Pragmas /= 0 then
 962                   for J in 1 .. S.Last_Source_Line loop
 963                      Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
 964                   end loop;
 965                end if;
 966
 967                --  Source buffer
 968
 969                Tree_Write_Data
 970                  (S.Source_Text (S.Source_First)'Address,
 971                    Int (S.Source_Last) - Int (S.Source_First) + 1);
 972             end if;
 973          end;
 974       end loop;
 975    end Tree_Write;
 976
 977    --------------------
 978    -- Write_Location --
 979    --------------------
 980
 981    procedure Write_Location (P : Source_Ptr) is
 982    begin
 983       if P = No_Location then
 984          Write_Str ("<no location>");
 985
 986       elsif P <= Standard_Location then
 987          Write_Str ("<standard location>");
 988
 989       else
 990          declare
 991             SI : constant Source_File_Index := Get_Source_File_Index (P);
 992
 993          begin
 994             Write_Name (Debug_Source_Name (SI));
 995             Write_Char (':');
 996             Write_Int (Int (Get_Logical_Line_Number (P)));
 997             Write_Char (':');
 998             Write_Int (Int (Get_Column_Number (P)));
 999
1000             if Instantiation (SI) /= No_Location then
1001                Write_Str (" [");
1002                Write_Location (Instantiation (SI));
1003                Write_Char (']');
1004             end if;
1005          end;
1006       end if;
1007    end Write_Location;
1008
1009    ----------------------
1010    -- Write_Time_Stamp --
1011    ----------------------
1012
1013    procedure Write_Time_Stamp (S : Source_File_Index) is
1014       T : constant Time_Stamp_Type := Time_Stamp (S);
1015       P : Natural;
1016
1017    begin
1018       if T (1) = '9' then
1019          Write_Str ("19");
1020          P := 0;
1021       else
1022          Write_Char (T (1));
1023          Write_Char (T (2));
1024          P := 2;
1025       end if;
1026
1027       Write_Char (T (P + 1));
1028       Write_Char (T (P + 2));
1029       Write_Char ('-');
1030
1031       Write_Char (T (P + 3));
1032       Write_Char (T (P + 4));
1033       Write_Char ('-');
1034
1035       Write_Char (T (P + 5));
1036       Write_Char (T (P + 6));
1037       Write_Char (' ');
1038
1039       Write_Char (T (P + 7));
1040       Write_Char (T (P + 8));
1041       Write_Char (':');
1042
1043       Write_Char (T (P + 9));
1044       Write_Char (T (P + 10));
1045       Write_Char (':');
1046
1047       Write_Char (T (P + 11));
1048       Write_Char (T (P + 12));
1049    end Write_Time_Stamp;
1050
1051    ----------------------------------------------
1052    -- Access Subprograms for Source File Table --
1053    ----------------------------------------------
1054
1055    function Debug_Source_Name (S : SFI) return File_Name_Type is
1056    begin
1057       return Source_File.Table (S).Debug_Source_Name;
1058    end Debug_Source_Name;
1059
1060    function File_Name (S : SFI) return File_Name_Type is
1061    begin
1062       return Source_File.Table (S).File_Name;
1063    end File_Name;
1064
1065    function File_Type (S : SFI) return Type_Of_File is
1066    begin
1067       return Source_File.Table (S).File_Type;
1068    end File_Type;
1069
1070    function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1071    begin
1072       return Source_File.Table (S).First_Mapped_Line;
1073    end First_Mapped_Line;
1074
1075    function Full_Debug_Name (S : SFI) return File_Name_Type is
1076    begin
1077       return Source_File.Table (S).Full_Debug_Name;
1078    end Full_Debug_Name;
1079
1080    function Full_File_Name (S : SFI) return File_Name_Type is
1081    begin
1082       return Source_File.Table (S).Full_File_Name;
1083    end Full_File_Name;
1084
1085    function Full_Ref_Name (S : SFI) return File_Name_Type is
1086    begin
1087       return Source_File.Table (S).Full_Ref_Name;
1088    end Full_Ref_Name;
1089
1090    function Identifier_Casing (S : SFI) return Casing_Type is
1091    begin
1092       return Source_File.Table (S).Identifier_Casing;
1093    end Identifier_Casing;
1094
1095    function Inlined_Body (S : SFI) return Boolean is
1096    begin
1097       return Source_File.Table (S).Inlined_Body;
1098    end Inlined_Body;
1099
1100    function Instantiation (S : SFI) return Source_Ptr is
1101    begin
1102       return Source_File.Table (S).Instantiation;
1103    end Instantiation;
1104
1105    function Keyword_Casing (S : SFI) return Casing_Type is
1106    begin
1107       return Source_File.Table (S).Keyword_Casing;
1108    end Keyword_Casing;
1109
1110    function Last_Source_Line (S : SFI) return Physical_Line_Number is
1111    begin
1112       return Source_File.Table (S).Last_Source_Line;
1113    end Last_Source_Line;
1114
1115    function License (S : SFI) return License_Type is
1116    begin
1117       return Source_File.Table (S).License;
1118    end License;
1119
1120    function Num_SRef_Pragmas (S : SFI) return Nat is
1121    begin
1122       return Source_File.Table (S).Num_SRef_Pragmas;
1123    end Num_SRef_Pragmas;
1124
1125    function Reference_Name (S : SFI) return File_Name_Type is
1126    begin
1127       return Source_File.Table (S).Reference_Name;
1128    end Reference_Name;
1129
1130    function Source_Checksum (S : SFI) return Word is
1131    begin
1132       return Source_File.Table (S).Source_Checksum;
1133    end Source_Checksum;
1134
1135    function Source_First (S : SFI) return Source_Ptr is
1136    begin
1137       if S = Internal_Source_File then
1138          return Internal_Source'First;
1139       else
1140          return Source_File.Table (S).Source_First;
1141       end if;
1142    end Source_First;
1143
1144    function Source_Last (S : SFI) return Source_Ptr is
1145    begin
1146       if S = Internal_Source_File then
1147          return Internal_Source'Last;
1148       else
1149          return Source_File.Table (S).Source_Last;
1150       end if;
1151
1152    end Source_Last;
1153
1154    function Source_Text (S : SFI) return Source_Buffer_Ptr is
1155    begin
1156       if S = Internal_Source_File then
1157          return Internal_Source_Ptr;
1158       else
1159          return Source_File.Table (S).Source_Text;
1160       end if;
1161
1162    end Source_Text;
1163
1164    function Template (S : SFI) return SFI is
1165    begin
1166       return Source_File.Table (S).Template;
1167    end Template;
1168
1169    function Time_Stamp (S : SFI) return Time_Stamp_Type is
1170    begin
1171       return Source_File.Table (S).Time_Stamp;
1172    end Time_Stamp;
1173
1174    ------------------------------------------
1175    -- Set Procedures for Source File Table --
1176    ------------------------------------------
1177
1178    procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1179    begin
1180       Source_File.Table (S).Identifier_Casing := C;
1181    end Set_Identifier_Casing;
1182
1183    procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1184    begin
1185       Source_File.Table (S).Keyword_Casing := C;
1186    end Set_Keyword_Casing;
1187
1188    procedure Set_License (S : SFI; L : License_Type) is
1189    begin
1190       Source_File.Table (S).License := L;
1191    end Set_License;
1192
1193    ----------------------
1194    -- Trim_Lines_Table --
1195    ----------------------
1196
1197    procedure Trim_Lines_Table (S : Source_File_Index) is
1198       Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1199
1200    begin
1201       --  Release allocated storage that is no longer needed
1202
1203       Source_File.Table (S).Lines_Table := To_Pointer
1204         (Memory.Realloc
1205           (To_Address (Source_File.Table (S).Lines_Table),
1206            Memory.size_t
1207             (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1208       Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1209    end Trim_Lines_Table;
1210
1211    --------
1212    -- wl --
1213    --------
1214
1215    procedure wl (P : Source_Ptr) is
1216    begin
1217       Write_Location (P);
1218       Write_Eol;
1219    end wl;
1220
1221 end Sinput;