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-2019, 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 Scans;    use Scans;
  40 with Tree_IO;  use Tree_IO;
  41 with Widechar; use Widechar;
  42
  43 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
  44
  45 with System.Storage_Elements;
  46 with System.Memory;
  47 with System.WCh_Con; use System.WCh_Con;
  48
  49 with Unchecked_Conversion;
  50 with Unchecked_Deallocation;
  51
  52 package body Sinput is
  53
  54    use ASCII, System;
  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    -- Source_File_Index_Table --
  79    -----------------------------
  80
  81    --  The Get_Source_File_Index function is called very frequently. Earlier
  82    --  versions cached a single entry, but then reverted to a serial search,
  83    --  and this proved to be a significant source of inefficiency. We then
  84    --  switched to using a table with a start point followed by a serial
  85    --  search. Now we make sure source buffers are on a reasonable boundary
  86    --  (see Types.Source_Align), and we can just use a direct look up in the
  87    --  following table.
  88
  89    --  Note that this array is pretty large, but in most operating systems
  90    --  it will not be allocated in physical memory unless it is actually used.
  91
  92    Source_File_Index_Table :
  93      array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index;
  94
  95    ---------------------------
  96    -- Add_Line_Tables_Entry --
  97    ---------------------------
  98
  99    procedure Add_Line_Tables_Entry
 100      (S : in out Source_File_Record;
 101       P : Source_Ptr)
 102    is
 103       LL : Physical_Line_Number;
 104
 105    begin
 106       --  Reallocate the lines tables if necessary
 107
 108       --  Note: the reason we do not use the normal Table package
 109       --  mechanism is that we have several of these tables. We could
 110       --  use the new GNAT.Dynamic_Tables package and that would probably
 111       --  be a good idea ???
 112
 113       if S.Last_Source_Line = S.Lines_Table_Max then
 114          Alloc_Line_Tables
 115            (S,
 116             Int (S.Last_Source_Line) *
 117               ((100 + Alloc.Lines_Increment) / 100));
 118
 119          if Debug_Flag_D then
 120             Write_Str ("--> Reallocating lines table, size = ");
 121             Write_Int (Int (S.Lines_Table_Max));
 122             Write_Eol;
 123          end if;
 124       end if;
 125
 126       S.Last_Source_Line := S.Last_Source_Line + 1;
 127       LL := S.Last_Source_Line;
 128
 129       S.Lines_Table (LL) := P;
 130
 131       --  Deal with setting new entry in logical lines table if one is
 132       --  present. Note that there is always space (because the call to
 133       --  Alloc_Line_Tables makes sure both tables are the same length),
 134
 135       if S.Logical_Lines_Table /= null then
 136
 137          --  We can always set the entry from the previous one, because
 138          --  the processing for a Source_Reference pragma ensures that
 139          --  at least one entry following the pragma is set up correctly.
 140
 141          S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
 142       end if;
 143    end Add_Line_Tables_Entry;
 144
 145    -----------------------
 146    -- Alloc_Line_Tables --
 147    -----------------------
 148
 149    procedure Alloc_Line_Tables
 150      (S       : in out Source_File_Record;
 151       New_Max : Nat)
 152    is
 153       subtype size_t is Memory.size_t;
 154
 155       New_Table : Lines_Table_Ptr;
 156
 157       New_Logical_Table : Logical_Lines_Table_Ptr;
 158
 159       New_Size : constant size_t :=
 160                    size_t (New_Max * Lines_Table_Type'Component_Size /
 161                                                              Storage_Unit);
 162
 163    begin
 164       if S.Lines_Table = null then
 165          New_Table := To_Pointer (Memory.Alloc (New_Size));
 166
 167       else
 168          New_Table :=
 169            To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
 170       end if;
 171
 172       if New_Table = null then
 173          raise Storage_Error;
 174       else
 175          S.Lines_Table     := New_Table;
 176          S.Lines_Table_Max := Physical_Line_Number (New_Max);
 177       end if;
 178
 179       if S.Num_SRef_Pragmas /= 0 then
 180          if S.Logical_Lines_Table = null then
 181             New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
 182          else
 183             New_Logical_Table := To_Pointer
 184               (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
 185          end if;
 186
 187          if New_Logical_Table = null then
 188             raise Storage_Error;
 189          else
 190             S.Logical_Lines_Table := New_Logical_Table;
 191          end if;
 192       end if;
 193    end Alloc_Line_Tables;
 194
 195    -----------------
 196    -- Backup_Line --
 197    -----------------
 198
 199    procedure Backup_Line (P : in out Source_Ptr) is
 200       Sindex : constant Source_File_Index := Get_Source_File_Index (P);
 201       Src    : constant Source_Buffer_Ptr :=
 202                  Source_File.Table (Sindex).Source_Text;
 203       Sfirst : constant Source_Ptr :=
 204                  Source_File.Table (Sindex).Source_First;
 205
 206    begin
 207       P := P - 1;
 208
 209       if P = Sfirst then
 210          return;
 211       end if;
 212
 213       if Src (P) = CR then
 214          if Src (P - 1) = LF then
 215             P := P - 1;
 216          end if;
 217
 218       else -- Src (P) = LF
 219          if Src (P - 1) = CR then
 220             P := P - 1;
 221          end if;
 222       end if;
 223
 224       --  Now find first character of the previous line
 225
 226       while P > Sfirst
 227         and then Src (P - 1) /= LF
 228         and then Src (P - 1) /= CR
 229       loop
 230          P := P - 1;
 231       end loop;
 232    end Backup_Line;
 233
 234    ---------------------------
 235    -- Build_Location_String --
 236    ---------------------------
 237
 238    procedure Build_Location_String
 239      (Buf : in out Bounded_String;
 240       Loc : Source_Ptr)
 241    is
 242       Ptr : Source_Ptr := Loc;
 243
 244    begin
 245       --  Loop through instantiations
 246
 247       loop
 248          Append (Buf, Reference_Name (Get_Source_File_Index (Ptr)));
 249          Append (Buf, ':');
 250          Append (Buf, Nat (Get_Logical_Line_Number (Ptr)));
 251
 252          Ptr := Instantiation_Location (Ptr);
 253          exit when Ptr = No_Location;
 254          Append (Buf, " instantiated at ");
 255       end loop;
 256    end Build_Location_String;
 257
 258    function Build_Location_String (Loc : Source_Ptr) return String is
 259       Buf : Bounded_String;
 260    begin
 261       Build_Location_String (Buf, Loc);
 262       return +Buf;
 263    end Build_Location_String;
 264
 265    -------------------
 266    -- Check_For_BOM --
 267    -------------------
 268
 269    procedure Check_For_BOM is
 270       BOM : BOM_Kind;
 271       Len : Natural;
 272       Tst : String (1 .. 5);
 273       C   : Character;
 274
 275    begin
 276       for J in 1 .. 5 loop
 277          C := Source (Scan_Ptr + Source_Ptr (J) - 1);
 278
 279          --  Definitely no BOM if EOF character marks either end of file, or
 280          --  an illegal non-BOM character if not at the end of file.
 281
 282          if C = EOF then
 283             return;
 284          end if;
 285
 286          Tst (J) := C;
 287       end loop;
 288
 289       Read_BOM (Tst, Len, BOM, XML_Support => False);
 290
 291       case BOM is
 292          when UTF8_All =>
 293             Scan_Ptr := Scan_Ptr + Source_Ptr (Len);
 294             First_Non_Blank_Location := Scan_Ptr;
 295             Current_Line_Start := Scan_Ptr;
 296             Wide_Character_Encoding_Method := WCEM_UTF8;
 297             Upper_Half_Encoding := True;
 298
 299          when UTF16_BE
 300             | UTF16_LE
 301          =>
 302             Set_Standard_Error;
 303             Write_Line ("UTF-16 encoding format not recognized");
 304             Set_Standard_Output;
 305             raise Unrecoverable_Error;
 306
 307          when UTF32_BE
 308             | UTF32_LE
 309          =>
 310             Set_Standard_Error;
 311             Write_Line ("UTF-32 encoding format not recognized");
 312             Set_Standard_Output;
 313             raise Unrecoverable_Error;
 314
 315          when Unknown =>
 316             null;
 317
 318          when others =>
 319             raise Program_Error;
 320       end case;
 321    end Check_For_BOM;
 322
 323    -----------------------------
 324    -- Clear_Source_File_Table --
 325    -----------------------------
 326
 327    procedure Free is new Unchecked_Deallocation
 328      (Lines_Table_Type, Lines_Table_Ptr);
 329
 330    procedure Free is new Unchecked_Deallocation
 331      (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr);
 332
 333    procedure Clear_Source_File_Table is
 334    begin
 335       for X in 1 .. Source_File.Last loop
 336          declare
 337             S  : Source_File_Record renames Source_File.Table (X);
 338          begin
 339             if S.Instance = No_Instance_Id then
 340                Free_Source_Buffer (S.Source_Text);
 341             else
 342                Free_Dope (S.Source_Text'Address);
 343                S.Source_Text := null;
 344             end if;
 345
 346             Free (S.Lines_Table);
 347             Free (S.Logical_Lines_Table);
 348          end;
 349       end loop;
 350
 351       Source_File.Free;
 352       Sinput.Initialize;
 353    end Clear_Source_File_Table;
 354
 355    ---------------------------------
 356    -- Comes_From_Inherited_Pragma --
 357    ---------------------------------
 358
 359    function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean is
 360       SIE : Source_File_Record renames
 361               Source_File.Table (Get_Source_File_Index (S));
 362    begin
 363       return SIE.Inherited_Pragma;
 364    end Comes_From_Inherited_Pragma;
 365
 366    -----------------------------
 367    -- Comes_From_Inlined_Body --
 368    -----------------------------
 369
 370    function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is
 371       SIE : Source_File_Record renames
 372               Source_File.Table (Get_Source_File_Index (S));
 373    begin
 374       return SIE.Inlined_Body;
 375    end Comes_From_Inlined_Body;
 376
 377    ------------------------
 378    -- Free_Source_Buffer --
 379    ------------------------
 380
 381    procedure Free_Source_Buffer (Src : in out Source_Buffer_Ptr) is
 382       --  Unchecked_Deallocation doesn't work for access-to-constant; we need
 383       --  to first Unchecked_Convert to access-to-variable.
 384
 385       function To_Source_Buffer_Ptr_Var is new
 386         Unchecked_Conversion (Source_Buffer_Ptr, Source_Buffer_Ptr_Var);
 387
 388       Temp : Source_Buffer_Ptr_Var := To_Source_Buffer_Ptr_Var (Src);
 389
 390       procedure Free_Ptr is new
 391         Unchecked_Deallocation (Source_Buffer, Source_Buffer_Ptr_Var);
 392    begin
 393       Free_Ptr (Temp);
 394       Src := null;
 395    end Free_Source_Buffer;
 396
 397    -----------------------
 398    -- Get_Column_Number --
 399    -----------------------
 400
 401    function Get_Column_Number (P : Source_Ptr) return Column_Number is
 402       S      : Source_Ptr;
 403       C      : Column_Number;
 404       Sindex : Source_File_Index;
 405       Src    : Source_Buffer_Ptr;
 406
 407    begin
 408       --  If the input source pointer is not a meaningful value then return
 409       --  at once with column number 1. This can happen for a file not found
 410       --  condition for a file loaded indirectly by RTE, and also perhaps on
 411       --  some unknown internal error conditions. In either case we certainly
 412       --  don't want to blow up.
 413
 414       if P < 1 then
 415          return 1;
 416
 417       else
 418          Sindex := Get_Source_File_Index (P);
 419          Src := Source_File.Table (Sindex).Source_Text;
 420          S := Line_Start (P);
 421          C := 1;
 422
 423          while S < P loop
 424             if Src (S) = HT then
 425                C := (C - 1) / 8 * 8 + (8 + 1);
 426                S := S + 1;
 427
 428             --  Deal with wide character case, but don't include brackets
 429             --  notation in this circuit, since we know that this will
 430             --  display unencoded (no one encodes brackets notation).
 431
 432             elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then
 433                C := C + 1;
 434                Skip_Wide (Src, S);
 435
 436             --  Normal (non-wide) character case or brackets sequence
 437
 438             else
 439                C := C + 1;
 440                S := S + 1;
 441             end if;
 442          end loop;
 443
 444          return C;
 445       end if;
 446    end Get_Column_Number;
 447
 448    -----------------------------
 449    -- Get_Logical_Line_Number --
 450    -----------------------------
 451
 452    function Get_Logical_Line_Number
 453      (P : Source_Ptr) return Logical_Line_Number
 454    is
 455       SFR : Source_File_Record
 456               renames Source_File.Table (Get_Source_File_Index (P));
 457
 458       L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
 459
 460    begin
 461       if SFR.Num_SRef_Pragmas = 0 then
 462          return Logical_Line_Number (L);
 463       else
 464          return SFR.Logical_Lines_Table (L);
 465       end if;
 466    end Get_Logical_Line_Number;
 467
 468    ---------------------------------
 469    -- Get_Logical_Line_Number_Img --
 470    ---------------------------------
 471
 472    function Get_Logical_Line_Number_Img
 473      (P : Source_Ptr) return String
 474    is
 475    begin
 476       Name_Len := 0;
 477       Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P)));
 478       return Name_Buffer (1 .. Name_Len);
 479    end Get_Logical_Line_Number_Img;
 480
 481    ------------------------------
 482    -- Get_Physical_Line_Number --
 483    ------------------------------
 484
 485    function Get_Physical_Line_Number
 486      (P : Source_Ptr) return Physical_Line_Number
 487    is
 488       Sfile : Source_File_Index;
 489       Table : Lines_Table_Ptr;
 490       Lo    : Physical_Line_Number;
 491       Hi    : Physical_Line_Number;
 492       Mid   : Physical_Line_Number;
 493       Loc   : Source_Ptr;
 494
 495    begin
 496       --  If the input source pointer is not a meaningful value then return
 497       --  at once with line number 1. This can happen for a file not found
 498       --  condition for a file loaded indirectly by RTE, and also perhaps on
 499       --  some unknown internal error conditions. In either case we certainly
 500       --  don't want to blow up.
 501
 502       if P < 1 then
 503          return 1;
 504
 505       --  Otherwise we can do the binary search
 506
 507       else
 508          Sfile := Get_Source_File_Index (P);
 509          Loc   := P + Source_File.Table (Sfile).Sloc_Adjust;
 510          Table := Source_File.Table (Sfile).Lines_Table;
 511          Lo    := 1;
 512          Hi    := Source_File.Table (Sfile).Last_Source_Line;
 513
 514          loop
 515             Mid := (Lo + Hi) / 2;
 516
 517             if Loc < Table (Mid) then
 518                Hi := Mid - 1;
 519
 520             else -- Loc >= Table (Mid)
 521
 522                if Mid = Hi or else
 523                   Loc < Table (Mid + 1)
 524                then
 525                   return Mid;
 526                else
 527                   Lo := Mid + 1;
 528                end if;
 529
 530             end if;
 531
 532          end loop;
 533       end if;
 534    end Get_Physical_Line_Number;
 535
 536    ---------------------------
 537    -- Get_Source_File_Index --
 538    ---------------------------
 539
 540    function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
 541       Result : Source_File_Index;
 542
 543       procedure Assertions;
 544       --  Assert various properties of the result
 545
 546       procedure Assertions is
 547
 548          --  ???The old version using zero-origin array indexing without array
 549          --  bounds checks returned 1 (i.e. system.ads) for these special
 550          --  locations, presumably by accident. We are mimicing that here.
 551
 552          Special : constant Boolean :=
 553                      S = No_Location
 554                        or else S = Standard_Location
 555                        or else S = Standard_ASCII_Location
 556                        or else S = System_Location;
 557
 558          pragma Assert ((S > No_Location) xor Special);
 559          pragma Assert (Result in Source_File.First .. Source_File.Last);
 560
 561          SFR : Source_File_Record renames Source_File.Table (Result);
 562
 563       begin
 564          --  SFR.Source_Text = null if and only if this is the SFR for a debug
 565          --  output file (*.dg), and that file is under construction. S can be
 566          --  slightly past Source_Last in that case because we haven't updated
 567          --  Source_Last.
 568
 569          if Null_Source_Buffer_Ptr (SFR.Source_Text) then
 570             pragma Assert (S >= SFR.Source_First); null;
 571          else
 572             pragma Assert (SFR.Source_Text'First = SFR.Source_First);
 573             pragma Assert (SFR.Source_Text'Last = SFR.Source_Last);
 574
 575             if not Special then
 576                pragma Assert (S in SFR.Source_First .. SFR.Source_Last);
 577                null;
 578             end if;
 579          end if;
 580       end Assertions;
 581
 582    --  Start of processing for Get_Source_File_Index
 583
 584    begin
 585       if S > No_Location then
 586          Result := Source_File_Index_Table (Int (S) / Source_Align);
 587       else
 588          Result := 1;
 589       end if;
 590
 591       pragma Debug (Assertions);
 592
 593       return Result;
 594    end Get_Source_File_Index;
 595
 596    ----------------
 597    -- Initialize --
 598    ----------------
 599
 600    procedure Initialize is
 601    begin
 602       Source_gnat_adc := No_Source_File;
 603       Source_File.Init;
 604       Instances.Init;
 605       Instances.Append (No_Location);
 606       pragma Assert (Instances.Last = No_Instance_Id);
 607    end Initialize;
 608
 609    -------------------
 610    -- Instantiation --
 611    -------------------
 612
 613    function Instantiation (S : SFI) return Source_Ptr is
 614       SIE : Source_File_Record renames Source_File.Table (S);
 615    begin
 616       if SIE.Inlined_Body or SIE.Inherited_Pragma then
 617          return SIE.Inlined_Call;
 618       else
 619          return Instances.Table (SIE.Instance);
 620       end if;
 621    end Instantiation;
 622
 623    -------------------------
 624    -- Instantiation_Depth --
 625    -------------------------
 626
 627    function Instantiation_Depth (S : Source_Ptr) return Nat is
 628       Sind  : Source_File_Index;
 629       Sval  : Source_Ptr;
 630       Depth : Nat;
 631
 632    begin
 633       Sval := S;
 634       Depth := 0;
 635
 636       loop
 637          Sind := Get_Source_File_Index (Sval);
 638          Sval := Instantiation (Sind);
 639          exit when Sval = No_Location;
 640          Depth := Depth + 1;
 641       end loop;
 642
 643       return Depth;
 644    end Instantiation_Depth;
 645
 646    ----------------------------
 647    -- Instantiation_Location --
 648    ----------------------------
 649
 650    function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
 651    begin
 652       return Instantiation (Get_Source_File_Index (S));
 653    end Instantiation_Location;
 654
 655    --------------------------
 656    -- Iterate_On_Instances --
 657    --------------------------
 658
 659    procedure Iterate_On_Instances is
 660    begin
 661       for J in 1 .. Instances.Last loop
 662          Process (J, Instances.Table (J));
 663       end loop;
 664    end Iterate_On_Instances;
 665
 666    ----------------------
 667    -- Last_Source_File --
 668    ----------------------
 669
 670    function Last_Source_File return Source_File_Index is
 671    begin
 672       return Source_File.Last;
 673    end Last_Source_File;
 674
 675    ----------------
 676    -- Line_Start --
 677    ----------------
 678
 679    function Line_Start (P : Source_Ptr) return Source_Ptr is
 680       Sindex : constant Source_File_Index := Get_Source_File_Index (P);
 681       Src    : constant Source_Buffer_Ptr :=
 682                  Source_File.Table (Sindex).Source_Text;
 683       Sfirst : constant Source_Ptr :=
 684                  Source_File.Table (Sindex).Source_First;
 685       S      : Source_Ptr;
 686
 687    begin
 688       S := P;
 689       while S > Sfirst
 690         and then Src (S - 1) /= CR
 691         and then Src (S - 1) /= LF
 692       loop
 693          S := S - 1;
 694       end loop;
 695
 696       return S;
 697    end Line_Start;
 698
 699    function Line_Start
 700      (L : Physical_Line_Number;
 701       S : Source_File_Index) return Source_Ptr
 702    is
 703    begin
 704       return Source_File.Table (S).Lines_Table (L);
 705    end Line_Start;
 706
 707    ----------
 708    -- Lock --
 709    ----------
 710
 711    procedure Lock is
 712    begin
 713       Source_File.Release;
 714       Source_File.Locked := True;
 715    end Lock;
 716
 717    ----------------------
 718    -- Num_Source_Files --
 719    ----------------------
 720
 721    function Num_Source_Files return Nat is
 722    begin
 723       return Int (Source_File.Last) - Int (Source_File.First) + 1;
 724    end Num_Source_Files;
 725
 726    ----------------------
 727    -- Num_Source_Lines --
 728    ----------------------
 729
 730    function Num_Source_Lines (S : Source_File_Index) return Nat is
 731    begin
 732       return Nat (Source_File.Table (S).Last_Source_Line);
 733    end Num_Source_Lines;
 734
 735    -----------------------
 736    -- Original_Location --
 737    -----------------------
 738
 739    function Original_Location (S : Source_Ptr) return Source_Ptr is
 740       Sindex : Source_File_Index;
 741       Tindex : Source_File_Index;
 742
 743    begin
 744       if S <= No_Location then
 745          return S;
 746
 747       else
 748          Sindex := Get_Source_File_Index (S);
 749
 750          if Instantiation (Sindex) = No_Location then
 751             return S;
 752
 753          else
 754             Tindex := Template (Sindex);
 755             while Instantiation (Tindex) /= No_Location loop
 756                Tindex := Template (Tindex);
 757             end loop;
 758
 759             return S - Source_First (Sindex) + Source_First (Tindex);
 760          end if;
 761       end if;
 762    end Original_Location;
 763
 764    -------------------------
 765    -- Physical_To_Logical --
 766    -------------------------
 767
 768    function Physical_To_Logical
 769      (Line : Physical_Line_Number;
 770       S    : Source_File_Index) return Logical_Line_Number
 771    is
 772       SFR : Source_File_Record renames Source_File.Table (S);
 773
 774    begin
 775       if SFR.Num_SRef_Pragmas = 0 then
 776          return Logical_Line_Number (Line);
 777       else
 778          return SFR.Logical_Lines_Table (Line);
 779       end if;
 780    end Physical_To_Logical;
 781
 782    --------------------------------
 783    -- Register_Source_Ref_Pragma --
 784    --------------------------------
 785
 786    procedure Register_Source_Ref_Pragma
 787      (File_Name          : File_Name_Type;
 788       Stripped_File_Name : File_Name_Type;
 789       Mapped_Line        : Nat;
 790       Line_After_Pragma  : Physical_Line_Number)
 791    is
 792       subtype size_t is Memory.size_t;
 793
 794       SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
 795
 796       ML : Logical_Line_Number;
 797
 798    begin
 799       if File_Name /= No_File then
 800          SFR.Reference_Name := Stripped_File_Name;
 801          SFR.Full_Ref_Name  := File_Name;
 802
 803          if not Debug_Generated_Code then
 804             SFR.Debug_Source_Name := Stripped_File_Name;
 805             SFR.Full_Debug_Name   := File_Name;
 806          end if;
 807
 808          SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
 809       end if;
 810
 811       if SFR.Num_SRef_Pragmas = 1 then
 812          SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
 813       end if;
 814
 815       if SFR.Logical_Lines_Table = null then
 816          SFR.Logical_Lines_Table := To_Pointer
 817            (Memory.Alloc
 818              (size_t (SFR.Lines_Table_Max *
 819                         Logical_Lines_Table_Type'Component_Size /
 820                                                         Storage_Unit)));
 821       end if;
 822
 823       SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
 824
 825       ML := Logical_Line_Number (Mapped_Line);
 826       for J in Line_After_Pragma .. SFR.Last_Source_Line loop
 827          SFR.Logical_Lines_Table (J) := ML;
 828          ML := ML + 1;
 829       end loop;
 830    end Register_Source_Ref_Pragma;
 831
 832    ---------------------------------
 833    -- Set_Source_File_Index_Table --
 834    ---------------------------------
 835
 836    procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
 837       Ind : Int;
 838       SP  : Source_Ptr;
 839       SL  : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
 840    begin
 841       SP  := Source_File.Table (Xnew).Source_First;
 842       pragma Assert (SP mod Source_Align = 0);
 843       Ind := Int (SP) / Source_Align;
 844       while SP <= SL loop
 845          Source_File_Index_Table (Ind) := Xnew;
 846          SP := SP + Source_Align;
 847          Ind := Ind + 1;
 848       end loop;
 849    end Set_Source_File_Index_Table;
 850
 851    ---------------------------
 852    -- Skip_Line_Terminators --
 853    ---------------------------
 854
 855    procedure Skip_Line_Terminators
 856      (P        : in out Source_Ptr;
 857       Physical : out Boolean)
 858    is
 859       Chr : constant Character := Source (P);
 860
 861    begin
 862       if Chr = CR then
 863          if Source (P + 1) = LF then
 864             P := P + 2;
 865          else
 866             P := P + 1;
 867          end if;
 868
 869       elsif Chr = LF then
 870          P := P + 1;
 871
 872       elsif Chr = FF or else Chr = VT then
 873          P := P + 1;
 874          Physical := False;
 875          return;
 876
 877          --  Otherwise we have a wide character
 878
 879       else
 880          Skip_Wide (Source, P);
 881       end if;
 882
 883       --  Fall through in the physical line terminator case. First deal with
 884       --  making a possible entry into the lines table if one is needed.
 885
 886       --  Note: we are dealing with a real source file here, this cannot be
 887       --  the instantiation case, so we need not worry about Sloc adjustment.
 888
 889       declare
 890          S : Source_File_Record
 891                renames Source_File.Table (Current_Source_File);
 892
 893       begin
 894          Physical := True;
 895
 896          --  Make entry in lines table if not already made (in some scan backup
 897          --  cases, we will be rescanning previously scanned source, so the
 898          --  entry may have already been made on the previous forward scan).
 899
 900          if Source (P) /= EOF
 901            and then P > S.Lines_Table (S.Last_Source_Line)
 902          then
 903             Add_Line_Tables_Entry (S, P);
 904          end if;
 905       end;
 906    end Skip_Line_Terminators;
 907
 908    --------------
 909    -- Set_Dope --
 910    --------------
 911
 912    procedure Set_Dope
 913      (Src : System.Address; New_Dope : Dope_Ptr)
 914    is
 915       --  A fat pointer is a pair consisting of data pointer and dope pointer,
 916       --  in that order. So we want to overwrite the second word.
 917       Dope : System.Address;
 918       pragma Import (Ada, Dope);
 919       use System.Storage_Elements;
 920       for Dope'Address use Src + System.Address'Size / 8;
 921    begin
 922       Dope := New_Dope.all'Address;
 923    end Set_Dope;
 924
 925    procedure Free_Dope (Src : System.Address) is
 926       Dope : Dope_Ptr;
 927       pragma Import (Ada, Dope);
 928       use System.Storage_Elements;
 929       for Dope'Address use Src + System.Address'Size / 8;
 930       procedure Free is new Unchecked_Deallocation (Dope_Rec, Dope_Ptr);
 931    begin
 932       Free (Dope);
 933    end Free_Dope;
 934
 935    ----------------
 936    -- Sloc_Range --
 937    ----------------
 938
 939    procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
 940
 941       function Process (N : Node_Id) return Traverse_Result;
 942       --  Process function for traversing the node tree
 943
 944       procedure Traverse is new Traverse_Proc (Process);
 945
 946       -------------
 947       -- Process --
 948       -------------
 949
 950       function Process (N : Node_Id) return Traverse_Result is
 951          Orig : constant Node_Id := Original_Node (N);
 952
 953       begin
 954          if Sloc (Orig) < Min then
 955             if Sloc (Orig) > No_Location then
 956                Min := Sloc (Orig);
 957             end if;
 958
 959          elsif Sloc (Orig) > Max then
 960             if Sloc (Orig) > No_Location then
 961                Max := Sloc (Orig);
 962             end if;
 963          end if;
 964
 965          return OK_Orig;
 966       end Process;
 967
 968    --  Start of processing for Sloc_Range
 969
 970    begin
 971       Min := Sloc (N);
 972       Max := Sloc (N);
 973       Traverse (N);
 974    end Sloc_Range;
 975
 976    -------------------
 977    -- Source_Offset --
 978    -------------------
 979
 980    function Source_Offset (S : Source_Ptr) return Nat is
 981       Sindex : constant Source_File_Index := Get_Source_File_Index (S);
 982       Sfirst : constant Source_Ptr :=
 983                  Source_File.Table (Sindex).Source_First;
 984    begin
 985       return Nat (S - Sfirst);
 986    end Source_Offset;
 987
 988    ------------------------
 989    -- Top_Level_Location --
 990    ------------------------
 991
 992    function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
 993       Oldloc : Source_Ptr;
 994       Newloc : Source_Ptr;
 995
 996    begin
 997       Newloc := S;
 998       loop
 999          Oldloc := Newloc;
1000          Newloc := Instantiation_Location (Oldloc);
1001          exit when Newloc = No_Location;
1002       end loop;
1003
1004       return Oldloc;
1005    end Top_Level_Location;
1006
1007    ---------------
1008    -- Tree_Read --
1009    ---------------
1010
1011    procedure Tree_Read is
1012    begin
1013       --  First we must free any old source buffer pointers
1014
1015       for J in Source_File.First .. Source_File.Last loop
1016          declare
1017             S : Source_File_Record renames Source_File.Table (J);
1018          begin
1019             if S.Instance = No_Instance_Id then
1020                Free_Source_Buffer (S.Source_Text);
1021
1022                if S.Lines_Table /= null then
1023                   Memory.Free (To_Address (S.Lines_Table));
1024                   S.Lines_Table := null;
1025                end if;
1026
1027                if S.Logical_Lines_Table /= null then
1028                   Memory.Free (To_Address (S.Logical_Lines_Table));
1029                   S.Logical_Lines_Table := null;
1030                end if;
1031
1032             else
1033                Free_Dope (S.Source_Text'Address);
1034                S.Source_Text := null;
1035             end if;
1036          end;
1037       end loop;
1038
1039       --  Read in source file table and instance table
1040
1041       Source_File.Tree_Read;
1042       Instances.Tree_Read;
1043
1044       --  The pointers we read in there for the source buffer and lines table
1045       --  pointers are junk. We now read in the actual data that is referenced
1046       --  by these two fields.
1047
1048       for J in Source_File.First .. Source_File.Last loop
1049          declare
1050             S : Source_File_Record renames Source_File.Table (J);
1051          begin
1052             --  Normal case (non-instantiation)
1053
1054             if S.Instance = No_Instance_Id then
1055                S.Lines_Table := null;
1056                S.Logical_Lines_Table := null;
1057                Alloc_Line_Tables (S, Int (S.Last_Source_Line));
1058
1059                for J in 1 .. S.Last_Source_Line loop
1060                   Tree_Read_Int (Int (S.Lines_Table (J)));
1061                end loop;
1062
1063                if S.Num_SRef_Pragmas /= 0 then
1064                   for J in 1 .. S.Last_Source_Line loop
1065                      Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
1066                   end loop;
1067                end if;
1068
1069                --  Allocate source buffer and read in the data
1070
1071                declare
1072                   T : constant Source_Buffer_Ptr_Var :=
1073                     new Source_Buffer (S.Source_First .. S.Source_Last);
1074                begin
1075                   Tree_Read_Data (T (S.Source_First)'Address,
1076                      Int (S.Source_Last) - Int (S.Source_First) + 1);
1077                   S.Source_Text := T.all'Access;
1078                end;
1079
1080             --  For the instantiation case, we do not read in any data. Instead
1081             --  we share the data for the generic template entry. Since the
1082             --  template always occurs first, we can safely refer to its data.
1083
1084             else
1085                declare
1086                   ST : Source_File_Record renames
1087                          Source_File.Table (S.Template);
1088
1089                begin
1090                   --  The lines tables are copied from the template entry
1091
1092                   S.Lines_Table := ST.Lines_Table;
1093                   S.Logical_Lines_Table := ST.Logical_Lines_Table;
1094
1095                   --  The Source_Text of the instance is the same data as that
1096                   --  of the template, but with different bounds.
1097
1098                   declare
1099                      Dope : constant Dope_Ptr :=
1100                        new Dope_Rec'(S.Source_First, S.Source_Last);
1101                   begin
1102                      S.Source_Text := ST.Source_Text;
1103                      Set_Dope (S.Source_Text'Address, Dope);
1104                   end;
1105                end;
1106             end if;
1107          end;
1108
1109          Set_Source_File_Index_Table (J);
1110       end loop;
1111    end Tree_Read;
1112
1113    ----------------
1114    -- Tree_Write --
1115    ----------------
1116
1117    procedure Tree_Write is
1118    begin
1119       Source_File.Tree_Write;
1120       Instances.Tree_Write;
1121
1122       --  The pointers we wrote out there for the source buffer and lines
1123       --  table pointers are junk, we now write out the actual data that
1124       --  is referenced by these two fields.
1125
1126       for J in Source_File.First .. Source_File.Last loop
1127          declare
1128             S : Source_File_Record renames Source_File.Table (J);
1129
1130          begin
1131             --  For instantiations, there is nothing to do, since the data is
1132             --  shared with the generic template. When the tree is read, the
1133             --  pointers must be set, but no extra data needs to be written.
1134             --  For the normal case, write out the data of the tables.
1135
1136             if S.Instance = No_Instance_Id then
1137                --  Lines table
1138
1139                for J in 1 .. S.Last_Source_Line loop
1140                   Tree_Write_Int (Int (S.Lines_Table (J)));
1141                end loop;
1142
1143                --  Logical lines table if present
1144
1145                if S.Num_SRef_Pragmas /= 0 then
1146                   for J in 1 .. S.Last_Source_Line loop
1147                      Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
1148                   end loop;
1149                end if;
1150
1151                --  Source buffer
1152
1153                Tree_Write_Data
1154                  (S.Source_Text (S.Source_First)'Address,
1155                    Int (S.Source_Last) - Int (S.Source_First) + 1);
1156             end if;
1157          end;
1158       end loop;
1159    end Tree_Write;
1160
1161    --------------------
1162    -- Write_Location --
1163    --------------------
1164
1165    procedure Write_Location (P : Source_Ptr) is
1166    begin
1167       if P = No_Location then
1168          Write_Str ("<no location>");
1169
1170       elsif P <= Standard_Location then
1171          Write_Str ("<standard location>");
1172
1173       else
1174          declare
1175             SI : constant Source_File_Index := Get_Source_File_Index (P);
1176
1177          begin
1178             Write_Name (Debug_Source_Name (SI));
1179             Write_Char (':');
1180             Write_Int (Int (Get_Logical_Line_Number (P)));
1181             Write_Char (':');
1182             Write_Int (Int (Get_Column_Number (P)));
1183
1184             if Instantiation (SI) /= No_Location then
1185                Write_Str (" [");
1186                Write_Location (Instantiation (SI));
1187                Write_Char (']');
1188             end if;
1189          end;
1190       end if;
1191    end Write_Location;
1192
1193    ----------------------
1194    -- Write_Time_Stamp --
1195    ----------------------
1196
1197    procedure Write_Time_Stamp (S : Source_File_Index) is
1198       T : constant Time_Stamp_Type := Time_Stamp (S);
1199       P : Natural;
1200
1201    begin
1202       if T (1) = '9' then
1203          Write_Str ("19");
1204          P := 0;
1205       else
1206          Write_Char (T (1));
1207          Write_Char (T (2));
1208          P := 2;
1209       end if;
1210
1211       Write_Char (T (P + 1));
1212       Write_Char (T (P + 2));
1213       Write_Char ('-');
1214
1215       Write_Char (T (P + 3));
1216       Write_Char (T (P + 4));
1217       Write_Char ('-');
1218
1219       Write_Char (T (P + 5));
1220       Write_Char (T (P + 6));
1221       Write_Char (' ');
1222
1223       Write_Char (T (P + 7));
1224       Write_Char (T (P + 8));
1225       Write_Char (':');
1226
1227       Write_Char (T (P + 9));
1228       Write_Char (T (P + 10));
1229       Write_Char (':');
1230
1231       Write_Char (T (P + 11));
1232       Write_Char (T (P + 12));
1233    end Write_Time_Stamp;
1234
1235    ----------------------------------------------
1236    -- Access Subprograms for Source File Table --
1237    ----------------------------------------------
1238
1239    function Debug_Source_Name (S : SFI) return File_Name_Type is
1240    begin
1241       return Source_File.Table (S).Debug_Source_Name;
1242    end Debug_Source_Name;
1243
1244    function Instance (S : SFI) return Instance_Id is
1245    begin
1246       return Source_File.Table (S).Instance;
1247    end Instance;
1248
1249    function File_Name (S : SFI) return File_Name_Type is
1250    begin
1251       return Source_File.Table (S).File_Name;
1252    end File_Name;
1253
1254    function File_Type (S : SFI) return Type_Of_File is
1255    begin
1256       return Source_File.Table (S).File_Type;
1257    end File_Type;
1258
1259    function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1260    begin
1261       return Source_File.Table (S).First_Mapped_Line;
1262    end First_Mapped_Line;
1263
1264    function Full_Debug_Name (S : SFI) return File_Name_Type is
1265    begin
1266       return Source_File.Table (S).Full_Debug_Name;
1267    end Full_Debug_Name;
1268
1269    function Full_File_Name (S : SFI) return File_Name_Type is
1270    begin
1271       return Source_File.Table (S).Full_File_Name;
1272    end Full_File_Name;
1273
1274    function Full_Ref_Name (S : SFI) return File_Name_Type is
1275    begin
1276       return Source_File.Table (S).Full_Ref_Name;
1277    end Full_Ref_Name;
1278
1279    function Identifier_Casing (S : SFI) return Casing_Type is
1280    begin
1281       return Source_File.Table (S).Identifier_Casing;
1282    end Identifier_Casing;
1283
1284    function Inherited_Pragma (S : SFI) return Boolean is
1285    begin
1286       return Source_File.Table (S).Inherited_Pragma;
1287    end Inherited_Pragma;
1288
1289    function Inlined_Body (S : SFI) return Boolean is
1290    begin
1291       return Source_File.Table (S).Inlined_Body;
1292    end Inlined_Body;
1293
1294    function Inlined_Call (S : SFI) return Source_Ptr is
1295    begin
1296       return Source_File.Table (S).Inlined_Call;
1297    end Inlined_Call;
1298
1299    function Keyword_Casing (S : SFI) return Casing_Type is
1300    begin
1301       return Source_File.Table (S).Keyword_Casing;
1302    end Keyword_Casing;
1303
1304    function Last_Source_Line (S : SFI) return Physical_Line_Number is
1305    begin
1306       return Source_File.Table (S).Last_Source_Line;
1307    end Last_Source_Line;
1308
1309    function License (S : SFI) return License_Type is
1310    begin
1311       return Source_File.Table (S).License;
1312    end License;
1313
1314    function Num_SRef_Pragmas (S : SFI) return Nat is
1315    begin
1316       return Source_File.Table (S).Num_SRef_Pragmas;
1317    end Num_SRef_Pragmas;
1318
1319    function Reference_Name (S : SFI) return File_Name_Type is
1320    begin
1321       return Source_File.Table (S).Reference_Name;
1322    end Reference_Name;
1323
1324    function Source_Checksum (S : SFI) return Word is
1325    begin
1326       return Source_File.Table (S).Source_Checksum;
1327    end Source_Checksum;
1328
1329    function Source_First (S : SFI) return Source_Ptr is
1330    begin
1331       return Source_File.Table (S).Source_First;
1332    end Source_First;
1333
1334    function Source_Last (S : SFI) return Source_Ptr is
1335    begin
1336       return Source_File.Table (S).Source_Last;
1337    end Source_Last;
1338
1339    function Source_Text (S : SFI) return Source_Buffer_Ptr is
1340    begin
1341       return Source_File.Table (S).Source_Text;
1342    end Source_Text;
1343
1344    function Template (S : SFI) return SFI is
1345    begin
1346       return Source_File.Table (S).Template;
1347    end Template;
1348
1349    function Time_Stamp (S : SFI) return Time_Stamp_Type is
1350    begin
1351       return Source_File.Table (S).Time_Stamp;
1352    end Time_Stamp;
1353
1354    function Unit (S : SFI) return Unit_Number_Type is
1355    begin
1356       return Source_File.Table (S).Unit;
1357    end Unit;
1358
1359    ------------------------------------------
1360    -- Set Procedures for Source File Table --
1361    ------------------------------------------
1362
1363    procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1364    begin
1365       Source_File.Table (S).Identifier_Casing := C;
1366    end Set_Identifier_Casing;
1367
1368    procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1369    begin
1370       Source_File.Table (S).Keyword_Casing := C;
1371    end Set_Keyword_Casing;
1372
1373    procedure Set_License (S : SFI; L : License_Type) is
1374    begin
1375       Source_File.Table (S).License := L;
1376    end Set_License;
1377
1378    procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1379    begin
1380       Source_File.Table (S).Unit := U;
1381    end Set_Unit;
1382
1383    ----------------------
1384    -- Trim_Lines_Table --
1385    ----------------------
1386
1387    procedure Trim_Lines_Table (S : Source_File_Index) is
1388       Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1389
1390    begin
1391       --  Release allocated storage that is no longer needed
1392
1393       Source_File.Table (S).Lines_Table := To_Pointer
1394         (Memory.Realloc
1395           (To_Address (Source_File.Table (S).Lines_Table),
1396            Memory.size_t
1397             (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1398       Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1399    end Trim_Lines_Table;
1400
1401    ------------
1402    -- Unlock --
1403    ------------
1404
1405    procedure Unlock is
1406    begin
1407       Source_File.Locked := False;
1408       Source_File.Release;
1409    end Unlock;
1410
1411    --------
1412    -- wl --
1413    --------
1414
1415    procedure wl (P : Source_Ptr) is
1416    begin
1417       Write_Location (P);
1418       Write_Eol;
1419    end wl;
1420
1421 end Sinput;