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