New Language: Ada

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

1 files changed, 533 insertions, 0 deletions

diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb
new file mode 100644
index 00000000000..f00cbbd26dc
--- /dev/null
+++ b/gcc/ada/sinput-l.adb
@@ -0,0 +1,533 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S I N P U T . L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.40 $
+--                                                                          --
+--          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.                                                      --
+--                                                                          --
+-- 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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Alloc;
+with Atree;  use Atree;
+with Debug;  use Debug;
+with Einfo;  use Einfo;
+with Namet;  use Namet;
+with Opt;
+with Osint;  use Osint;
+with Output; use Output;
+with Scans;  use Scans;
+with Scn;    use Scn;
+with Sinfo;  use Sinfo;
+with System; use System;
+
+with Unchecked_Conversion;
+
+package body Sinput.L is
+
+   Dfile : Source_File_Index;
+   --  Index of currently active debug source file
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Trim_Lines_Table (S : Source_File_Index);
+   --  Set lines table size for entry S in the source file table to
+   --  correspond to the current value of Num_Source_Lines, releasing
+   --  any unused storage.
+
+   function Load_File
+     (N    : File_Name_Type;
+      T    : File_Type)
+      return Source_File_Index;
+   --  Load a source file or a configuration pragma file.
+
+   -------------------------------
+   -- Adjust_Instantiation_Sloc --
+   -------------------------------
+
+   procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
+      Loc : constant Source_Ptr := Sloc (N);
+
+   begin
+      --  We only do the adjustment if the value is between the appropriate
+      --  low and high values. It is not clear that this should ever not be
+      --  the case, but in practice there seem to be some nodes that get
+      --  copied twice, and this is a defence against that happening.
+
+      if A.Lo <= Loc and then Loc <= A.Hi then
+         Set_Sloc (N, Loc + A.Adjust);
+      end if;
+   end Adjust_Instantiation_Sloc;
+
+   ------------------------
+   -- Close_Debug_Source --
+   ------------------------
+
+   procedure Close_Debug_Source is
+      S    : Source_File_Record renames Source_File.Table (Dfile);
+      Src  : Source_Buffer_Ptr;
+
+   begin
+      Trim_Lines_Table (Dfile);
+      Close_Debug_File;
+
+      --  Now we need to read the file that we wrote and store it
+      --  in memory for subsequent access.
+
+      Read_Source_File
+        (S.Debug_Source_Name, S.Source_First, S.Source_Last, Src);
+      S.Source_Text := Src;
+   end Close_Debug_Source;
+
+   --------------------------------
+   -- Complete_Source_File_Entry --
+   --------------------------------
+
+   procedure Complete_Source_File_Entry is
+      CSF : constant Source_File_Index := Current_Source_File;
+
+   begin
+      Trim_Lines_Table (CSF);
+      Source_File.Table (CSF).Source_Checksum := Checksum;
+   end Complete_Source_File_Entry;
+
+   -------------------------
+   -- Create_Debug_Source --
+   -------------------------
+
+   procedure Create_Debug_Source
+     (Source : Source_File_Index;
+      Loc    : out Source_Ptr)
+   is
+   begin
+      Loc := Source_File.Table (Source_File.Last).Source_Last + 1;
+      Source_File.Increment_Last;
+      Dfile := Source_File.Last;
+
+      declare
+         S : Source_File_Record renames Source_File.Table (Dfile);
+
+      begin
+         S := Source_File.Table (Source);
+         S.Debug_Source_Name := Create_Debug_File (S.File_Name);
+         S.Source_First      := Loc;
+         S.Source_Last       := Loc;
+         S.Lines_Table       := null;
+         S.Last_Source_Line  := 1;
+
+         --  Allocate lines table, guess that it needs to be three times
+         --  bigger than the original source (in number of lines).
+
+         Alloc_Line_Tables
+           (S, Int (Source_File.Table (Source).Last_Source_Line * 3));
+         S.Lines_Table (1) := Loc;
+      end;
+
+      if Debug_Flag_GG then
+         Write_Str ("---> Create_Debug_Source (Source => ");
+         Write_Int (Int (Source));
+         Write_Str (", Loc => ");
+         Write_Int (Int (Loc));
+         Write_Str (");");
+         Write_Eol;
+      end if;
+
+   end Create_Debug_Source;
+
+   ---------------------------------
+   -- Create_Instantiation_Source --
+   ---------------------------------
+
+   procedure Create_Instantiation_Source
+     (Inst_Node   : Entity_Id;
+      Template_Id : Entity_Id;
+      A           : out Sloc_Adjustment)
+   is
+      Dnod : constant Node_Id := Declaration_Node (Template_Id);
+      Xold : Source_File_Index;
+      Xnew : Source_File_Index;
+
+   begin
+      Xold := Get_Source_File_Index (Sloc (Template_Id));
+      A.Lo := Source_File.Table (Xold).Source_First;
+      A.Hi := Source_File.Table (Xold).Source_Last;
+
+      Source_File.Increment_Last;
+      Xnew := Source_File.Last;
+
+      Source_File.Table (Xnew)               := Source_File.Table (Xold);
+      Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
+      Source_File.Table (Xnew).Template      := Xold;
+
+      --  Now we need to compute the new values of Source_First, Source_Last
+      --  and adjust the source file pointer to have the correct virtual
+      --  origin for the new range of values.
+
+      Source_File.Table (Xnew).Source_First :=
+        Source_File.Table (Xnew - 1).Source_Last + 1;
+
+      A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
+      Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
+
+      Source_File.Table (Xnew).Sloc_Adjust :=
+        Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
+
+      if Debug_Flag_L then
+         Write_Eol;
+         Write_Str ("*** Create instantiation source for ");
+
+         if Nkind (Dnod) in N_Proper_Body
+           and then Was_Originally_Stub (Dnod)
+         then
+            Write_Str ("subunit ");
+
+         elsif Ekind (Template_Id) = E_Generic_Package then
+            if Nkind (Dnod) = N_Package_Body then
+               Write_Str ("body of package ");
+            else
+               Write_Str ("spec of package ");
+            end if;
+
+         elsif Ekind (Template_Id) = E_Function then
+            Write_Str ("body of function ");
+
+         elsif Ekind (Template_Id) = E_Procedure then
+            Write_Str ("body of procedure ");
+
+         elsif Ekind (Template_Id) = E_Generic_Function then
+            Write_Str ("spec of function ");
+
+         elsif Ekind (Template_Id) = E_Generic_Procedure then
+            Write_Str ("spec of procedure ");
+
+         elsif Ekind (Template_Id) = E_Package_Body then
+            Write_Str ("body of package ");
+
+         else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
+
+            if Nkind (Dnod) = N_Procedure_Specification then
+               Write_Str ("body of procedure ");
+            else
+               Write_Str ("body of function ");
+            end if;
+         end if;
+
+         Write_Name (Chars (Template_Id));
+         Write_Eol;
+
+         Write_Str ("  new source index = ");
+         Write_Int (Int (Xnew));
+         Write_Eol;
+
+         Write_Str ("  copying from file name = ");
+         Write_Name (File_Name (Xold));
+         Write_Eol;
+
+         Write_Str ("  old source index = ");
+         Write_Int (Int (Xold));
+         Write_Eol;
+
+         Write_Str ("  old lo = ");
+         Write_Int (Int (A.Lo));
+         Write_Eol;
+
+         Write_Str ("  old hi = ");
+         Write_Int (Int (A.Hi));
+         Write_Eol;
+
+         Write_Str ("  new lo = ");
+         Write_Int (Int (Source_File.Table (Xnew).Source_First));
+         Write_Eol;
+
+         Write_Str ("  new hi = ");
+         Write_Int (Int (Source_File.Table (Xnew).Source_Last));
+         Write_Eol;
+
+         Write_Str ("  adjustment factor = ");
+         Write_Int (Int (A.Adjust));
+         Write_Eol;
+
+         Write_Str ("  instantiation location: ");
+         Write_Location (Sloc (Inst_Node));
+         Write_Eol;
+      end if;
+
+      --  For a given character in the source, a higher subscript will be
+      --  used to access the instantiation, which means that the virtual
+      --  origin must have a corresponding lower value. We compute this
+      --  new origin by taking the address of the appropriate adjusted
+      --  element in the old array. Since this adjusted element will be
+      --  at a negative subscript, we must suppress checks.
+
+      declare
+         pragma Suppress (All_Checks);
+
+         function To_Source_Buffer_Ptr is new
+           Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+      begin
+         Source_File.Table (Xnew).Source_Text :=
+           To_Source_Buffer_Ptr
+             (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
+      end;
+
+   end Create_Instantiation_Source;
+
+   ----------------------
+   -- Load_Config_File --
+   ----------------------
+
+   function Load_Config_File
+     (N    : File_Name_Type)
+      return Source_File_Index
+   is
+   begin
+      return Load_File (N, Osint.Config);
+   end Load_Config_File;
+
+   ---------------
+   -- Load_File --
+   ---------------
+
+   function Load_File
+     (N :    File_Name_Type;
+      T :    File_Type)
+      return Source_File_Index
+   is
+      Src  : Source_Buffer_Ptr;
+      X    : Source_File_Index;
+      Lo   : Source_Ptr;
+      Hi   : Source_Ptr;
+
+   begin
+      for J in 1 .. Source_File.Last loop
+         if Source_File.Table (J).File_Name = N then
+            return J;
+         end if;
+      end loop;
+
+      --  Here we must build a new entry in the file table
+
+      Source_File.Increment_Last;
+      X := Source_File.Last;
+
+      if X = Source_File.First then
+         Lo := First_Source_Ptr;
+      else
+         Lo := Source_File.Table (X - 1).Source_Last + 1;
+      end if;
+
+      Read_Source_File (N, Lo, Hi, Src, T);
+
+      if Src = null then
+         Source_File.Decrement_Last;
+         return No_Source_File;
+
+      else
+         if Debug_Flag_L then
+            Write_Eol;
+            Write_Str ("*** Build source file table entry, Index = ");
+            Write_Int (Int (X));
+            Write_Str (", file name = ");
+            Write_Name (N);
+            Write_Eol;
+            Write_Str ("  lo = ");
+            Write_Int (Int (Lo));
+            Write_Eol;
+            Write_Str ("  hi = ");
+            Write_Int (Int (Hi));
+            Write_Eol;
+
+            Write_Str ("  first 10 chars -->");
+
+            declare
+               procedure Wchar (C : Character);
+               --  Writes character or ? for control character
+
+               procedure Wchar (C : Character) is
+               begin
+                  if C < ' ' or C in ASCII.DEL .. Character'Val (16#9F#) then
+                     Write_Char ('?');
+                  else
+                     Write_Char (C);
+                  end if;
+               end Wchar;
+
+            begin
+               for J in Lo .. Lo + 9 loop
+                  Wchar (Src (J));
+               end loop;
+
+               Write_Str ("<--");
+               Write_Eol;
+
+               Write_Str ("  last 10 chars  -->");
+
+               for J in Hi - 10 .. Hi - 1 loop
+                  Wchar (Src (J));
+               end loop;
+
+               Write_Str ("<--");
+               Write_Eol;
+
+               if Src (Hi) /= EOF then
+                  Write_Str ("  error: no EOF at end");
+                  Write_Eol;
+               end if;
+            end;
+         end if;
+
+         declare
+            S : Source_File_Record renames Source_File.Table (X);
+
+         begin
+            S := (Debug_Source_Name   => Full_Source_Name,
+                  File_Name           => N,
+                  First_Mapped_Line   => No_Line_Number,
+                  Full_File_Name      => Full_Source_Name,
+                  Full_Ref_Name       => Full_Source_Name,
+                  Identifier_Casing   => Unknown,
+                  Instantiation       => No_Location,
+                  Keyword_Casing      => Unknown,
+                  Last_Source_Line    => 1,
+                  License             => Unknown,
+                  Lines_Table         => null,
+                  Lines_Table_Max     => 1,
+                  Logical_Lines_Table => null,
+                  Num_SRef_Pragmas    => 0,
+                  Reference_Name      => N,
+                  Sloc_Adjust         => 0,
+                  Source_Checksum     => 0,
+                  Source_First        => Lo,
+                  Source_Last         => Hi,
+                  Source_Text         => Src,
+                  Template            => No_Source_File,
+                  Time_Stamp          => Current_Source_File_Stamp);
+
+            Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
+            S.Lines_Table (1) := Lo;
+         end;
+
+         return X;
+      end if;
+   end Load_File;
+
+   ----------------------
+   -- Load_Source_File --
+   ----------------------
+
+   function Load_Source_File
+     (N    : File_Name_Type)
+      return Source_File_Index
+   is
+   begin
+      return Load_File (N, Osint.Source);
+   end Load_Source_File;
+
+   ----------------------------
+   -- Source_File_Is_Subunit --
+   ----------------------------
+
+   function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
+   begin
+      Initialize_Scanner (No_Unit, X);
+
+      --  We scan past junk to the first interesting compilation unit
+      --  token, to see if it is SEPARATE. We ignore WITH keywords during
+      --  this and also PRIVATE. The reason for ignoring PRIVATE is that
+      --  it handles some error situations, and also it is possible that
+      --  a PRIVATE WITH feature might be approved some time in the future.
+
+      while Token = Tok_With
+        or else Token = Tok_Private
+        or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
+      loop
+         Scan;
+      end loop;
+
+      return Token = Tok_Separate;
+   end Source_File_Is_Subunit;
+
+   ----------------------
+   -- Trim_Lines_Table --
+   ----------------------
+
+   procedure Trim_Lines_Table (S : Source_File_Index) is
+
+      function realloc
+        (P        : Lines_Table_Ptr;
+         New_Size : Int)
+         return     Lines_Table_Ptr;
+      pragma Import (C, realloc);
+
+      Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
+
+   begin
+      --  Release allocated storage that is no longer needed
+
+      Source_File.Table (S).Lines_Table :=
+        realloc
+          (Source_File.Table (S).Lines_Table,
+           Max * (Lines_Table_Type'Component_Size / System.Storage_Unit));
+      Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
+   end Trim_Lines_Table;
+
+   ----------------------
+   -- Write_Debug_Line --
+   ----------------------
+
+   procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr) is
+      S : Source_File_Record renames Source_File.Table (Dfile);
+
+   begin
+      --  Ignore write request if null line at start of file
+
+      if Str'Length = 0 and then Loc = S.Source_First then
+         return;
+
+      --  Here we write the line, and update the source record entry
+
+      else
+         Write_Debug_Info (Str);
+         Add_Line_Tables_Entry (S, Loc);
+         Loc := Loc + Source_Ptr (Str'Length + Debug_File_Eol_Length);
+         S.Source_Last := Loc;
+
+         if Debug_Flag_GG then
+            declare
+               Lin : constant String := Str;
+
+            begin
+               Column := 1;
+               Write_Str ("---> Write_Debug_Line (Str => """);
+               Write_Str (Lin);
+               Write_Str (""", Loc => ");
+               Write_Int (Int (Loc));
+               Write_Str (");");
+               Write_Eol;
+            end;
+         end if;
+      end if;
+   end Write_Debug_Line;
+
+end Sinput.L;