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