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