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