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