OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
1dbadbbecd
gcc/gcc/ada/sinput.adb
Arnaud Charlet beacce0274 [multiple changes] 
2010-10-12  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Clarify that 'Old can be used in preconditions and
	postcondition pragmas.

2010-10-12  Robert Dewar  <dewar@adacore.com>

	* errout.ads, erroutc.adb: The # insertion now handles from in place of
	at.
	* exp_prag.adb (Expand_Pragma_Check): Suppress generated default
	message if new switch Exception_Locations_Suppressed is set.
	(Expand_Pragma_Check): Revised wording for default message for case
	of precondition or postcondition.
	* namet.ads, namet.adb (Build_Location_String): New procedure.
	* opt.ads (List_Inherited_Pre_Post): New flag.
	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Add call to
	list inherited pre/post aspects.
	* sem_ch13.adb (Analyze_Aspect_Specification): Improve generation of
	messages for precondition/postcondition cases.
	* sem_ch6.adb (Process_PPCs): General cleanup, and list inherited PPC's
	if flag List_Inherited_Pre_Post is set True.
	(Process_PPCs): Add initial handling for inherited preconditions
	(List_Inherited_Pre_Post_Aspects): New procedure
	* sem_ch6.ads (List_Inherited_Pre_Post_Aspects): New procedure
	* sem_disp.adb (Inherited_Subprograms): New function
	* sem_disp.ads (Inherited_Subprograms): New function
	* sem_prag.adb (Check_Duplicate_Pragma): Clean up handling of
	pre/postcondition.
	(Check_Precondition_Postcondition): Check for inherited aspects
	* sem_warn.adb: Process -gnatw.l/w.L setting List_Inherited_Pre_Post
	* sinfo.ads, sinfo.adb (Split_PPC): New flag.
	* sinput.ads, sinput.adb (Build_Location_String): New function.
	* usage.adb: Add line for -gnatw.l/-gnatw.L

2010-10-12  Javier Miranda  <miranda@adacore.com>

	* exp_util.adb (Remove_Side_Effects): Remove wrong code.

2010-10-12  Arnaud Charlet  <charlet@adacore.com>

	* xref_lib.adb: Add handling of j/J letters.

From-SVN: r165361
2010-10-12 13:00:42 +02:00

1267 lines
37 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S I N P U T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, 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 3, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Style_Checks (All_Checks);
-- Subprograms not all in alpha order
with Atree; use Atree;
with Debug; use Debug;
with Opt; use Opt;
with Output; use Output;
with Tree_IO; use Tree_IO;
with System; use System;
with Widechar; use Widechar;
with System.Memory;
with Unchecked_Conversion;
with Unchecked_Deallocation;
package body Sinput is
use ASCII;
-- Make control characters visible
First_Time_Around : Boolean := True;
-- Routines to support conversion between types Lines_Table_Ptr,
-- Logical_Lines_Table_Ptr and System.Address.
pragma Warnings (Off);
-- These unchecked conversions are aliasing safe, since they are never
-- used to construct improperly aliased pointer values.
function To_Address is
new Unchecked_Conversion (Lines_Table_Ptr, Address);
function To_Address is
new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
function To_Pointer is
new Unchecked_Conversion (Address, Lines_Table_Ptr);
function To_Pointer is
new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
pragma Warnings (On);
---------------------------
-- Add_Line_Tables_Entry --
---------------------------
procedure Add_Line_Tables_Entry
(S : in out Source_File_Record;
P : Source_Ptr)
is
LL : Physical_Line_Number;
begin
-- Reallocate the lines tables if necessary
-- Note: the reason we do not use the normal Table package
-- mechanism is that we have several of these tables. We could
-- use the new GNAT.Dynamic_Tables package and that would probably
-- be a good idea ???
if S.Last_Source_Line = S.Lines_Table_Max then
Alloc_Line_Tables
(S,
Int (S.Last_Source_Line) *
((100 + Alloc.Lines_Increment) / 100));
if Debug_Flag_D then
Write_Str ("--> Reallocating lines table, size = ");
Write_Int (Int (S.Lines_Table_Max));
Write_Eol;
end if;
end if;
S.Last_Source_Line := S.Last_Source_Line + 1;
LL := S.Last_Source_Line;
S.Lines_Table (LL) := P;
-- Deal with setting new entry in logical lines table if one is
-- present. Note that there is always space (because the call to
-- Alloc_Line_Tables makes sure both tables are the same length),
if S.Logical_Lines_Table /= null then
-- We can always set the entry from the previous one, because
-- the processing for a Source_Reference pragma ensures that
-- at least one entry following the pragma is set up correctly.
S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
end if;
end Add_Line_Tables_Entry;
-----------------------
-- Alloc_Line_Tables --
-----------------------
procedure Alloc_Line_Tables
(S : in out Source_File_Record;
New_Max : Nat)
is
subtype size_t is Memory.size_t;
New_Table : Lines_Table_Ptr;
New_Logical_Table : Logical_Lines_Table_Ptr;
New_Size : constant size_t :=
size_t (New_Max * Lines_Table_Type'Component_Size /
Storage_Unit);
begin
if S.Lines_Table = null then
New_Table := To_Pointer (Memory.Alloc (New_Size));
else
New_Table :=
To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
end if;
if New_Table = null then
raise Storage_Error;
else
S.Lines_Table := New_Table;
S.Lines_Table_Max := Physical_Line_Number (New_Max);
end if;
if S.Num_SRef_Pragmas /= 0 then
if S.Logical_Lines_Table = null then
New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
else
New_Logical_Table := To_Pointer
(Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
end if;
if New_Logical_Table = null then
raise Storage_Error;
else
S.Logical_Lines_Table := New_Logical_Table;
end if;
end if;
end Alloc_Line_Tables;
-----------------
-- Backup_Line --
-----------------
procedure Backup_Line (P : in out Source_Ptr) is
Sindex : constant Source_File_Index := Get_Source_File_Index (P);
Src : constant Source_Buffer_Ptr :=
Source_File.Table (Sindex).Source_Text;
Sfirst : constant Source_Ptr :=
Source_File.Table (Sindex).Source_First;
begin
P := P - 1;
if P = Sfirst then
return;
end if;
if Src (P) = CR then
if Src (P - 1) = LF then
P := P - 1;
end if;
else -- Src (P) = LF
if Src (P - 1) = CR then
P := P - 1;
end if;
end if;
-- Now find first character of the previous line
while P > Sfirst
and then Src (P - 1) /= LF
and then Src (P - 1) /= CR
loop
P := P - 1;
end loop;
end Backup_Line;
---------------------------
-- Build_Location_String --
---------------------------
procedure Build_Location_String (Loc : Source_Ptr) is
Ptr : Source_Ptr;
begin
-- Loop through instantiations
Ptr := Loc;
loop
Get_Name_String_And_Append
(Reference_Name (Get_Source_File_Index (Ptr)));
Add_Char_To_Name_Buffer (':');
Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Ptr)));
Ptr := Instantiation_Location (Ptr);
exit when Ptr = No_Location;
Add_Str_To_Name_Buffer (" instantiated at ");
end loop;
Name_Buffer (Name_Len + 1) := NUL;
return;
end Build_Location_String;
function Build_Location_String (Loc : Source_Ptr) return String is
begin
Name_Len := 0;
Build_Location_String (Loc);
return Name_Buffer (1 .. Name_Len);
end Build_Location_String;
-----------------------
-- Get_Column_Number --
-----------------------
function Get_Column_Number (P : Source_Ptr) return Column_Number is
S : Source_Ptr;
C : Column_Number;
Sindex : Source_File_Index;
Src : Source_Buffer_Ptr;
begin
-- If the input source pointer is not a meaningful value then return
-- at once with column number 1. This can happen for a file not found
-- condition for a file loaded indirectly by RTE, and also perhaps on
-- some unknown internal error conditions. In either case we certainly
-- don't want to blow up.
if P < 1 then
return 1;
else
Sindex := Get_Source_File_Index (P);
Src := Source_File.Table (Sindex).Source_Text;
S := Line_Start (P);
C := 1;
while S < P loop
if Src (S) = HT then
C := (C - 1) / 8 * 8 + (8 + 1);
else
C := C + 1;
end if;
S := S + 1;
end loop;
return C;
end if;
end Get_Column_Number;
-----------------------------
-- Get_Logical_Line_Number --
-----------------------------
function Get_Logical_Line_Number
(P : Source_Ptr) return Logical_Line_Number
is
SFR : Source_File_Record
renames Source_File.Table (Get_Source_File_Index (P));
L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
begin
if SFR.Num_SRef_Pragmas = 0 then
return Logical_Line_Number (L);
else
return SFR.Logical_Lines_Table (L);
end if;
end Get_Logical_Line_Number;
---------------------------------
-- Get_Logical_Line_Number_Img --
---------------------------------
function Get_Logical_Line_Number_Img
(P : Source_Ptr) return String
is
begin
Name_Len := 0;
Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P)));
return Name_Buffer (1 .. Name_Len);
end Get_Logical_Line_Number_Img;
------------------------------
-- Get_Physical_Line_Number --
------------------------------
function Get_Physical_Line_Number
(P : Source_Ptr) return Physical_Line_Number
is
Sfile : Source_File_Index;
Table : Lines_Table_Ptr;
Lo : Physical_Line_Number;
Hi : Physical_Line_Number;
Mid : Physical_Line_Number;
Loc : Source_Ptr;
begin
-- If the input source pointer is not a meaningful value then return
-- at once with line number 1. This can happen for a file not found
-- condition for a file loaded indirectly by RTE, and also perhaps on
-- some unknown internal error conditions. In either case we certainly
-- don't want to blow up.
if P < 1 then
return 1;
-- Otherwise we can do the binary search
else
Sfile := Get_Source_File_Index (P);
Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
Table := Source_File.Table (Sfile).Lines_Table;
Lo := 1;
Hi := Source_File.Table (Sfile).Last_Source_Line;
loop
Mid := (Lo + Hi) / 2;
if Loc < Table (Mid) then
Hi := Mid - 1;
else -- Loc >= Table (Mid)
if Mid = Hi or else
Loc < Table (Mid + 1)
then
return Mid;
else
Lo := Mid + 1;
end if;
end if;
end loop;
end if;
end Get_Physical_Line_Number;
---------------------------
-- Get_Source_File_Index --
---------------------------
Source_Cache_First : Source_Ptr := 1;
Source_Cache_Last : Source_Ptr := 0;
-- Records the First and Last subscript values for the most recently
-- referenced entry in the source table, to optimize the common case of
-- repeated references to the same entry. The initial values force an
-- initial search to set the cache value.
Source_Cache_Index : Source_File_Index := No_Source_File;
-- Contains the index of the entry corresponding to Source_Cache
function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
begin
if S in Source_Cache_First .. Source_Cache_Last then
return Source_Cache_Index;
else
pragma Assert (Source_File_Index_Table (Int (S) / Chunk_Size)
/=
No_Source_File);
for J in Source_File_Index_Table (Int (S) / Chunk_Size)
.. Source_File.Last
loop
if S in Source_File.Table (J).Source_First ..
Source_File.Table (J).Source_Last
then
Source_Cache_Index := J;
Source_Cache_First :=
Source_File.Table (Source_Cache_Index).Source_First;
Source_Cache_Last :=
Source_File.Table (Source_Cache_Index).Source_Last;
return Source_Cache_Index;
end if;
end loop;
end if;
-- We must find a matching entry in the above loop!
raise Program_Error;
end Get_Source_File_Index;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Source_Cache_First := 1;
Source_Cache_Last := 0;
Source_Cache_Index := No_Source_File;
Source_gnat_adc := No_Source_File;
First_Time_Around := True;
Source_File.Init;
end Initialize;
-------------------------
-- Instantiation_Depth --
-------------------------
function Instantiation_Depth (S : Source_Ptr) return Nat is
Sind : Source_File_Index;
Sval : Source_Ptr;
Depth : Nat;
begin
Sval := S;
Depth := 0;
loop
Sind := Get_Source_File_Index (Sval);
Sval := Instantiation (Sind);
exit when Sval = No_Location;
Depth := Depth + 1;
end loop;
return Depth;
end Instantiation_Depth;
----------------------------
-- Instantiation_Location --
----------------------------
function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
begin
return Instantiation (Get_Source_File_Index (S));
end Instantiation_Location;
----------------------
-- Last_Source_File --
----------------------
function Last_Source_File return Source_File_Index is
begin
return Source_File.Last;
end Last_Source_File;
----------------
-- Line_Start --
----------------
function Line_Start (P : Source_Ptr) return Source_Ptr is
Sindex : constant Source_File_Index := Get_Source_File_Index (P);
Src : constant Source_Buffer_Ptr :=
Source_File.Table (Sindex).Source_Text;
Sfirst : constant Source_Ptr :=
Source_File.Table (Sindex).Source_First;
S : Source_Ptr;
begin
S := P;
while S > Sfirst
and then Src (S - 1) /= CR
and then Src (S - 1) /= LF
loop
S := S - 1;
end loop;
return S;
end Line_Start;
function Line_Start
(L : Physical_Line_Number;
S : Source_File_Index) return Source_Ptr
is
begin
return Source_File.Table (S).Lines_Table (L);
end Line_Start;
----------
-- Lock --
----------
procedure Lock is
begin
Source_File.Locked := True;
Source_File.Release;
end Lock;
----------------------
-- Num_Source_Files --
----------------------
function Num_Source_Files return Nat is
begin
return Int (Source_File.Last) - Int (Source_File.First) + 1;
end Num_Source_Files;
----------------------
-- Num_Source_Lines --
----------------------
function Num_Source_Lines (S : Source_File_Index) return Nat is
begin
return Nat (Source_File.Table (S).Last_Source_Line);
end Num_Source_Lines;
-----------------------
-- Original_Location --
-----------------------
function Original_Location (S : Source_Ptr) return Source_Ptr is
Sindex : Source_File_Index;
Tindex : Source_File_Index;
begin
if S <= No_Location then
return S;
else
Sindex := Get_Source_File_Index (S);
if Instantiation (Sindex) = No_Location then
return S;
else
Tindex := Template (Sindex);
while Instantiation (Tindex) /= No_Location loop
Tindex := Template (Tindex);
end loop;
return S - Source_First (Sindex) + Source_First (Tindex);
end if;
end if;
end Original_Location;
-------------------------
-- Physical_To_Logical --
-------------------------
function Physical_To_Logical
(Line : Physical_Line_Number;
S : Source_File_Index) return Logical_Line_Number
is
SFR : Source_File_Record renames Source_File.Table (S);
begin
if SFR.Num_SRef_Pragmas = 0 then
return Logical_Line_Number (Line);
else
return SFR.Logical_Lines_Table (Line);
end if;
end Physical_To_Logical;
--------------------------------
-- Register_Source_Ref_Pragma --
--------------------------------
procedure Register_Source_Ref_Pragma
(File_Name : File_Name_Type;
Stripped_File_Name : File_Name_Type;
Mapped_Line : Nat;
Line_After_Pragma : Physical_Line_Number)
is
subtype size_t is Memory.size_t;
SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
ML : Logical_Line_Number;
begin
if File_Name /= No_File then
SFR.Reference_Name := Stripped_File_Name;
SFR.Full_Ref_Name := File_Name;
if not Debug_Generated_Code then
SFR.Debug_Source_Name := Stripped_File_Name;
SFR.Full_Debug_Name := File_Name;
end if;
SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
end if;
if SFR.Num_SRef_Pragmas = 1 then
SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
end if;
if SFR.Logical_Lines_Table = null then
SFR.Logical_Lines_Table := To_Pointer
(Memory.Alloc
(size_t (SFR.Lines_Table_Max *
Logical_Lines_Table_Type'Component_Size /
Storage_Unit)));
end if;
SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
ML := Logical_Line_Number (Mapped_Line);
for J in Line_After_Pragma .. SFR.Last_Source_Line loop
SFR.Logical_Lines_Table (J) := ML;
ML := ML + 1;
end loop;
end Register_Source_Ref_Pragma;
---------------------------------
-- Set_Source_File_Index_Table --
---------------------------------
procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
Ind : Int;
SP : Source_Ptr;
SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
begin
SP := (Source_File.Table (Xnew).Source_First + Chunk_Size - 1)
/ Chunk_Size * Chunk_Size;
Ind := Int (SP) / Chunk_Size;
while SP <= SL loop
Source_File_Index_Table (Ind) := Xnew;
SP := SP + Chunk_Size;
Ind := Ind + 1;
end loop;
end Set_Source_File_Index_Table;
---------------------------
-- Skip_Line_Terminators --
---------------------------
procedure Skip_Line_Terminators
(P : in out Source_Ptr;
Physical : out Boolean)
is
Chr : constant Character := Source (P);
begin
if Chr = CR then
if Source (P + 1) = LF then
P := P + 2;
else
P := P + 1;
end if;
elsif Chr = LF then
P := P + 1;
elsif Chr = FF or else Chr = VT then
P := P + 1;
Physical := False;
return;
-- Otherwise we have a wide character
else
Skip_Wide (Source, P);
end if;
-- Fall through in the physical line terminator case. First deal with
-- making a possible entry into the lines table if one is needed.
-- Note: we are dealing with a real source file here, this cannot be
-- the instantiation case, so we need not worry about Sloc adjustment.
declare
S : Source_File_Record
renames Source_File.Table (Current_Source_File);
begin
Physical := True;
-- Make entry in lines table if not already made (in some scan backup
-- cases, we will be rescanning previously scanned source, so the
-- entry may have already been made on the previous forward scan).
if Source (P) /= EOF
and then P > S.Lines_Table (S.Last_Source_Line)
then
Add_Line_Tables_Entry (S, P);
end if;
end;
end Skip_Line_Terminators;
----------------
-- Sloc_Range --
----------------
procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
function Process (N : Node_Id) return Traverse_Result;
-- Process function for traversing the node tree
procedure Traverse is new Traverse_Proc (Process);
-------------
-- Process --
-------------
function Process (N : Node_Id) return Traverse_Result is
begin
if Sloc (N) < Min then
if Sloc (N) > No_Location then
Min := Sloc (N);
end if;
elsif Sloc (N) > Max then
if Sloc (N) > No_Location then
Max := Sloc (N);
end if;
end if;
return OK;
end Process;
-- Start of processing for Sloc_Range
begin
Min := Sloc (N);
Max := Sloc (N);
Traverse (N);
end Sloc_Range;
-------------------
-- Source_Offset --
-------------------
function Source_Offset (S : Source_Ptr) return Nat is
Sindex : constant Source_File_Index := Get_Source_File_Index (S);
Sfirst : constant Source_Ptr :=
Source_File.Table (Sindex).Source_First;
begin
return Nat (S - Sfirst);
end Source_Offset;
------------------------
-- Top_Level_Location --
------------------------
function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
Oldloc : Source_Ptr;
Newloc : Source_Ptr;
begin
Newloc := S;
loop
Oldloc := Newloc;
Newloc := Instantiation_Location (Oldloc);
exit when Newloc = No_Location;
end loop;
return Oldloc;
end Top_Level_Location;
---------------
-- Tree_Read --
---------------
procedure Tree_Read is
begin
-- First we must free any old source buffer pointers
if not First_Time_Around then
for J in Source_File.First .. Source_File.Last loop
declare
S : Source_File_Record renames Source_File.Table (J);
procedure Free_Ptr is new Unchecked_Deallocation
(Big_Source_Buffer, Source_Buffer_Ptr);
pragma Warnings (Off);
-- This unchecked conversion is aliasing safe, since it is not
-- used to create improperly aliased pointer values.
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
pragma Warnings (On);
Tmp1 : Source_Buffer_Ptr;
begin
if S.Instantiation /= No_Location then
null;
else
-- Free the buffer, we use Free here, because we used malloc
-- or realloc directly to allocate the tables. That is
-- because we were playing the big array trick.
-- We have to recreate a proper pointer to the actual array
-- from the zero origin pointer stored in the source table.
Tmp1 :=
To_Source_Buffer_Ptr
(S.Source_Text (S.Source_First)'Address);
Free_Ptr (Tmp1);
if S.Lines_Table /= null then
Memory.Free (To_Address (S.Lines_Table));
S.Lines_Table := null;
end if;
if S.Logical_Lines_Table /= null then
Memory.Free (To_Address (S.Logical_Lines_Table));
S.Logical_Lines_Table := null;
end if;
end if;
end;
end loop;
end if;
-- Reset source cache pointers to force new read
Source_Cache_First := 1;
Source_Cache_Last := 0;
-- Read in source file table
Source_File.Tree_Read;
-- The pointers we read in there for the source buffer and lines
-- table pointers are junk. We now read in the actual data that
-- is referenced by these two fields.
for J in Source_File.First .. Source_File.Last loop
declare
S : Source_File_Record renames Source_File.Table (J);
begin
-- For the instantiation case, we do not read in any data. Instead
-- we share the data for the generic template entry. Since the
-- template always occurs first, we can safely refer to its data.
if S.Instantiation /= No_Location then
declare
ST : Source_File_Record renames
Source_File.Table (S.Template);
begin
-- The lines tables are copied from the template entry
S.Lines_Table :=
Source_File.Table (S.Template).Lines_Table;
S.Logical_Lines_Table :=
Source_File.Table (S.Template).Logical_Lines_Table;
-- In the case of the source table pointer, we share the
-- same data as the generic template, but the virtual origin
-- is adjusted. For example, if the first subscript of the
-- template is 100, and that of the instantiation is 200,
-- then the instantiation pointer is obtained by subtracting
-- 100 from the template pointer.
declare
pragma Suppress (All_Checks);
pragma Warnings (Off);
-- This unchecked conversion is aliasing safe since it
-- not used to create improperly aliased pointer values.
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
pragma Warnings (On);
begin
S.Source_Text :=
To_Source_Buffer_Ptr
(ST.Source_Text
(ST.Source_First - S.Source_First)'Address);
end;
end;
-- Normal case (non-instantiation)
else
First_Time_Around := False;
S.Lines_Table := null;
S.Logical_Lines_Table := null;
Alloc_Line_Tables (S, Int (S.Last_Source_Line));
for J in 1 .. S.Last_Source_Line loop
Tree_Read_Int (Int (S.Lines_Table (J)));
end loop;
if S.Num_SRef_Pragmas /= 0 then
for J in 1 .. S.Last_Source_Line loop
Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
end loop;
end if;
-- Allocate source buffer and read in the data and then set the
-- virtual origin to point to the logical zero'th element. This
-- address must be computed with subscript checks turned off.
declare
subtype B is Text_Buffer (S.Source_First .. S.Source_Last);
type Text_Buffer_Ptr is access B;
T : Text_Buffer_Ptr;
pragma Suppress (All_Checks);
pragma Warnings (Off);
-- This unchecked conversion is aliasing safe, since it is
-- never used to create improperly aliased pointer values.
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
pragma Warnings (On);
begin
T := new B;
Tree_Read_Data (T (S.Source_First)'Address,
Int (S.Source_Last) - Int (S.Source_First) + 1);
S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address);
end;
end if;
end;
Set_Source_File_Index_Table (J);
end loop;
end Tree_Read;
----------------
-- Tree_Write --
----------------
procedure Tree_Write is
begin
Source_File.Tree_Write;
-- The pointers we wrote out there for the source buffer and lines
-- table pointers are junk, we now write out the actual data that
-- is referenced by these two fields.
for J in Source_File.First .. Source_File.Last loop
declare
S : Source_File_Record renames Source_File.Table (J);
begin
-- For instantiations, there is nothing to do, since the data is
-- shared with the generic template. When the tree is read, the
-- pointers must be set, but no extra data needs to be written.
if S.Instantiation /= No_Location then
null;
-- For the normal case, write out the data of the tables
else
-- Lines table
for J in 1 .. S.Last_Source_Line loop
Tree_Write_Int (Int (S.Lines_Table (J)));
end loop;
-- Logical lines table if present
if S.Num_SRef_Pragmas /= 0 then
for J in 1 .. S.Last_Source_Line loop
Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
end loop;
end if;
-- Source buffer
Tree_Write_Data
(S.Source_Text (S.Source_First)'Address,
Int (S.Source_Last) - Int (S.Source_First) + 1);
end if;
end;
end loop;
end Tree_Write;
--------------------
-- Write_Location --
--------------------
procedure Write_Location (P : Source_Ptr) is
begin
if P = No_Location then
Write_Str ("<no location>");
elsif P <= Standard_Location then
Write_Str ("<standard location>");
else
declare
SI : constant Source_File_Index := Get_Source_File_Index (P);
begin
Write_Name (Debug_Source_Name (SI));
Write_Char (':');
Write_Int (Int (Get_Logical_Line_Number (P)));
Write_Char (':');
Write_Int (Int (Get_Column_Number (P)));
if Instantiation (SI) /= No_Location then
Write_Str (" [");
Write_Location (Instantiation (SI));
Write_Char (']');
end if;
end;
end if;
end Write_Location;
----------------------
-- Write_Time_Stamp --
----------------------
procedure Write_Time_Stamp (S : Source_File_Index) is
T : constant Time_Stamp_Type := Time_Stamp (S);
P : Natural;
begin
if T (1) = '9' then
Write_Str ("19");
P := 0;
else
Write_Char (T (1));
Write_Char (T (2));
P := 2;
end if;
Write_Char (T (P + 1));
Write_Char (T (P + 2));
Write_Char ('-');
Write_Char (T (P + 3));
Write_Char (T (P + 4));
Write_Char ('-');
Write_Char (T (P + 5));
Write_Char (T (P + 6));
Write_Char (' ');
Write_Char (T (P + 7));
Write_Char (T (P + 8));
Write_Char (':');
Write_Char (T (P + 9));
Write_Char (T (P + 10));
Write_Char (':');
Write_Char (T (P + 11));
Write_Char (T (P + 12));
end Write_Time_Stamp;
----------------------------------------------
-- Access Subprograms for Source File Table --
----------------------------------------------
function Debug_Source_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Debug_Source_Name;
end Debug_Source_Name;
function File_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).File_Name;
end File_Name;
function File_Type (S : SFI) return Type_Of_File is
begin
return Source_File.Table (S).File_Type;
end File_Type;
function First_Mapped_Line (S : SFI) return Logical_Line_Number is
begin
return Source_File.Table (S).First_Mapped_Line;
end First_Mapped_Line;
function Full_Debug_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Full_Debug_Name;
end Full_Debug_Name;
function Full_File_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Full_File_Name;
end Full_File_Name;
function Full_Ref_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Full_Ref_Name;
end Full_Ref_Name;
function Identifier_Casing (S : SFI) return Casing_Type is
begin
return Source_File.Table (S).Identifier_Casing;
end Identifier_Casing;
function Inlined_Body (S : SFI) return Boolean is
begin
return Source_File.Table (S).Inlined_Body;
end Inlined_Body;
function Instantiation (S : SFI) return Source_Ptr is
begin
return Source_File.Table (S).Instantiation;
end Instantiation;
function Keyword_Casing (S : SFI) return Casing_Type is
begin
return Source_File.Table (S).Keyword_Casing;
end Keyword_Casing;
function Last_Source_Line (S : SFI) return Physical_Line_Number is
begin
return Source_File.Table (S).Last_Source_Line;
end Last_Source_Line;
function License (S : SFI) return License_Type is
begin
return Source_File.Table (S).License;
end License;
function Num_SRef_Pragmas (S : SFI) return Nat is
begin
return Source_File.Table (S).Num_SRef_Pragmas;
end Num_SRef_Pragmas;
function Reference_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Reference_Name;
end Reference_Name;
function Source_Checksum (S : SFI) return Word is
begin
return Source_File.Table (S).Source_Checksum;
end Source_Checksum;
function Source_First (S : SFI) return Source_Ptr is
begin
if S = Internal_Source_File then
return Internal_Source'First;
else
return Source_File.Table (S).Source_First;
end if;
end Source_First;
function Source_Last (S : SFI) return Source_Ptr is
begin
if S = Internal_Source_File then
return Internal_Source'Last;
else
return Source_File.Table (S).Source_Last;
end if;
end Source_Last;
function Source_Text (S : SFI) return Source_Buffer_Ptr is
begin
if S = Internal_Source_File then
return Internal_Source_Ptr;
else
return Source_File.Table (S).Source_Text;
end if;
end Source_Text;
function Template (S : SFI) return SFI is
begin
return Source_File.Table (S).Template;
end Template;
function Time_Stamp (S : SFI) return Time_Stamp_Type is
begin
return Source_File.Table (S).Time_Stamp;
end Time_Stamp;
function Unit (S : SFI) return Unit_Number_Type is
begin
return Source_File.Table (S).Unit;
end Unit;
------------------------------------------
-- Set Procedures for Source File Table --
------------------------------------------
procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
begin
Source_File.Table (S).Identifier_Casing := C;
end Set_Identifier_Casing;
procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
begin
Source_File.Table (S).Keyword_Casing := C;
end Set_Keyword_Casing;
procedure Set_License (S : SFI; L : License_Type) is
begin
Source_File.Table (S).License := L;
end Set_License;
procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
begin
Source_File.Table (S).Unit := U;
end Set_Unit;
----------------------
-- Trim_Lines_Table --
----------------------
procedure Trim_Lines_Table (S : Source_File_Index) is
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 := To_Pointer
(Memory.Realloc
(To_Address (Source_File.Table (S).Lines_Table),
Memory.size_t
(Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
end Trim_Lines_Table;
------------
-- Unlock --
------------
procedure Unlock is
begin
Source_File.Locked := False;
Source_File.Release;
end Unlock;
--------
-- wl --
--------
procedure wl (P : Source_Ptr) is
begin
Write_Location (P);
Write_Eol;
end wl;
end Sinput;
Reference in New Issue View Git Blame Copy Permalink