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