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