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-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Style_Checks (All_Checks);
  33 --  Subprograms not all in alpha order
  34
  35 with Atree;    use Atree;
  36 with Debug;    use Debug;
  37 with Opt;      use Opt;
  38 with Output;   use Output;
  39 with Tree_IO;  use Tree_IO;
  40 with System;   use System;
  41 with Widechar; use Widechar;
  42
  43 with System.Memory;
  44
  45 with Unchecked_Conversion;
  46 with Unchecked_Deallocation;
  47
  48 package body Sinput is
  49
  50    use ASCII;
  51    --  Make control characters visible
  52
  53    First_Time_Around : Boolean := True;
  54    --  This needs a comment ???
  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       --  Loop through instantiations
 225
 226       Ptr := Loc;
 227       loop
 228          Get_Name_String_And_Append
 229            (Reference_Name (Get_Source_File_Index (Ptr)));
 230          Add_Char_To_Name_Buffer (':');
 231          Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Ptr)));
 232
 233          Ptr := Instantiation_Location (Ptr);
 234          exit when Ptr = No_Location;
 235          Add_Str_To_Name_Buffer (" instantiated at ");
 236       end loop;
 237
 238       Name_Buffer (Name_Len + 1) := NUL;
 239       return;
 240    end Build_Location_String;
 241
 242    function Build_Location_String (Loc : Source_Ptr) return String is
 243    begin
 244       Name_Len := 0;
 245       Build_Location_String (Loc);
 246       return Name_Buffer (1 .. Name_Len);
 247    end Build_Location_String;
 248
 249    -----------------------
 250    -- Get_Column_Number --
 251    -----------------------
 252
 253    function Get_Column_Number (P : Source_Ptr) return Column_Number is
 254       S      : Source_Ptr;
 255       C      : Column_Number;
 256       Sindex : Source_File_Index;
 257       Src    : Source_Buffer_Ptr;
 258
 259    begin
 260       --  If the input source pointer is not a meaningful value then return
 261       --  at once with column number 1. This can happen for a file not found
 262       --  condition for a file loaded indirectly by RTE, and also perhaps on
 263       --  some unknown internal error conditions. In either case we certainly
 264       --  don't want to blow up.
 265
 266       if P < 1 then
 267          return 1;
 268
 269       else
 270          Sindex := Get_Source_File_Index (P);
 271          Src := Source_File.Table (Sindex).Source_Text;
 272          S := Line_Start (P);
 273          C := 1;
 274
 275          while S < P loop
 276             if Src (S) = HT then
 277                C := (C - 1) / 8 * 8 + (8 + 1);
 278             else
 279                C := C + 1;
 280             end if;
 281
 282             S := S + 1;
 283          end loop;
 284
 285          return C;
 286       end if;
 287    end Get_Column_Number;
 288
 289    -----------------------------
 290    -- Get_Logical_Line_Number --
 291    -----------------------------
 292
 293    function Get_Logical_Line_Number
 294      (P : Source_Ptr) return Logical_Line_Number
 295    is
 296       SFR : Source_File_Record
 297               renames Source_File.Table (Get_Source_File_Index (P));
 298
 299       L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
 300
 301    begin
 302       if SFR.Num_SRef_Pragmas = 0 then
 303          return Logical_Line_Number (L);
 304       else
 305          return SFR.Logical_Lines_Table (L);
 306       end if;
 307    end Get_Logical_Line_Number;
 308
 309    ---------------------------------
 310    -- Get_Logical_Line_Number_Img --
 311    ---------------------------------
 312
 313    function Get_Logical_Line_Number_Img
 314      (P : Source_Ptr) return String
 315    is
 316    begin
 317       Name_Len := 0;
 318       Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P)));
 319       return Name_Buffer (1 .. Name_Len);
 320    end Get_Logical_Line_Number_Img;
 321
 322    ------------------------------
 323    -- Get_Physical_Line_Number --
 324    ------------------------------
 325
 326    function Get_Physical_Line_Number
 327      (P : Source_Ptr) return Physical_Line_Number
 328    is
 329       Sfile : Source_File_Index;
 330       Table : Lines_Table_Ptr;
 331       Lo    : Physical_Line_Number;
 332       Hi    : Physical_Line_Number;
 333       Mid   : Physical_Line_Number;
 334       Loc   : Source_Ptr;
 335
 336    begin
 337       --  If the input source pointer is not a meaningful value then return
 338       --  at once with line number 1. This can happen for a file not found
 339       --  condition for a file loaded indirectly by RTE, and also perhaps on
 340       --  some unknown internal error conditions. In either case we certainly
 341       --  don't want to blow up.
 342
 343       if P < 1 then
 344          return 1;
 345
 346       --  Otherwise we can do the binary search
 347
 348       else
 349          Sfile := Get_Source_File_Index (P);
 350          Loc   := P + Source_File.Table (Sfile).Sloc_Adjust;
 351          Table := Source_File.Table (Sfile).Lines_Table;
 352          Lo    := 1;
 353          Hi    := Source_File.Table (Sfile).Last_Source_Line;
 354
 355          loop
 356             Mid := (Lo + Hi) / 2;
 357
 358             if Loc < Table (Mid) then
 359                Hi := Mid - 1;
 360
 361             else -- Loc >= Table (Mid)
 362
 363                if Mid = Hi or else
 364                   Loc < Table (Mid + 1)
 365                then
 366                   return Mid;
 367                else
 368                   Lo := Mid + 1;
 369                end if;
 370
 371             end if;
 372
 373          end loop;
 374       end if;
 375    end Get_Physical_Line_Number;
 376
 377    ---------------------------
 378    -- Get_Source_File_Index --
 379    ---------------------------
 380
 381    Source_Cache_First : Source_Ptr := 1;
 382    Source_Cache_Last  : Source_Ptr := 0;
 383    --  Records the First and Last subscript values for the most recently
 384    --  referenced entry in the source table, to optimize the common case of
 385    --  repeated references to the same entry. The initial values force an
 386    --  initial search to set the cache value.
 387
 388    Source_Cache_Index : Source_File_Index := No_Source_File;
 389    --  Contains the index of the entry corresponding to Source_Cache
 390
 391    function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
 392    begin
 393       if S in Source_Cache_First .. Source_Cache_Last then
 394          return Source_Cache_Index;
 395
 396       else
 397          pragma Assert (Source_File_Index_Table (Int (S) / Chunk_Size)
 398                           /=
 399                         No_Source_File);
 400          for J in Source_File_Index_Table (Int (S) / Chunk_Size)
 401                                                     .. Source_File.Last
 402          loop
 403             if S in Source_File.Table (J).Source_First ..
 404                     Source_File.Table (J).Source_Last
 405             then
 406                Source_Cache_Index := J;
 407                Source_Cache_First :=
 408                  Source_File.Table (Source_Cache_Index).Source_First;
 409                Source_Cache_Last :=
 410                  Source_File.Table (Source_Cache_Index).Source_Last;
 411                return Source_Cache_Index;
 412             end if;
 413          end loop;
 414       end if;
 415
 416       --  We must find a matching entry in the above loop!
 417
 418       raise Program_Error;
 419    end Get_Source_File_Index;
 420
 421    ----------------
 422    -- Initialize --
 423    ----------------
 424
 425    procedure Initialize is
 426    begin
 427       Source_Cache_First := 1;
 428       Source_Cache_Last  := 0;
 429       Source_Cache_Index := No_Source_File;
 430       Source_gnat_adc    := No_Source_File;
 431       First_Time_Around  := True;
 432
 433       Source_File.Init;
 434    end Initialize;
 435
 436    -------------------------
 437    -- Instantiation_Depth --
 438    -------------------------
 439
 440    function Instantiation_Depth (S : Source_Ptr) return Nat is
 441       Sind  : Source_File_Index;
 442       Sval  : Source_Ptr;
 443       Depth : Nat;
 444
 445    begin
 446       Sval := S;
 447       Depth := 0;
 448
 449       loop
 450          Sind := Get_Source_File_Index (Sval);
 451          Sval := Instantiation (Sind);
 452          exit when Sval = No_Location;
 453          Depth := Depth + 1;
 454       end loop;
 455
 456       return Depth;
 457    end Instantiation_Depth;
 458
 459    ----------------------------
 460    -- Instantiation_Location --
 461    ----------------------------
 462
 463    function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
 464    begin
 465       return Instantiation (Get_Source_File_Index (S));
 466    end Instantiation_Location;
 467
 468    ----------------------
 469    -- Last_Source_File --
 470    ----------------------
 471
 472    function Last_Source_File return Source_File_Index is
 473    begin
 474       return Source_File.Last;
 475    end Last_Source_File;
 476
 477    ----------------
 478    -- Line_Start --
 479    ----------------
 480
 481    function Line_Start (P : Source_Ptr) return Source_Ptr is
 482       Sindex : constant Source_File_Index := Get_Source_File_Index (P);
 483       Src    : constant Source_Buffer_Ptr :=
 484                  Source_File.Table (Sindex).Source_Text;
 485       Sfirst : constant Source_Ptr :=
 486                  Source_File.Table (Sindex).Source_First;
 487       S      : Source_Ptr;
 488
 489    begin
 490       S := P;
 491       while S > Sfirst
 492         and then Src (S - 1) /= CR
 493         and then Src (S - 1) /= LF
 494       loop
 495          S := S - 1;
 496       end loop;
 497
 498       return S;
 499    end Line_Start;
 500
 501    function Line_Start
 502      (L : Physical_Line_Number;
 503       S : Source_File_Index) return Source_Ptr
 504    is
 505    begin
 506       return Source_File.Table (S).Lines_Table (L);
 507    end Line_Start;
 508
 509    ----------
 510    -- Lock --
 511    ----------
 512
 513    procedure Lock is
 514    begin
 515       Source_File.Locked := True;
 516       Source_File.Release;
 517    end Lock;
 518
 519    ----------------------
 520    -- Num_Source_Files --
 521    ----------------------
 522
 523    function Num_Source_Files return Nat is
 524    begin
 525       return Int (Source_File.Last) - Int (Source_File.First) + 1;
 526    end Num_Source_Files;
 527
 528    ----------------------
 529    -- Num_Source_Lines --
 530    ----------------------
 531
 532    function Num_Source_Lines (S : Source_File_Index) return Nat is
 533    begin
 534       return Nat (Source_File.Table (S).Last_Source_Line);
 535    end Num_Source_Lines;
 536
 537    -----------------------
 538    -- Original_Location --
 539    -----------------------
 540
 541    function Original_Location (S : Source_Ptr) return Source_Ptr is
 542       Sindex : Source_File_Index;
 543       Tindex : Source_File_Index;
 544
 545    begin
 546       if S <= No_Location then
 547          return S;
 548
 549       else
 550          Sindex := Get_Source_File_Index (S);
 551
 552          if Instantiation (Sindex) = No_Location then
 553             return S;
 554
 555          else
 556             Tindex := Template (Sindex);
 557             while Instantiation (Tindex) /= No_Location loop
 558                Tindex := Template (Tindex);
 559             end loop;
 560
 561             return S - Source_First (Sindex) + Source_First (Tindex);
 562          end if;
 563       end if;
 564    end Original_Location;
 565
 566    -------------------------
 567    -- Physical_To_Logical --
 568    -------------------------
 569
 570    function Physical_To_Logical
 571      (Line : Physical_Line_Number;
 572       S    : Source_File_Index) return Logical_Line_Number
 573    is
 574       SFR : Source_File_Record renames Source_File.Table (S);
 575
 576    begin
 577       if SFR.Num_SRef_Pragmas = 0 then
 578          return Logical_Line_Number (Line);
 579       else
 580          return SFR.Logical_Lines_Table (Line);
 581       end if;
 582    end Physical_To_Logical;
 583
 584    --------------------------------
 585    -- Register_Source_Ref_Pragma --
 586    --------------------------------
 587
 588    procedure Register_Source_Ref_Pragma
 589      (File_Name          : File_Name_Type;
 590       Stripped_File_Name : File_Name_Type;
 591       Mapped_Line        : Nat;
 592       Line_After_Pragma  : Physical_Line_Number)
 593    is
 594       subtype size_t is Memory.size_t;
 595
 596       SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
 597
 598       ML : Logical_Line_Number;
 599
 600    begin
 601       if File_Name /= No_File then
 602          SFR.Reference_Name := Stripped_File_Name;
 603          SFR.Full_Ref_Name  := File_Name;
 604
 605          if not Debug_Generated_Code then
 606             SFR.Debug_Source_Name := Stripped_File_Name;
 607             SFR.Full_Debug_Name   := File_Name;
 608          end if;
 609
 610          SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
 611       end if;
 612
 613       if SFR.Num_SRef_Pragmas = 1 then
 614          SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
 615       end if;
 616
 617       if SFR.Logical_Lines_Table = null then
 618          SFR.Logical_Lines_Table := To_Pointer
 619            (Memory.Alloc
 620              (size_t (SFR.Lines_Table_Max *
 621                         Logical_Lines_Table_Type'Component_Size /
 622                                                         Storage_Unit)));
 623       end if;
 624
 625       SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
 626
 627       ML := Logical_Line_Number (Mapped_Line);
 628       for J in Line_After_Pragma .. SFR.Last_Source_Line loop
 629          SFR.Logical_Lines_Table (J) := ML;
 630          ML := ML + 1;
 631       end loop;
 632    end Register_Source_Ref_Pragma;
 633
 634    ---------------------------------
 635    -- Set_Source_File_Index_Table --
 636    ---------------------------------
 637
 638    procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
 639       Ind : Int;
 640       SP  : Source_Ptr;
 641       SL  : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
 642
 643    begin
 644       SP  := (Source_File.Table (Xnew).Source_First + Chunk_Size - 1)
 645                                                     / Chunk_Size * Chunk_Size;
 646       Ind := Int (SP) / Chunk_Size;
 647
 648       while SP <= SL loop
 649          Source_File_Index_Table (Ind) := Xnew;
 650          SP := SP + Chunk_Size;
 651          Ind := Ind + 1;
 652       end loop;
 653    end Set_Source_File_Index_Table;
 654
 655    ---------------------------
 656    -- Skip_Line_Terminators --
 657    ---------------------------
 658
 659    procedure Skip_Line_Terminators
 660      (P        : in out Source_Ptr;
 661       Physical : out Boolean)
 662    is
 663       Chr : constant Character := Source (P);
 664
 665    begin
 666       if Chr = CR then
 667          if Source (P + 1) = LF then
 668             P := P + 2;
 669          else
 670             P := P + 1;
 671          end if;
 672
 673       elsif Chr = LF then
 674          P := P + 1;
 675
 676       elsif Chr = FF or else Chr = VT then
 677          P := P + 1;
 678          Physical := False;
 679          return;
 680
 681          --  Otherwise we have a wide character
 682
 683       else
 684          Skip_Wide (Source, P);
 685       end if;
 686
 687       --  Fall through in the physical line terminator case. First deal with
 688       --  making a possible entry into the lines table if one is needed.
 689
 690       --  Note: we are dealing with a real source file here, this cannot be
 691       --  the instantiation case, so we need not worry about Sloc adjustment.
 692
 693       declare
 694          S : Source_File_Record
 695                renames Source_File.Table (Current_Source_File);
 696
 697       begin
 698          Physical := True;
 699
 700          --  Make entry in lines table if not already made (in some scan backup
 701          --  cases, we will be rescanning previously scanned source, so the
 702          --  entry may have already been made on the previous forward scan).
 703
 704          if Source (P) /= EOF
 705            and then P > S.Lines_Table (S.Last_Source_Line)
 706          then
 707             Add_Line_Tables_Entry (S, P);
 708          end if;
 709       end;
 710    end Skip_Line_Terminators;
 711
 712    ----------------
 713    -- Sloc_Range --
 714    ----------------
 715
 716    procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
 717
 718       function Process (N : Node_Id) return Traverse_Result;
 719       --  Process function for traversing the node tree
 720
 721       procedure Traverse is new Traverse_Proc (Process);
 722
 723       -------------
 724       -- Process --
 725       -------------
 726
 727       function Process (N : Node_Id) return Traverse_Result is
 728       begin
 729          if Sloc (N) < Min then
 730             if Sloc (N) > No_Location then
 731                Min := Sloc (N);
 732             end if;
 733          elsif Sloc (N) > Max then
 734             if Sloc (N) > No_Location then
 735                Max := Sloc (N);
 736             end if;
 737          end if;
 738
 739          return OK;
 740       end Process;
 741
 742    --  Start of processing for Sloc_Range
 743
 744    begin
 745       Min := Sloc (N);
 746       Max := Sloc (N);
 747       Traverse (N);
 748    end Sloc_Range;
 749
 750    -------------------
 751    -- Source_Offset --
 752    -------------------
 753
 754    function Source_Offset (S : Source_Ptr) return Nat is
 755       Sindex : constant Source_File_Index := Get_Source_File_Index (S);
 756       Sfirst : constant Source_Ptr :=
 757                  Source_File.Table (Sindex).Source_First;
 758    begin
 759       return Nat (S - Sfirst);
 760    end Source_Offset;
 761
 762    ------------------------
 763    -- Top_Level_Location --
 764    ------------------------
 765
 766    function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
 767       Oldloc : Source_Ptr;
 768       Newloc : Source_Ptr;
 769
 770    begin
 771       Newloc := S;
 772       loop
 773          Oldloc := Newloc;
 774          Newloc := Instantiation_Location (Oldloc);
 775          exit when Newloc = No_Location;
 776       end loop;
 777
 778       return Oldloc;
 779    end Top_Level_Location;
 780
 781    ---------------
 782    -- Tree_Read --
 783    ---------------
 784
 785    procedure Tree_Read is
 786    begin
 787       --  First we must free any old source buffer pointers
 788
 789       if not First_Time_Around then
 790          for J in Source_File.First .. Source_File.Last loop
 791             declare
 792                S : Source_File_Record renames Source_File.Table (J);
 793
 794                procedure Free_Ptr is new Unchecked_Deallocation
 795                  (Big_Source_Buffer, Source_Buffer_Ptr);
 796
 797                pragma Warnings (Off);
 798                --  This unchecked conversion is aliasing safe, since it is not
 799                --  used to create improperly aliased pointer values.
 800
 801                function To_Source_Buffer_Ptr is new
 802                  Unchecked_Conversion (Address, Source_Buffer_Ptr);
 803
 804                pragma Warnings (On);
 805
 806                Tmp1 : Source_Buffer_Ptr;
 807
 808             begin
 809                if S.Instantiation /= No_Location then
 810                   null;
 811
 812                else
 813                   --  Free the buffer, we use Free here, because we used malloc
 814                   --  or realloc directly to allocate the tables. That is
 815                   --  because we were playing the big array trick.
 816
 817                   --  We have to recreate a proper pointer to the actual array
 818                   --  from the zero origin pointer stored in the source table.
 819
 820                   Tmp1 :=
 821                     To_Source_Buffer_Ptr
 822                       (S.Source_Text (S.Source_First)'Address);
 823                   Free_Ptr (Tmp1);
 824
 825                   if S.Lines_Table /= null then
 826                      Memory.Free (To_Address (S.Lines_Table));
 827                      S.Lines_Table := null;
 828                   end if;
 829
 830                   if S.Logical_Lines_Table /= null then
 831                      Memory.Free (To_Address (S.Logical_Lines_Table));
 832                      S.Logical_Lines_Table := null;
 833                   end if;
 834                end if;
 835             end;
 836          end loop;
 837       end if;
 838
 839       --  Reset source cache pointers to force new read
 840
 841       Source_Cache_First := 1;
 842       Source_Cache_Last  := 0;
 843
 844       --  Read in source file table
 845
 846       Source_File.Tree_Read;
 847
 848       --  The pointers we read in there for the source buffer and lines
 849       --  table pointers are junk. We now read in the actual data that
 850       --  is referenced by these two fields.
 851
 852       for J in Source_File.First .. Source_File.Last loop
 853          declare
 854             S : Source_File_Record renames Source_File.Table (J);
 855
 856          begin
 857             --  For the instantiation case, we do not read in any data. Instead
 858             --  we share the data for the generic template entry. Since the
 859             --  template always occurs first, we can safely refer to its data.
 860
 861             if S.Instantiation /= No_Location then
 862                declare
 863                   ST : Source_File_Record renames
 864                          Source_File.Table (S.Template);
 865
 866                begin
 867                   --  The lines tables are copied from the template entry
 868
 869                   S.Lines_Table :=
 870                     Source_File.Table (S.Template).Lines_Table;
 871                   S.Logical_Lines_Table :=
 872                     Source_File.Table (S.Template).Logical_Lines_Table;
 873
 874                   --  In the case of the source table pointer, we share the
 875                   --  same data as the generic template, but the virtual origin
 876                   --  is adjusted. For example, if the first subscript of the
 877                   --  template is 100, and that of the instantiation is 200,
 878                   --  then the instantiation pointer is obtained by subtracting
 879                   --  100 from the template pointer.
 880
 881                   declare
 882                      pragma Suppress (All_Checks);
 883
 884                      pragma Warnings (Off);
 885                      --  This unchecked conversion is aliasing safe since it
 886                      --  not used to create improperly aliased pointer values.
 887
 888                      function To_Source_Buffer_Ptr is new
 889                        Unchecked_Conversion (Address, Source_Buffer_Ptr);
 890
 891                      pragma Warnings (On);
 892
 893                   begin
 894                      S.Source_Text :=
 895                        To_Source_Buffer_Ptr
 896                           (ST.Source_Text
 897                             (ST.Source_First - S.Source_First)'Address);
 898                   end;
 899                end;
 900
 901             --  Normal case (non-instantiation)
 902
 903             else
 904                First_Time_Around := False;
 905                S.Lines_Table := null;
 906                S.Logical_Lines_Table := null;
 907                Alloc_Line_Tables (S, Int (S.Last_Source_Line));
 908
 909                for J in 1 .. S.Last_Source_Line loop
 910                   Tree_Read_Int (Int (S.Lines_Table (J)));
 911                end loop;
 912
 913                if S.Num_SRef_Pragmas /= 0 then
 914                   for J in 1 .. S.Last_Source_Line loop
 915                      Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
 916                   end loop;
 917                end if;
 918
 919                --  Allocate source buffer and read in the data and then set the
 920                --  virtual origin to point to the logical zero'th element. This
 921                --  address must be computed with subscript checks turned off.
 922
 923                declare
 924                   subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
 925                   type Text_Buffer_Ptr is access B;
 926                   T : Text_Buffer_Ptr;
 927
 928                   pragma Suppress (All_Checks);
 929
 930                   pragma Warnings (Off);
 931                   --  This unchecked conversion is aliasing safe, since it is
 932                   --  never used to create improperly aliased pointer values.
 933
 934                   function To_Source_Buffer_Ptr is new
 935                     Unchecked_Conversion (Address, Source_Buffer_Ptr);
 936
 937                   pragma Warnings (On);
 938
 939                begin
 940                   T := new B;
 941
 942                   Tree_Read_Data (T (S.Source_First)'Address,
 943                      Int (S.Source_Last) - Int (S.Source_First) + 1);
 944
 945                   S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
 946                end;
 947             end if;
 948          end;
 949
 950          Set_Source_File_Index_Table (J);
 951       end loop;
 952    end Tree_Read;
 953
 954    ----------------
 955    -- Tree_Write --
 956    ----------------
 957
 958    procedure Tree_Write is
 959    begin
 960       Source_File.Tree_Write;
 961
 962       --  The pointers we wrote out there for the source buffer and lines
 963       --  table pointers are junk, we now write out the actual data that
 964       --  is referenced by these two fields.
 965
 966       for J in Source_File.First .. Source_File.Last loop
 967          declare
 968             S : Source_File_Record renames Source_File.Table (J);
 969
 970          begin
 971             --  For instantiations, there is nothing to do, since the data is
 972             --  shared with the generic template. When the tree is read, the
 973             --  pointers must be set, but no extra data needs to be written.
 974
 975             if S.Instantiation /= No_Location then
 976                null;
 977
 978             --  For the normal case, write out the data of the tables
 979
 980             else
 981                --  Lines table
 982
 983                for J in 1 .. S.Last_Source_Line loop
 984                   Tree_Write_Int (Int (S.Lines_Table (J)));
 985                end loop;
 986
 987                --  Logical lines table if present
 988
 989                if S.Num_SRef_Pragmas /= 0 then
 990                   for J in 1 .. S.Last_Source_Line loop
 991                      Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
 992                   end loop;
 993                end if;
 994
 995                --  Source buffer
 996
 997                Tree_Write_Data
 998                  (S.Source_Text (S.Source_First)'Address,
 999                    Int (S.Source_Last) - Int (S.Source_First) + 1);
1000             end if;
1001          end;
1002       end loop;
1003    end Tree_Write;
1004
1005    --------------------
1006    -- Write_Location --
1007    --------------------
1008
1009    procedure Write_Location (P : Source_Ptr) is
1010    begin
1011       if P = No_Location then
1012          Write_Str ("<no location>");
1013
1014       elsif P <= Standard_Location then
1015          Write_Str ("<standard location>");
1016
1017       else
1018          declare
1019             SI : constant Source_File_Index := Get_Source_File_Index (P);
1020
1021          begin
1022             Write_Name (Debug_Source_Name (SI));
1023             Write_Char (':');
1024             Write_Int (Int (Get_Logical_Line_Number (P)));
1025             Write_Char (':');
1026             Write_Int (Int (Get_Column_Number (P)));
1027
1028             if Instantiation (SI) /= No_Location then
1029                Write_Str (" [");
1030                Write_Location (Instantiation (SI));
1031                Write_Char (']');
1032             end if;
1033          end;
1034       end if;
1035    end Write_Location;
1036
1037    ----------------------
1038    -- Write_Time_Stamp --
1039    ----------------------
1040
1041    procedure Write_Time_Stamp (S : Source_File_Index) is
1042       T : constant Time_Stamp_Type := Time_Stamp (S);
1043       P : Natural;
1044
1045    begin
1046       if T (1) = '9' then
1047          Write_Str ("19");
1048          P := 0;
1049       else
1050          Write_Char (T (1));
1051          Write_Char (T (2));
1052          P := 2;
1053       end if;
1054
1055       Write_Char (T (P + 1));
1056       Write_Char (T (P + 2));
1057       Write_Char ('-');
1058
1059       Write_Char (T (P + 3));
1060       Write_Char (T (P + 4));
1061       Write_Char ('-');
1062
1063       Write_Char (T (P + 5));
1064       Write_Char (T (P + 6));
1065       Write_Char (' ');
1066
1067       Write_Char (T (P + 7));
1068       Write_Char (T (P + 8));
1069       Write_Char (':');
1070
1071       Write_Char (T (P + 9));
1072       Write_Char (T (P + 10));
1073       Write_Char (':');
1074
1075       Write_Char (T (P + 11));
1076       Write_Char (T (P + 12));
1077    end Write_Time_Stamp;
1078
1079    ----------------------------------------------
1080    -- Access Subprograms for Source File Table --
1081    ----------------------------------------------
1082
1083    function Debug_Source_Name (S : SFI) return File_Name_Type is
1084    begin
1085       return Source_File.Table (S).Debug_Source_Name;
1086    end Debug_Source_Name;
1087
1088    function File_Name (S : SFI) return File_Name_Type is
1089    begin
1090       return Source_File.Table (S).File_Name;
1091    end File_Name;
1092
1093    function File_Type (S : SFI) return Type_Of_File is
1094    begin
1095       return Source_File.Table (S).File_Type;
1096    end File_Type;
1097
1098    function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1099    begin
1100       return Source_File.Table (S).First_Mapped_Line;
1101    end First_Mapped_Line;
1102
1103    function Full_Debug_Name (S : SFI) return File_Name_Type is
1104    begin
1105       return Source_File.Table (S).Full_Debug_Name;
1106    end Full_Debug_Name;
1107
1108    function Full_File_Name (S : SFI) return File_Name_Type is
1109    begin
1110       return Source_File.Table (S).Full_File_Name;
1111    end Full_File_Name;
1112
1113    function Full_Ref_Name (S : SFI) return File_Name_Type is
1114    begin
1115       return Source_File.Table (S).Full_Ref_Name;
1116    end Full_Ref_Name;
1117
1118    function Identifier_Casing (S : SFI) return Casing_Type is
1119    begin
1120       return Source_File.Table (S).Identifier_Casing;
1121    end Identifier_Casing;
1122
1123    function Inlined_Body (S : SFI) return Boolean is
1124    begin
1125       return Source_File.Table (S).Inlined_Body;
1126    end Inlined_Body;
1127
1128    function Instantiation (S : SFI) return Source_Ptr is
1129    begin
1130       return Source_File.Table (S).Instantiation;
1131    end Instantiation;
1132
1133    function Keyword_Casing (S : SFI) return Casing_Type is
1134    begin
1135       return Source_File.Table (S).Keyword_Casing;
1136    end Keyword_Casing;
1137
1138    function Last_Source_Line (S : SFI) return Physical_Line_Number is
1139    begin
1140       return Source_File.Table (S).Last_Source_Line;
1141    end Last_Source_Line;
1142
1143    function License (S : SFI) return License_Type is
1144    begin
1145       return Source_File.Table (S).License;
1146    end License;
1147
1148    function Num_SRef_Pragmas (S : SFI) return Nat is
1149    begin
1150       return Source_File.Table (S).Num_SRef_Pragmas;
1151    end Num_SRef_Pragmas;
1152
1153    function Reference_Name (S : SFI) return File_Name_Type is
1154    begin
1155       return Source_File.Table (S).Reference_Name;
1156    end Reference_Name;
1157
1158    function Source_Checksum (S : SFI) return Word is
1159    begin
1160       return Source_File.Table (S).Source_Checksum;
1161    end Source_Checksum;
1162
1163    function Source_First (S : SFI) return Source_Ptr is
1164    begin
1165       if S = Internal_Source_File then
1166          return Internal_Source'First;
1167       else
1168          return Source_File.Table (S).Source_First;
1169       end if;
1170    end Source_First;
1171
1172    function Source_Last (S : SFI) return Source_Ptr is
1173    begin
1174       if S = Internal_Source_File then
1175          return Internal_Source'Last;
1176       else
1177          return Source_File.Table (S).Source_Last;
1178       end if;
1179    end Source_Last;
1180
1181    function Source_Text (S : SFI) return Source_Buffer_Ptr is
1182    begin
1183       if S = Internal_Source_File then
1184          return Internal_Source_Ptr;
1185       else
1186          return Source_File.Table (S).Source_Text;
1187       end if;
1188    end Source_Text;
1189
1190    function Template (S : SFI) return SFI is
1191    begin
1192       return Source_File.Table (S).Template;
1193    end Template;
1194
1195    function Time_Stamp (S : SFI) return Time_Stamp_Type is
1196    begin
1197       return Source_File.Table (S).Time_Stamp;
1198    end Time_Stamp;
1199
1200    function Unit (S : SFI) return Unit_Number_Type is
1201    begin
1202       return Source_File.Table (S).Unit;
1203    end Unit;
1204
1205    ------------------------------------------
1206    -- Set Procedures for Source File Table --
1207    ------------------------------------------
1208
1209    procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1210    begin
1211       Source_File.Table (S).Identifier_Casing := C;
1212    end Set_Identifier_Casing;
1213
1214    procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1215    begin
1216       Source_File.Table (S).Keyword_Casing := C;
1217    end Set_Keyword_Casing;
1218
1219    procedure Set_License (S : SFI; L : License_Type) is
1220    begin
1221       Source_File.Table (S).License := L;
1222    end Set_License;
1223
1224    procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1225    begin
1226       Source_File.Table (S).Unit := U;
1227    end Set_Unit;
1228
1229    ----------------------
1230    -- Trim_Lines_Table --
1231    ----------------------
1232
1233    procedure Trim_Lines_Table (S : Source_File_Index) is
1234       Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1235
1236    begin
1237       --  Release allocated storage that is no longer needed
1238
1239       Source_File.Table (S).Lines_Table := To_Pointer
1240         (Memory.Realloc
1241           (To_Address (Source_File.Table (S).Lines_Table),
1242            Memory.size_t
1243             (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1244       Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1245    end Trim_Lines_Table;
1246
1247    ------------
1248    -- Unlock --
1249    ------------
1250
1251    procedure Unlock is
1252    begin
1253       Source_File.Locked := False;
1254       Source_File.Release;
1255    end Unlock;
1256
1257    --------
1258    -- wl --
1259    --------
1260
1261    procedure wl (P : Source_Ptr) is
1262    begin
1263       Write_Location (P);
1264       Write_Eol;
1265    end wl;
1266
1267 end Sinput;