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