path: root/gcc/ada/sinput-l.adb

------------------------------------------------------------------------------
--                                                                          --
--                         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;