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