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