534 lines
17 KiB
Ada
534 lines
17 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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;
|