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