+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S I N P U T . L --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- 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. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
projects / msp430-gcc.git / blobdiff