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