New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45959 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 1132 insertions, 0 deletions

diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb
new file mode 100644
index 00000000000..b8612882550
--- /dev/null
+++ b/gcc/ada/sinput.adb
@@ -0,0 +1,1132 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               S I N P U T                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.99 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Subprograms not all in alpha order
+
+with Debug;   use Debug;
+with Namet;   use Namet;
+with Opt;     use Opt;
+with Output;  use Output;
+with Tree_IO; use Tree_IO;
+with System;  use System;
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body Sinput is
+
+   use ASCII;
+   --  Make control characters visible
+
+   First_Time_Around : Boolean := True;
+
+   ---------------------------
+   -- Add_Line_Tables_Entry --
+   ---------------------------
+
+   procedure Add_Line_Tables_Entry
+     (S : in out Source_File_Record;
+      P : Source_Ptr)
+   is
+      LL : Physical_Line_Number;
+
+   begin
+      --  Reallocate the lines tables if necessary.
+
+      --  Note: the reason we do not use the normal Table package
+      --  mechanism is that we have several of these tables. We could
+      --  use the new GNAT.Dynamic_Tables package and that would probably
+      --  be a good idea ???
+
+      if S.Last_Source_Line = S.Lines_Table_Max then
+         Alloc_Line_Tables
+           (S,
+            Int (S.Last_Source_Line) *
+              ((100 + Alloc.Lines_Increment) / 100));
+
+         if Debug_Flag_D then
+            Write_Str ("--> Reallocating lines table, size = ");
+            Write_Int (Int (S.Lines_Table_Max));
+            Write_Eol;
+         end if;
+      end if;
+
+      S.Last_Source_Line := S.Last_Source_Line + 1;
+      LL := S.Last_Source_Line;
+
+      S.Lines_Table (LL) := P;
+
+      --  Deal with setting new entry in logical lines table if one is
+      --  present. Note that there is always space (because the call to
+      --  Alloc_Line_Tables makes sure both tables are the same length),
+
+      if S.Logical_Lines_Table /= null then
+
+         --  We can always set the entry from the previous one, because
+         --  the processing for a Source_Reference pragma ensures that
+         --  at least one entry following the pragma is set up correctly.
+
+         S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
+      end if;
+   end Add_Line_Tables_Entry;
+
+   -----------------------
+   -- Alloc_Line_Tables --
+   -----------------------
+
+   procedure Alloc_Line_Tables
+     (S       : in out Source_File_Record;
+      New_Max : Nat)
+   is
+      function realloc
+        (memblock : Lines_Table_Ptr;
+         size     : size_t)
+         return     Lines_Table_Ptr;
+      pragma Import (C, realloc, "realloc");
+
+      function reallocl
+        (memblock : Logical_Lines_Table_Ptr;
+         size     : size_t)
+         return     Logical_Lines_Table_Ptr;
+      pragma Import (C, reallocl, "realloc");
+
+      function malloc
+        (size   : size_t)
+         return Lines_Table_Ptr;
+      pragma Import (C, malloc, "malloc");
+
+      function mallocl
+        (size   : size_t)
+         return Logical_Lines_Table_Ptr;
+      pragma Import (C, mallocl, "malloc");
+
+      New_Table : Lines_Table_Ptr;
+
+      New_Logical_Table : Logical_Lines_Table_Ptr;
+
+      New_Size : constant size_t :=
+                   size_t (New_Max * Lines_Table_Type'Component_Size /
+                                                             Storage_Unit);
+
+   begin
+      if S.Lines_Table = null then
+         New_Table := malloc (New_Size);
+
+      else
+         New_Table :=
+           realloc (memblock => S.Lines_Table, size => New_Size);
+      end if;
+
+      if New_Table = null then
+         raise Storage_Error;
+      else
+         S.Lines_Table     := New_Table;
+         S.Lines_Table_Max := Physical_Line_Number (New_Max);
+      end if;
+
+      if S.Num_SRef_Pragmas /= 0 then
+         if S.Logical_Lines_Table = null then
+            New_Logical_Table := mallocl (New_Size);
+         else
+            New_Logical_Table :=
+              reallocl (memblock => S.Logical_Lines_Table, size => New_Size);
+         end if;
+
+         if New_Logical_Table = null then
+            raise Storage_Error;
+         else
+            S.Logical_Lines_Table := New_Logical_Table;
+         end if;
+      end if;
+   end Alloc_Line_Tables;
+
+   -----------------
+   -- Backup_Line --
+   -----------------
+
+   procedure Backup_Line (P : in out Source_Ptr) is
+      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
+      Src    : constant Source_Buffer_Ptr :=
+                 Source_File.Table (Sindex).Source_Text;
+      Sfirst : constant Source_Ptr :=
+                 Source_File.Table (Sindex).Source_First;
+
+   begin
+      P := P - 1;
+
+      if P = Sfirst then
+         return;
+      end if;
+
+      if Src (P) = CR then
+         if Src (P - 1) = LF then
+            P := P - 1;
+         end if;
+
+      else -- Src (P) = LF
+         if Src (P - 1) = CR then
+            P := P - 1;
+         end if;
+      end if;
+
+      --  Now find first character of the previous line
+
+      while P > Sfirst
+        and then Src (P - 1) /= LF
+        and then Src (P - 1) /= CR
+      loop
+         P := P - 1;
+      end loop;
+   end Backup_Line;
+
+   ---------------------------
+   -- Build_Location_String --
+   ---------------------------
+
+   procedure Build_Location_String (Loc : Source_Ptr) is
+      Ptr : Source_Ptr;
+
+   begin
+      Name_Len := 0;
+
+      --  Loop through instantiations
+
+      Ptr := Loc;
+      loop
+         Get_Name_String_And_Append
+           (Reference_Name (Get_Source_File_Index (Ptr)));
+         Add_Char_To_Name_Buffer (':');
+         Add_Nat_To_Name_Buffer
+           (Nat (Get_Logical_Line_Number (Ptr)));
+
+         Ptr := Instantiation_Location (Ptr);
+         exit when Ptr = No_Location;
+         Add_Str_To_Name_Buffer (" instantiated at ");
+      end loop;
+
+      Name_Buffer (Name_Len + 1) := NUL;
+      return;
+   end Build_Location_String;
+
+   -----------------------
+   -- Get_Column_Number --
+   -----------------------
+
+   function Get_Column_Number (P : Source_Ptr) return Column_Number is
+      S      : Source_Ptr;
+      C      : Column_Number;
+      Sindex : Source_File_Index;
+      Src    : Source_Buffer_Ptr;
+
+   begin
+      --  If the input source pointer is not a meaningful value then return
+      --  at once with column number 1. This can happen for a file not found
+      --  condition for a file loaded indirectly by RTE, and also perhaps on
+      --  some unknown internal error conditions. In either case we certainly
+      --  don't want to blow up.
+
+      if P < 1 then
+         return 1;
+
+      else
+         Sindex := Get_Source_File_Index (P);
+         Src := Source_File.Table (Sindex).Source_Text;
+         S := Line_Start (P);
+         C := 1;
+
+         while S < P loop
+            if Src (S) = HT then
+               C := (C - 1) / 8 * 8 + (8 + 1);
+            else
+               C := C + 1;
+            end if;
+
+            S := S + 1;
+         end loop;
+
+         return C;
+      end if;
+   end Get_Column_Number;
+
+   -----------------------------
+   -- Get_Logical_Line_Number --
+   -----------------------------
+
+   function Get_Logical_Line_Number
+     (P    : Source_Ptr)
+      return Logical_Line_Number
+   is
+      SFR : Source_File_Record
+              renames Source_File.Table (Get_Source_File_Index (P));
+
+      L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
+
+   begin
+      if SFR.Num_SRef_Pragmas = 0 then
+         return Logical_Line_Number (L);
+      else
+         return SFR.Logical_Lines_Table (L);
+      end if;
+   end Get_Logical_Line_Number;
+
+   ------------------------------
+   -- Get_Physical_Line_Number --
+   ------------------------------
+
+   function Get_Physical_Line_Number
+     (P    : Source_Ptr)
+      return Physical_Line_Number
+   is
+      Sfile : Source_File_Index;
+      Table : Lines_Table_Ptr;
+      Lo    : Physical_Line_Number;
+      Hi    : Physical_Line_Number;
+      Mid   : Physical_Line_Number;
+      Loc   : Source_Ptr;
+
+   begin
+      --  If the input source pointer is not a meaningful value then return
+      --  at once with line number 1. This can happen for a file not found
+      --  condition for a file loaded indirectly by RTE, and also perhaps on
+      --  some unknown internal error conditions. In either case we certainly
+      --  don't want to blow up.
+
+      if P < 1 then
+         return 1;
+
+      --  Otherwise we can do the binary search
+
+      else
+         Sfile := Get_Source_File_Index (P);
+         Loc   := P + Source_File.Table (Sfile).Sloc_Adjust;
+         Table := Source_File.Table (Sfile).Lines_Table;
+         Lo    := 1;
+         Hi    := Source_File.Table (Sfile).Last_Source_Line;
+
+         loop
+            Mid := (Lo + Hi) / 2;
+
+            if Loc < Table (Mid) then
+               Hi := Mid - 1;
+
+            else -- Loc >= Table (Mid)
+
+               if Mid = Hi or else
+                  Loc < Table (Mid + 1)
+               then
+                  return Mid;
+               else
+                  Lo := Mid + 1;
+               end if;
+
+            end if;
+
+         end loop;
+      end if;
+   end Get_Physical_Line_Number;
+
+   ---------------------------
+   -- Get_Source_File_Index --
+   ---------------------------
+
+   Source_Cache_First : Source_Ptr := 1;
+   Source_Cache_Last  : Source_Ptr := 0;
+   --  Records the First and Last subscript values for the most recently
+   --  referenced entry in the source table, to optimize the common case
+   --  of repeated references to the same entry. The initial values force
+   --  an initial search to set the cache value.
+
+   Source_Cache_Index : Source_File_Index := No_Source_File;
+   --  Contains the index of the entry corresponding to Source_Cache
+
+   function Get_Source_File_Index
+     (S    : Source_Ptr)
+      return Source_File_Index
+   is
+   begin
+      if S in Source_Cache_First .. Source_Cache_Last then
+         return Source_Cache_Index;
+
+      else
+         for J in 1 .. Source_File.Last loop
+            if S in Source_File.Table (J).Source_First ..
+                    Source_File.Table (J).Source_Last
+            then
+               Source_Cache_Index := J;
+               Source_Cache_First :=
+                 Source_File.Table (Source_Cache_Index).Source_First;
+               Source_Cache_Last :=
+                 Source_File.Table (Source_Cache_Index).Source_Last;
+               return Source_Cache_Index;
+            end if;
+         end loop;
+      end if;
+
+      --  We must find a matching entry in the above loop!
+
+      raise Program_Error;
+   end Get_Source_File_Index;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Source_File.Init;
+   end Initialize;
+
+   -------------------------
+   -- Instantiation_Depth --
+   -------------------------
+
+   function Instantiation_Depth (S : Source_Ptr) return Nat is
+      Sind  : Source_File_Index;
+      Sval  : Source_Ptr;
+      Depth : Nat;
+
+   begin
+      Sval := S;
+      Depth := 0;
+
+      loop
+         Sind := Get_Source_File_Index (Sval);
+         Sval := Instantiation (Sind);
+         exit when Sval = No_Location;
+         Depth := Depth + 1;
+      end loop;
+
+      return Depth;
+   end Instantiation_Depth;
+
+   ----------------------------
+   -- Instantiation_Location --
+   ----------------------------
+
+   function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
+   begin
+      return Instantiation (Get_Source_File_Index (S));
+   end Instantiation_Location;
+
+   ----------------------
+   -- Last_Source_File --
+   ----------------------
+
+   function Last_Source_File return Source_File_Index is
+   begin
+      return Source_File.Last;
+   end Last_Source_File;
+
+   ----------------
+   -- Line_Start --
+   ----------------
+
+   function Line_Start (P : Source_Ptr) return Source_Ptr is
+      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
+      Src    : constant Source_Buffer_Ptr :=
+                 Source_File.Table (Sindex).Source_Text;
+      Sfirst : constant Source_Ptr :=
+                 Source_File.Table (Sindex).Source_First;
+      S      : Source_Ptr;
+
+   begin
+      S := P;
+
+      while S > Sfirst
+        and then Src (S - 1) /= CR
+        and then Src (S - 1) /= LF
+      loop
+         S := S - 1;
+      end loop;
+
+      return S;
+   end Line_Start;
+
+   function Line_Start
+     (L    : Physical_Line_Number;
+      S    : Source_File_Index)
+      return Source_Ptr
+   is
+   begin
+      return Source_File.Table (S).Lines_Table (L);
+   end Line_Start;
+
+   ----------
+   -- Lock --
+   ----------
+
+   procedure Lock is
+   begin
+      Source_File.Locked := True;
+      Source_File.Release;
+   end Lock;
+
+   ----------------------
+   -- Num_Source_Files --
+   ----------------------
+
+   function Num_Source_Files return Nat is
+   begin
+      return Int (Source_File.Last) - Int (Source_File.First) + 1;
+   end Num_Source_Files;
+
+   ----------------------
+   -- Num_Source_Lines --
+   ----------------------
+
+   function Num_Source_Lines (S : Source_File_Index) return Nat is
+   begin
+      return Nat (Source_File.Table (S).Last_Source_Line);
+   end Num_Source_Lines;
+
+   -----------------------
+   -- Original_Location --
+   -----------------------
+
+   function Original_Location (S : Source_Ptr) return Source_Ptr is
+      Sindex : Source_File_Index;
+      Tindex : Source_File_Index;
+
+   begin
+      if S <= No_Location then
+         return S;
+
+      else
+         Sindex := Get_Source_File_Index (S);
+
+         if Instantiation (Sindex) = No_Location then
+            return S;
+
+         else
+            Tindex := Template (Sindex);
+            while Instantiation (Tindex) /= No_Location loop
+               Tindex := Template (Tindex);
+            end loop;
+
+            return S - Source_First (Sindex) + Source_First (Tindex);
+         end if;
+      end if;
+   end Original_Location;
+
+   -------------------------
+   -- Physical_To_Logical --
+   -------------------------
+
+   function Physical_To_Logical
+     (Line : Physical_Line_Number;
+      S    : Source_File_Index)
+      return Logical_Line_Number
+   is
+      SFR : Source_File_Record renames Source_File.Table (S);
+
+   begin
+      if SFR.Num_SRef_Pragmas = 0 then
+         return Logical_Line_Number (Line);
+      else
+         return SFR.Logical_Lines_Table (Line);
+      end if;
+   end Physical_To_Logical;
+
+   --------------------------------
+   -- Register_Source_Ref_Pragma --
+   --------------------------------
+
+   procedure Register_Source_Ref_Pragma
+     (File_Name          : Name_Id;
+      Stripped_File_Name : Name_Id;
+      Mapped_Line        : Nat;
+      Line_After_Pragma  : Physical_Line_Number)
+   is
+      SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
+
+      function malloc
+        (size     : size_t)
+         return     Logical_Lines_Table_Ptr;
+      pragma Import (C, malloc);
+
+      ML : Logical_Line_Number;
+
+   begin
+      if File_Name /= No_Name then
+         SFR.Full_Ref_Name := File_Name;
+
+         if not Debug_Generated_Code then
+            SFR.Debug_Source_Name := File_Name;
+         end if;
+
+         SFR.Reference_Name   := Stripped_File_Name;
+         SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
+      end if;
+
+      if SFR.Num_SRef_Pragmas = 1 then
+         SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
+      end if;
+
+      if SFR.Logical_Lines_Table = null then
+         SFR.Logical_Lines_Table :=
+           malloc
+             (size_t (SFR.Lines_Table_Max *
+                        Logical_Lines_Table_Type'Component_Size /
+                                                        Storage_Unit));
+      end if;
+
+      SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
+
+      ML := Logical_Line_Number (Mapped_Line);
+      for J in Line_After_Pragma .. SFR.Last_Source_Line loop
+         SFR.Logical_Lines_Table (J) := ML;
+         ML := ML + 1;
+      end loop;
+   end Register_Source_Ref_Pragma;
+
+   ---------------------------
+   -- Skip_Line_Terminators --
+   ---------------------------
+
+   --  There are two distinct concepts of line terminator in GNAT
+
+   --    A logical line terminator is what corresponds to the "end of a line"
+   --    as described in RM 2.2 (13). Any of the characters FF, LF, CR or VT
+   --    acts as an end of logical line in this sense, and it is essentially
+   --    irrelevant whether one or more appears in sequence (since if a
+   --    sequence of such characters is regarded as separate ends of line,
+   --    then the intervening logical lines are null in any case).
+
+   --    A physical line terminator is a sequence of format effectors that
+   --    is treated as ending a physical line. Physical lines have no Ada
+   --    semantic significance, but they are significant for error reporting
+   --    purposes, since errors are identified by line and column location.
+
+   --  In GNAT, a physical line is ended by any of the sequences LF, CR/LF,
+   --  CR or LF/CR. LF is used in typical Unix systems, CR/LF in DOS systems,
+   --  and CR alone in System 7. We don't know of any system using LF/CR, but
+   --  it seems reasonable to include this case for consistency. In addition,
+   --  we recognize any of these sequences in any of the operating systems,
+   --  for better behavior in treating foreign files (e.g. a Unix file with
+   --  LF terminators transferred to a DOS system).
+
+   procedure Skip_Line_Terminators
+     (P        : in out Source_Ptr;
+      Physical : out Boolean)
+   is
+   begin
+      pragma Assert (Source (P) in Line_Terminator);
+
+      if Source (P) = CR then
+         if Source (P + 1) = LF then
+            P := P + 2;
+         else
+            P := P + 1;
+         end if;
+
+      elsif Source (P) = LF then
+         if Source (P + 1) = CR then
+            P := P + 2;
+         else
+            P := P + 1;
+         end if;
+
+      else -- Source (P) = FF or else Source (P) = VT
+         P := P + 1;
+         Physical := False;
+         return;
+      end if;
+
+      --  Fall through in the physical line terminator case. First deal with
+      --  making a possible entry into the lines table if one is needed.
+
+      --  Note: we are dealing with a real source file here, this cannot be
+      --  the instantiation case, so we need not worry about Sloc adjustment.
+
+      declare
+         S : Source_File_Record
+               renames Source_File.Table (Current_Source_File);
+
+      begin
+         Physical := True;
+
+         --  Make entry in lines table if not already made (in some scan backup
+         --  cases, we will be rescanning previously scanned source, so the
+         --  entry may have already been made on the previous forward scan).
+
+         if Source (P) /= EOF
+           and then P > S.Lines_Table (S.Last_Source_Line)
+         then
+            Add_Line_Tables_Entry (S, P);
+         end if;
+      end;
+   end Skip_Line_Terminators;
+
+   -------------------
+   -- Source_Offset --
+   -------------------
+
+   function Source_Offset (S : Source_Ptr) return Nat is
+      Sindex : constant Source_File_Index := Get_Source_File_Index (S);
+      Sfirst : constant Source_Ptr :=
+                 Source_File.Table (Sindex).Source_First;
+
+   begin
+      return Nat (S - Sfirst);
+   end Source_Offset;
+
+   ------------------------
+   -- Top_Level_Location --
+   ------------------------
+
+   function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
+      Oldloc : Source_Ptr;
+      Newloc : Source_Ptr;
+
+   begin
+      Newloc := S;
+      loop
+         Oldloc := Newloc;
+         Newloc := Instantiation_Location (Oldloc);
+         exit when Newloc = No_Location;
+      end loop;
+
+      return Oldloc;
+   end Top_Level_Location;
+
+   ---------------
+   -- Tree_Read --
+   ---------------
+
+   procedure Tree_Read is
+   begin
+      --  First we must free any old source buffer pointers
+
+      if not First_Time_Around then
+         for J in Source_File.First .. Source_File.Last loop
+            declare
+               S : Source_File_Record renames Source_File.Table (J);
+
+               procedure Free_Ptr is new Unchecked_Deallocation
+                 (Big_Source_Buffer, Source_Buffer_Ptr);
+
+               --  Note: we are using free here, because we used malloc
+               --  or realloc directly to allocate the tables. That is
+               --  because we were playing the big array trick.
+
+               procedure free (X : Lines_Table_Ptr);
+               pragma Import (C, free, "free");
+
+               procedure freel (X : Logical_Lines_Table_Ptr);
+               pragma Import (C, freel, "free");
+
+               function To_Source_Buffer_Ptr is new
+                 Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+               Tmp1 : Source_Buffer_Ptr;
+
+            begin
+               if S.Instantiation /= No_Location then
+                  null;
+
+               else
+                  --  We have to recreate a proper pointer to the actual array
+                  --  from the zero origin pointer stored in the source table.
+
+                  Tmp1 :=
+                    To_Source_Buffer_Ptr
+                      (S.Source_Text (S.Source_First)'Address);
+                  Free_Ptr (Tmp1);
+
+                  if S.Lines_Table /= null then
+                     free (S.Lines_Table);
+                     S.Lines_Table := null;
+                  end if;
+
+                  if S.Logical_Lines_Table /= null then
+                     freel (S.Logical_Lines_Table);
+                     S.Logical_Lines_Table := null;
+                  end if;
+               end if;
+            end;
+         end loop;
+      end if;
+
+      --  Reset source cache pointers to force new read
+
+      Source_Cache_First := 1;
+      Source_Cache_Last  := 0;
+
+      --  Read in source file table
+
+      Source_File.Tree_Read;
+
+      --  The pointers we read in there for the source buffer and lines
+      --  table pointers are junk. We now read in the actual data that
+      --  is referenced by these two fields.
+
+      for J in Source_File.First .. Source_File.Last loop
+         declare
+            S : Source_File_Record renames Source_File.Table (J);
+
+         begin
+            --  For the instantiation case, we do not read in any data. Instead
+            --  we share the data for the generic template entry. Since the
+            --  template always occurs first, we can safetly refer to its data.
+
+            if S.Instantiation /= No_Location then
+               declare
+                  ST : Source_File_Record renames
+                         Source_File.Table (S.Template);
+
+               begin
+                  --  The lines tables are copied from the template entry
+
+                  S.Lines_Table :=
+                    Source_File.Table (S.Template).Lines_Table;
+                  S.Logical_Lines_Table :=
+                    Source_File.Table (S.Template).Logical_Lines_Table;
+
+                  --  In the case of the source table pointer, we share the
+                  --  same data as the generic template, but the virtual origin
+                  --  is adjusted. For example, if the first subscript of the
+                  --  template is 100, and that of the instantiation is 200,
+                  --  then the instantiation pointer is obtained by subtracting
+                  --  100 from the template pointer.
+
+                  declare
+                     pragma Suppress (All_Checks);
+
+                     function To_Source_Buffer_Ptr is new
+                       Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+                  begin
+                     S.Source_Text :=
+                       To_Source_Buffer_Ptr
+                          (ST.Source_Text
+                            (ST.Source_First - S.Source_First)'Address);
+                  end;
+               end;
+
+            --  Normal case (non-instantiation)
+
+            else
+               First_Time_Around := False;
+               S.Lines_Table := null;
+               S.Logical_Lines_Table := null;
+               Alloc_Line_Tables (S, Int (S.Last_Source_Line));
+
+               for J in 1 .. S.Last_Source_Line loop
+                  Tree_Read_Int (Int (S.Lines_Table (J)));
+               end loop;
+
+               if S.Num_SRef_Pragmas /= 0 then
+                  for J in 1 .. S.Last_Source_Line loop
+                     Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
+                  end loop;
+               end if;
+
+               --  Allocate source buffer and read in the data and then set the
+               --  virtual origin to point to the logical zero'th element. This
+               --  address must be computed with subscript checks turned off.
+
+               declare
+                  subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
+                  type Text_Buffer_Ptr is access B;
+                  T : Text_Buffer_Ptr;
+
+                  pragma Suppress (All_Checks);
+
+                  function To_Source_Buffer_Ptr is new
+                    Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+               begin
+                  T := new B;
+
+                  Tree_Read_Data (T (S.Source_First)'Address,
+                     Int (S.Source_Last) - Int (S.Source_First) + 1);
+
+                  S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
+               end;
+            end if;
+         end;
+      end loop;
+   end Tree_Read;
+
+   ----------------
+   -- Tree_Write --
+   ----------------
+
+   procedure Tree_Write is
+   begin
+      Source_File.Tree_Write;
+
+      --  The pointers we wrote out there for the source buffer and lines
+      --  table pointers are junk, we now write out the actual data that
+      --  is referenced by these two fields.
+
+      for J in Source_File.First .. Source_File.Last loop
+         declare
+            S : Source_File_Record renames Source_File.Table (J);
+
+         begin
+            --  For instantiations, there is nothing to do, since the data is
+            --  shared with the generic template. When the tree is read, the
+            --  pointers must be set, but no extra data needs to be written.
+
+            if S.Instantiation /= No_Location then
+               null;
+
+            --  For the normal case, write out the data of the tables
+
+            else
+               --  Lines table
+
+               for J in 1 .. S.Last_Source_Line loop
+                  Tree_Write_Int (Int (S.Lines_Table (J)));
+               end loop;
+
+               --  Logical lines table if present
+
+               if S.Num_SRef_Pragmas /= 0 then
+                  for J in 1 .. S.Last_Source_Line loop
+                     Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
+                  end loop;
+               end if;
+
+               --  Source buffer
+
+               Tree_Write_Data
+                 (S.Source_Text (S.Source_First)'Address,
+                   Int (S.Source_Last) - Int (S.Source_First) + 1);
+            end if;
+         end;
+      end loop;
+   end Tree_Write;
+
+   --------------------
+   -- Write_Location --
+   --------------------
+
+   procedure Write_Location (P : Source_Ptr) is
+   begin
+      if P = No_Location then
+         Write_Str ("<no location>");
+
+      elsif P <= Standard_Location then
+         Write_Str ("<standard location>");
+
+      else
+         declare
+            SI : constant Source_File_Index := Get_Source_File_Index (P);
+
+         begin
+            Write_Name (Debug_Source_Name (SI));
+            Write_Char (':');
+            Write_Int (Int (Get_Logical_Line_Number (P)));
+            Write_Char (':');
+            Write_Int (Int (Get_Column_Number (P)));
+
+            if Instantiation (SI) /= No_Location then
+               Write_Str (" [");
+               Write_Location (Instantiation (SI));
+               Write_Char (']');
+            end if;
+         end;
+      end if;
+   end Write_Location;
+
+   ----------------------
+   -- Write_Time_Stamp --
+   ----------------------
+
+   procedure Write_Time_Stamp (S : Source_File_Index) is
+      T : constant Time_Stamp_Type := Time_Stamp (S);
+      P : Natural;
+
+   begin
+      if T (1) = '9' then
+         Write_Str ("19");
+         P := 0;
+      else
+         Write_Char (T (1));
+         Write_Char (T (2));
+         P := 2;
+      end if;
+
+      Write_Char (T (P + 1));
+      Write_Char (T (P + 2));
+      Write_Char ('-');
+
+      Write_Char (T (P + 3));
+      Write_Char (T (P + 4));
+      Write_Char ('-');
+
+      Write_Char (T (P + 5));
+      Write_Char (T (P + 6));
+      Write_Char (' ');
+
+      Write_Char (T (P + 7));
+      Write_Char (T (P + 8));
+      Write_Char (':');
+
+      Write_Char (T (P + 9));
+      Write_Char (T (P + 10));
+      Write_Char (':');
+
+      Write_Char (T (P + 11));
+      Write_Char (T (P + 12));
+   end Write_Time_Stamp;
+
+   ----------------------------------------------
+   -- Access Subprograms for Source File Table --
+   ----------------------------------------------
+
+   function Debug_Source_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).Debug_Source_Name;
+   end Debug_Source_Name;
+
+   function File_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).File_Name;
+   end File_Name;
+
+   function First_Mapped_Line (S : SFI) return Logical_Line_Number is
+   begin
+      return Source_File.Table (S).First_Mapped_Line;
+   end First_Mapped_Line;
+
+   function Full_File_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).Full_File_Name;
+   end Full_File_Name;
+
+   function Full_Ref_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).Full_Ref_Name;
+   end Full_Ref_Name;
+
+   function Identifier_Casing (S : SFI) return Casing_Type is
+   begin
+      return Source_File.Table (S).Identifier_Casing;
+   end Identifier_Casing;
+
+   function Instantiation (S : SFI) return Source_Ptr is
+   begin
+      return Source_File.Table (S).Instantiation;
+   end Instantiation;
+
+   function Keyword_Casing (S : SFI) return Casing_Type is
+   begin
+      return Source_File.Table (S).Keyword_Casing;
+   end Keyword_Casing;
+
+   function Last_Source_Line (S : SFI) return Physical_Line_Number is
+   begin
+      return Source_File.Table (S).Last_Source_Line;
+   end Last_Source_Line;
+
+   function License (S : SFI) return License_Type is
+   begin
+      return Source_File.Table (S).License;
+   end License;
+
+   function Num_SRef_Pragmas (S : SFI) return Nat is
+   begin
+      return Source_File.Table (S).Num_SRef_Pragmas;
+   end Num_SRef_Pragmas;
+
+   function Reference_Name (S : SFI) return File_Name_Type is
+   begin
+      return Source_File.Table (S).Reference_Name;
+   end Reference_Name;
+
+   function Source_Checksum (S : SFI) return Word is
+   begin
+      return Source_File.Table (S).Source_Checksum;
+   end Source_Checksum;
+
+   function Source_First (S : SFI) return Source_Ptr is
+   begin
+      return Source_File.Table (S).Source_First;
+   end Source_First;
+
+   function Source_Last (S : SFI) return Source_Ptr is
+   begin
+      return Source_File.Table (S).Source_Last;
+   end Source_Last;
+
+   function Source_Text (S : SFI) return Source_Buffer_Ptr is
+   begin
+      return Source_File.Table (S).Source_Text;
+   end Source_Text;
+
+   function Template (S : SFI) return SFI is
+   begin
+      return Source_File.Table (S).Template;
+   end Template;
+
+   function Time_Stamp (S : SFI) return Time_Stamp_Type is
+   begin
+      return Source_File.Table (S).Time_Stamp;
+   end Time_Stamp;
+
+   ------------------------------------------
+   -- Set Procedures for Source File Table --
+   ------------------------------------------
+
+   procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
+   begin
+      Source_File.Table (S).Identifier_Casing := C;
+   end Set_Identifier_Casing;
+
+   procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
+   begin
+      Source_File.Table (S).Keyword_Casing := C;
+   end Set_Keyword_Casing;
+
+   procedure Set_License (S : SFI; L : License_Type) is
+   begin
+      Source_File.Table (S).License := L;
+   end Set_License;
+
+   --------
+   -- wl --
+   --------
+
+   procedure wl (P : Source_Ptr) is
+   begin
+      Write_Location (P);
+      Write_Eol;
+   end wl;
+
+end Sinput;