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_Physical_Line_Number --
 465    ------------------------------
 466
 467    function Get_Physical_Line_Number
 468      (P : Source_Ptr) return Physical_Line_Number
 469    is
 470       Sfile : Source_File_Index;
 471       Table : Lines_Table_Ptr;
 472       Lo    : Physical_Line_Number;
 473       Hi    : Physical_Line_Number;
 474       Mid   : Physical_Line_Number;
 475       Loc   : Source_Ptr;
 476
 477    begin
 478       --  If the input source pointer is not a meaningful value then return
 479       --  at once with line number 1. This can happen for a file not found
 480       --  condition for a file loaded indirectly by RTE, and also perhaps on
 481       --  some unknown internal error conditions. In either case we certainly
 482       --  don't want to blow up.
 483
 484       if P < 1 then
 485          return 1;
 486
 487       --  Otherwise we can do the binary search
 488
 489       else
 490          Sfile := Get_Source_File_Index (P);
 491          Loc   := P + Source_File.Table (Sfile).Sloc_Adjust;
 492          Table := Source_File.Table (Sfile).Lines_Table;
 493          Lo    := 1;
 494          Hi    := Source_File.Table (Sfile).Last_Source_Line;
 495
 496          loop
 497             Mid := (Lo + Hi) / 2;
 498
 499             if Loc < Table (Mid) then
 500                Hi := Mid - 1;
 501
 502             else -- Loc >= Table (Mid)
 503
 504                if Mid = Hi or else
 505                   Loc < Table (Mid + 1)
 506                then
 507                   return Mid;
 508                else
 509                   Lo := Mid + 1;
 510                end if;
 511
 512             end if;
 513
 514          end loop;
 515       end if;
 516    end Get_Physical_Line_Number;
 517
 518    ---------------------------
 519    -- Get_Source_File_Index --
 520    ---------------------------
 521
 522    function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
 523       Result : Source_File_Index;
 524
 525       procedure Assertions;
 526       --  Assert various properties of the result
 527
 528       procedure Assertions is
 529
 530          --  ???The old version using zero-origin array indexing without array
 531          --  bounds checks returned 1 (i.e. system.ads) for these special
 532          --  locations, presumably by accident. We are mimicing that here.
 533
 534          Special : constant Boolean :=
 535                      S = No_Location
 536                        or else S = Standard_Location
 537                        or else S = Standard_ASCII_Location
 538                        or else S = System_Location;
 539
 540          pragma Assert (S > No_Location xor Special);
 541          pragma Assert (Result in Source_File.First .. Source_File.Last);
 542
 543          SFR : Source_File_Record renames Source_File.Table (Result);
 544
 545       begin
 546          --  SFR.Source_Text = null if and only if this is the SFR for a debug
 547          --  output file (*.dg), and that file is under construction. S can be
 548          --  slightly past Source_Last in that case because we haven't updated
 549          --  Source_Last.
 550
 551          if Null_Source_Buffer_Ptr (SFR.Source_Text) then
 552             pragma Assert (S >= SFR.Source_First); null;
 553          else
 554             pragma Assert (SFR.Source_Text'First = SFR.Source_First);
 555             pragma Assert (SFR.Source_Text'Last = SFR.Source_Last);
 556
 557             if not Special then
 558                pragma Assert (S in SFR.Source_First .. SFR.Source_Last);
 559                null;
 560             end if;
 561          end if;
 562       end Assertions;
 563
 564    --  Start of processing for Get_Source_File_Index
 565
 566    begin
 567       if S > No_Location then
 568          Result := Source_File_Index_Table (Int (S) / Source_Align);
 569       else
 570          Result := 1;
 571       end if;
 572
 573       pragma Debug (Assertions);
 574
 575       return Result;
 576    end Get_Source_File_Index;
 577
 578    ----------------
 579    -- Initialize --
 580    ----------------
 581
 582    procedure Initialize is
 583    begin
 584       Source_gnat_adc := No_Source_File;
 585       Source_File.Init;
 586       Instances.Init;
 587       Instances.Append (No_Location);
 588       pragma Assert (Instances.Last = No_Instance_Id);
 589    end Initialize;
 590
 591    -------------------
 592    -- Instantiation --
 593    -------------------
 594
 595    function Instantiation (S : SFI) return Source_Ptr is
 596       SIE : Source_File_Record renames Source_File.Table (S);
 597    begin
 598       if SIE.Inlined_Body or SIE.Inherited_Pragma then
 599          return SIE.Inlined_Call;
 600       else
 601          return Instances.Table (SIE.Instance);
 602       end if;
 603    end Instantiation;
 604
 605    -------------------------
 606    -- Instantiation_Depth --
 607    -------------------------
 608
 609    function Instantiation_Depth (S : Source_Ptr) return Nat is
 610       Sval  : Source_Ptr;
 611       Depth : Nat;
 612
 613    begin
 614       Sval := S;
 615       Depth := 0;
 616
 617       loop
 618          Sval := Instantiation_Location (Sval);
 619          exit when Sval = No_Location;
 620          Depth := Depth + 1;
 621       end loop;
 622
 623       return Depth;
 624    end Instantiation_Depth;
 625
 626    ----------------------------
 627    -- Instantiation_Location --
 628    ----------------------------
 629
 630    function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
 631    begin
 632       return Instantiation (Get_Source_File_Index (S));
 633    end Instantiation_Location;
 634
 635    --------------------------
 636    -- Iterate_On_Instances --
 637    --------------------------
 638
 639    procedure Iterate_On_Instances is
 640    begin
 641       for J in 1 .. Instances.Last loop
 642          Process (J, Instances.Table (J));
 643       end loop;
 644    end Iterate_On_Instances;
 645
 646    ----------------------
 647    -- Last_Source_File --
 648    ----------------------
 649
 650    function Last_Source_File return Source_File_Index is
 651    begin
 652       return Source_File.Last;
 653    end Last_Source_File;
 654
 655    ----------------
 656    -- Line_Start --
 657    ----------------
 658
 659    function Line_Start (P : Source_Ptr) return Source_Ptr is
 660       Sindex : constant Source_File_Index := Get_Source_File_Index (P);
 661       Src    : constant Source_Buffer_Ptr :=
 662                  Source_File.Table (Sindex).Source_Text;
 663       Sfirst : constant Source_Ptr :=
 664                  Source_File.Table (Sindex).Source_First;
 665       S      : Source_Ptr;
 666
 667    begin
 668       S := P;
 669       while S > Sfirst
 670         and then Src (S - 1) /= CR
 671         and then Src (S - 1) /= LF
 672       loop
 673          S := S - 1;
 674       end loop;
 675
 676       return S;
 677    end Line_Start;
 678
 679    function Line_Start
 680      (L : Physical_Line_Number;
 681       S : Source_File_Index) return Source_Ptr
 682    is
 683    begin
 684       return Source_File.Table (S).Lines_Table (L);
 685    end Line_Start;
 686
 687    ----------
 688    -- Lock --
 689    ----------
 690
 691    procedure Lock is
 692    begin
 693       Source_File.Release;
 694       Source_File.Locked := True;
 695    end Lock;
 696
 697    ----------------------
 698    -- Num_Source_Files --
 699    ----------------------
 700
 701    function Num_Source_Files return Nat is
 702    begin
 703       return Int (Source_File.Last) - Int (Source_File.First) + 1;
 704    end Num_Source_Files;
 705
 706    ----------------------
 707    -- Num_Source_Lines --
 708    ----------------------
 709
 710    function Num_Source_Lines (S : Source_File_Index) return Nat is
 711    begin
 712       return Nat (Source_File.Table (S).Last_Source_Line);
 713    end Num_Source_Lines;
 714
 715    -----------------------
 716    -- Original_Location --
 717    -----------------------
 718
 719    function Original_Location (S : Source_Ptr) return Source_Ptr is
 720       Sindex : Source_File_Index;
 721       Tindex : Source_File_Index;
 722
 723    begin
 724       if S <= No_Location then
 725          return S;
 726
 727       else
 728          Sindex := Get_Source_File_Index (S);
 729
 730          if Instantiation (Sindex) = No_Location then
 731             return S;
 732
 733          else
 734             Tindex := Template (Sindex);
 735             while Instantiation (Tindex) /= No_Location loop
 736                Tindex := Template (Tindex);
 737             end loop;
 738
 739             return S - Source_First (Sindex) + Source_First (Tindex);
 740          end if;
 741       end if;
 742    end Original_Location;
 743
 744    -------------------------
 745    -- Physical_To_Logical --
 746    -------------------------
 747
 748    function Physical_To_Logical
 749      (Line : Physical_Line_Number;
 750       S    : Source_File_Index) return Logical_Line_Number
 751    is
 752       SFR : Source_File_Record renames Source_File.Table (S);
 753
 754    begin
 755       if SFR.Num_SRef_Pragmas = 0 then
 756          return Logical_Line_Number (Line);
 757       else
 758          return SFR.Logical_Lines_Table (Line);
 759       end if;
 760    end Physical_To_Logical;
 761
 762    --------------------------------
 763    -- Register_Source_Ref_Pragma --
 764    --------------------------------
 765
 766    procedure Register_Source_Ref_Pragma
 767      (File_Name          : File_Name_Type;
 768       Stripped_File_Name : File_Name_Type;
 769       Mapped_Line        : Nat;
 770       Line_After_Pragma  : Physical_Line_Number)
 771    is
 772       subtype size_t is Memory.size_t;
 773
 774       SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
 775
 776       ML : Logical_Line_Number;
 777
 778    begin
 779       if File_Name /= No_File then
 780          SFR.Reference_Name := Stripped_File_Name;
 781          SFR.Full_Ref_Name  := File_Name;
 782
 783          if not Debug_Generated_Code then
 784             SFR.Debug_Source_Name := Stripped_File_Name;
 785             SFR.Full_Debug_Name   := File_Name;
 786          end if;
 787
 788          SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
 789       end if;
 790
 791       if SFR.Num_SRef_Pragmas = 1 then
 792          SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
 793       end if;
 794
 795       if SFR.Logical_Lines_Table = null then
 796          SFR.Logical_Lines_Table := To_Pointer
 797            (Memory.Alloc
 798              (size_t (SFR.Lines_Table_Max *
 799                         Logical_Lines_Table_Type'Component_Size /
 800                                                         Storage_Unit)));
 801       end if;
 802
 803       SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
 804
 805       ML := Logical_Line_Number (Mapped_Line);
 806       for J in Line_After_Pragma .. SFR.Last_Source_Line loop
 807          SFR.Logical_Lines_Table (J) := ML;
 808          ML := ML + 1;
 809       end loop;
 810    end Register_Source_Ref_Pragma;
 811
 812    ---------------------------------
 813    -- Set_Source_File_Index_Table --
 814    ---------------------------------
 815
 816    procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
 817       Ind : Int;
 818       SP  : Source_Ptr;
 819       SL  : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
 820    begin
 821       SP  := Source_File.Table (Xnew).Source_First;
 822       pragma Assert (SP mod Source_Align = 0);
 823       Ind := Int (SP) / Source_Align;
 824       while SP <= SL loop
 825          Source_File_Index_Table (Ind) := Xnew;
 826          SP := SP + Source_Align;
 827          Ind := Ind + 1;
 828       end loop;
 829    end Set_Source_File_Index_Table;
 830
 831    ---------------------------
 832    -- Skip_Line_Terminators --
 833    ---------------------------
 834
 835    procedure Skip_Line_Terminators
 836      (P        : in out Source_Ptr;
 837       Physical : out Boolean)
 838    is
 839       Chr : constant Character := Source (P);
 840
 841    begin
 842       if Chr = CR then
 843          if Source (P + 1) = LF then
 844             P := P + 2;
 845          else
 846             P := P + 1;
 847          end if;
 848
 849       elsif Chr = LF then
 850          P := P + 1;
 851
 852       elsif Chr = FF or else Chr = VT then
 853          P := P + 1;
 854          Physical := False;
 855          return;
 856
 857          --  Otherwise we have a wide character
 858
 859       else
 860          Skip_Wide (Source, P);
 861       end if;
 862
 863       --  Fall through in the physical line terminator case. First deal with
 864       --  making a possible entry into the lines table if one is needed.
 865
 866       --  Note: we are dealing with a real source file here, this cannot be
 867       --  the instantiation case, so we need not worry about Sloc adjustment.
 868
 869       declare
 870          S : Source_File_Record
 871                renames Source_File.Table (Current_Source_File);
 872
 873       begin
 874          Physical := True;
 875
 876          --  Make entry in lines table if not already made (in some scan backup
 877          --  cases, we will be rescanning previously scanned source, so the
 878          --  entry may have already been made on the previous forward scan).
 879
 880          if Source (P) /= EOF
 881            and then P > S.Lines_Table (S.Last_Source_Line)
 882          then
 883             Add_Line_Tables_Entry (S, P);
 884          end if;
 885       end;
 886    end Skip_Line_Terminators;
 887
 888    --------------
 889    -- Set_Dope --
 890    --------------
 891
 892    procedure Set_Dope
 893      (Src : System.Address; New_Dope : Dope_Ptr)
 894    is
 895       --  A fat pointer is a pair consisting of data pointer and dope pointer,
 896       --  in that order. So we want to overwrite the second word.
 897       Dope : System.Address;
 898       pragma Import (Ada, Dope);
 899       use System.Storage_Elements;
 900       for Dope'Address use Src + System.Address'Size / 8;
 901    begin
 902       Dope := New_Dope.all'Address;
 903    end Set_Dope;
 904
 905    procedure Free_Dope (Src : System.Address) is
 906       Dope : Dope_Ptr;
 907       pragma Import (Ada, Dope);
 908       use System.Storage_Elements;
 909       for Dope'Address use Src + System.Address'Size / 8;
 910       procedure Free is new Ada.Unchecked_Deallocation (Dope_Rec, Dope_Ptr);
 911    begin
 912       Free (Dope);
 913    end Free_Dope;
 914
 915    ----------------
 916    -- Sloc_Range --
 917    ----------------
 918
 919    procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
 920
 921       Indx : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
 922
 923       function Process (N : Node_Id) return Traverse_Result;
 924       --  Process function for traversing the node tree
 925
 926       procedure Traverse is new Traverse_Proc (Process);
 927
 928       -------------
 929       -- Process --
 930       -------------
 931
 932       function Process (N : Node_Id) return Traverse_Result is
 933          Loc : constant Source_Ptr := Sloc (Original_Node (N));
 934
 935       begin
 936          --  Skip nodes that may have been added during expansion and
 937          --  that originate in other units, such as code for contracts
 938          --  in subprogram bodies.
 939
 940          if Get_Source_File_Index (Loc) /= Indx then
 941             return Skip;
 942          end if;
 943
 944          if Loc > No_Location then
 945             if Loc < Min then
 946                Min := Loc;
 947             elsif Loc > Max then
 948                Max := Loc;
 949             end if;
 950          end if;
 951
 952          return OK_Orig;
 953       end Process;
 954
 955    --  Start of processing for Sloc_Range
 956
 957    begin
 958       Min := Sloc (N);
 959       Max := Min;
 960       Traverse (N);
 961    end Sloc_Range;
 962
 963    -------------------
 964    -- Source_Offset --
 965    -------------------
 966
 967    function Source_Offset (S : Source_Ptr) return Nat is
 968       Sindex : constant Source_File_Index := Get_Source_File_Index (S);
 969       Sfirst : constant Source_Ptr :=
 970                  Source_File.Table (Sindex).Source_First;
 971    begin
 972       return Nat (S - Sfirst);
 973    end Source_Offset;
 974
 975    ------------------------
 976    -- Top_Level_Location --
 977    ------------------------
 978
 979    function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
 980       Oldloc : Source_Ptr;
 981       Newloc : Source_Ptr;
 982
 983    begin
 984       Newloc := S;
 985       loop
 986          Oldloc := Newloc;
 987          Newloc := Instantiation_Location (Oldloc);
 988          exit when Newloc = No_Location;
 989       end loop;
 990
 991       return Oldloc;
 992    end Top_Level_Location;
 993
 994    --------------------
 995    -- Write_Location --
 996    --------------------
 997
 998    procedure Write_Location (P : Source_Ptr) is
 999    begin
1000       if P = No_Location then
1001          Write_Str ("<no location>");
1002
1003       elsif P <= Standard_Location then
1004          Write_Str ("<standard location>");
1005
1006       else
1007          declare
1008             SI : constant Source_File_Index := Get_Source_File_Index (P);
1009
1010          begin
1011             Write_Name_For_Debug (Debug_Source_Name (SI));
1012             Write_Char (':');
1013             Write_Int (Int (Get_Logical_Line_Number (P)));
1014             Write_Char (':');
1015             Write_Int (Int (Get_Column_Number (P)));
1016
1017             if Instantiation (SI) /= No_Location then
1018                Write_Str (" [");
1019                Write_Location (Instantiation (SI));
1020                Write_Char (']');
1021             end if;
1022          end;
1023       end if;
1024    end Write_Location;
1025
1026    ----------------------
1027    -- Write_Time_Stamp --
1028    ----------------------
1029
1030    procedure Write_Time_Stamp (S : Source_File_Index) is
1031       T : constant Time_Stamp_Type := Time_Stamp (S);
1032       P : Natural;
1033
1034    begin
1035       if T (1) = '9' then
1036          Write_Str ("19");
1037          P := 0;
1038       else
1039          Write_Char (T (1));
1040          Write_Char (T (2));
1041          P := 2;
1042       end if;
1043
1044       Write_Char (T (P + 1));
1045       Write_Char (T (P + 2));
1046       Write_Char ('-');
1047
1048       Write_Char (T (P + 3));
1049       Write_Char (T (P + 4));
1050       Write_Char ('-');
1051
1052       Write_Char (T (P + 5));
1053       Write_Char (T (P + 6));
1054       Write_Char (' ');
1055
1056       Write_Char (T (P + 7));
1057       Write_Char (T (P + 8));
1058       Write_Char (':');
1059
1060       Write_Char (T (P + 9));
1061       Write_Char (T (P + 10));
1062       Write_Char (':');
1063
1064       Write_Char (T (P + 11));
1065       Write_Char (T (P + 12));
1066    end Write_Time_Stamp;
1067
1068    ----------------------------------------------
1069    -- Access Subprograms for Source File Table --
1070    ----------------------------------------------
1071
1072    function Debug_Source_Name (S : SFI) return File_Name_Type is
1073    begin
1074       return Source_File.Table (S).Debug_Source_Name;
1075    end Debug_Source_Name;
1076
1077    function Instance (S : SFI) return Instance_Id is
1078    begin
1079       return Source_File.Table (S).Instance;
1080    end Instance;
1081
1082    function File_Name (S : SFI) return File_Name_Type is
1083    begin
1084       return Source_File.Table (S).File_Name;
1085    end File_Name;
1086
1087    function File_Type (S : SFI) return Type_Of_File is
1088    begin
1089       return Source_File.Table (S).File_Type;
1090    end File_Type;
1091
1092    function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1093    begin
1094       return Source_File.Table (S).First_Mapped_Line;
1095    end First_Mapped_Line;
1096
1097    function Full_Debug_Name (S : SFI) return File_Name_Type is
1098    begin
1099       return Source_File.Table (S).Full_Debug_Name;
1100    end Full_Debug_Name;
1101
1102    function Full_File_Name (S : SFI) return File_Name_Type is
1103    begin
1104       return Source_File.Table (S).Full_File_Name;
1105    end Full_File_Name;
1106
1107    function Full_Ref_Name (S : SFI) return File_Name_Type is
1108    begin
1109       return Source_File.Table (S).Full_Ref_Name;
1110    end Full_Ref_Name;
1111
1112    function Identifier_Casing (S : SFI) return Casing_Type is
1113    begin
1114       return Source_File.Table (S).Identifier_Casing;
1115    end Identifier_Casing;
1116
1117    function Inherited_Pragma (S : SFI) return Boolean is
1118    begin
1119       return Source_File.Table (S).Inherited_Pragma;
1120    end Inherited_Pragma;
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 Inlined_Call (S : SFI) return Source_Ptr is
1128    begin
1129       return Source_File.Table (S).Inlined_Call;
1130    end Inlined_Call;
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       return Source_File.Table (S).Source_First;
1165    end Source_First;
1166
1167    function Source_Last (S : SFI) return Source_Ptr is
1168    begin
1169       return Source_File.Table (S).Source_Last;
1170    end Source_Last;
1171
1172    function Source_Text (S : SFI) return Source_Buffer_Ptr is
1173    begin
1174       return Source_File.Table (S).Source_Text;
1175    end Source_Text;
1176
1177    function Template (S : SFI) return SFI is
1178    begin
1179       return Source_File.Table (S).Template;
1180    end Template;
1181
1182    function Time_Stamp (S : SFI) return Time_Stamp_Type is
1183    begin
1184       return Source_File.Table (S).Time_Stamp;
1185    end Time_Stamp;
1186
1187    function Unit (S : SFI) return Unit_Number_Type is
1188    begin
1189       return Source_File.Table (S).Unit;
1190    end Unit;
1191
1192    ------------------------------------------
1193    -- Set Procedures for Source File Table --
1194    ------------------------------------------
1195
1196    procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1197    begin
1198       Source_File.Table (S).Identifier_Casing := C;
1199    end Set_Identifier_Casing;
1200
1201    procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1202    begin
1203       Source_File.Table (S).Keyword_Casing := C;
1204    end Set_Keyword_Casing;
1205
1206    procedure Set_License (S : SFI; L : License_Type) is
1207    begin
1208       Source_File.Table (S).License := L;
1209    end Set_License;
1210
1211    procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1212    begin
1213       Source_File.Table (S).Unit := U;
1214    end Set_Unit;
1215
1216    ----------------------
1217    -- Trim_Lines_Table --
1218    ----------------------
1219
1220    procedure Trim_Lines_Table (S : Source_File_Index) is
1221       Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1222
1223    begin
1224       --  Release allocated storage that is no longer needed
1225
1226       Source_File.Table (S).Lines_Table := To_Pointer
1227         (Memory.Realloc
1228           (To_Address (Source_File.Table (S).Lines_Table),
1229            Memory.size_t
1230             (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1231       Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1232    end Trim_Lines_Table;
1233
1234    ------------
1235    -- Unlock --
1236    ------------
1237
1238    procedure Unlock is
1239    begin
1240       Source_File.Locked := False;
1241       Source_File.Release;
1242    end Unlock;
1243
1244    --------
1245    -- wl --
1246    --------
1247
1248    procedure wl (P : Source_Ptr) is
1249    begin
1250       Write_Location (P);
1251       Write_Eol;
1252    end wl;
1253
1254 end Sinput;