-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
+-- 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. 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. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- 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 Debug; use Debug;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Tree_IO; use Tree_IO;
-with System; use System;
+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;
-- 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_Pointer is
new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
+ pragma Warnings (On);
+
---------------------------
-- Add_Line_Tables_Entry --
---------------------------
LL : Physical_Line_Number;
begin
- -- Reallocate the lines tables if necessary.
+ -- 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
Ptr : Source_Ptr;
begin
- Name_Len := 0;
-
-- Loop through instantiations
Ptr := Loc;
-----------------------------
function Get_Logical_Line_Number
- (P : Source_Ptr)
- return Logical_Line_Number
+ (P : Source_Ptr) return Logical_Line_Number
is
SFR : Source_File_Record
renames Source_File.Table (Get_Source_File_Index (P));
------------------------------
function Get_Physical_Line_Number
- (P : Source_Ptr)
- return Physical_Line_Number
+ (P : Source_Ptr) return Physical_Line_Number
is
Sfile : Source_File_Index;
Table : Lines_Table_Ptr;
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.
+ -- 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
+ 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
- for J in 1 .. Source_File.Last loop
+ 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
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;
begin
S := P;
-
while S > Sfirst
and then Src (S - 1) /= CR
and then Src (S - 1) /= LF
end Line_Start;
function Line_Start
- (L : Physical_Line_Number;
- S : Source_File_Index)
- return Source_Ptr
+ (L : Physical_Line_Number;
+ S : Source_File_Index) return Source_Ptr
is
begin
return Source_File.Table (S).Lines_Table (L);
function Physical_To_Logical
(Line : Physical_Line_Number;
- S : Source_File_Index)
- return Logical_Line_Number
+ S : Source_File_Index) return Logical_Line_Number
is
SFR : Source_File_Record renames Source_File.Table (S);
--------------------------------
procedure Register_Source_Ref_Pragma
- (File_Name : Name_Id;
- Stripped_File_Name : Name_Id;
+ (File_Name : File_Name_Type;
+ Stripped_File_Name : File_Name_Type;
Mapped_Line : Nat;
Line_After_Pragma : Physical_Line_Number)
is
ML : Logical_Line_Number;
begin
- if File_Name /= No_Name then
- SFR.Full_Ref_Name := File_Name;
+ 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 := File_Name;
+ SFR.Debug_Source_Name := Stripped_File_Name;
+ SFR.Full_Debug_Name := File_Name;
end if;
- SFR.Reference_Name := Stripped_File_Name;
SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
end if;
end loop;
end Register_Source_Ref_Pragma;
- ---------------------------
- -- Skip_Line_Terminators --
- ---------------------------
+ ---------------------------------
+ -- Set_Source_File_Index_Table --
+ ---------------------------------
- -- There are two distinct concepts of line terminator in GNAT
+ 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;
- -- A logical line terminator is what corresponds to the "end of a line"
- -- as described in RM 2.2 (13). Any of the characters FF, LF, CR or VT
- -- acts as an end of logical line in this sense, and it is essentially
- -- irrelevant whether one or more appears in sequence (since if a
- -- sequence of such characters is regarded as separate ends of line,
- -- then the intervening logical lines are null in any case).
-
- -- A physical line terminator is a sequence of format effectors that
- -- is treated as ending a physical line. Physical lines have no Ada
- -- semantic significance, but they are significant for error reporting
- -- purposes, since errors are identified by line and column location.
+ 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;
- -- In GNAT, a physical line is ended by any of the sequences LF, CR/LF,
- -- CR or LF/CR. LF is used in typical Unix systems, CR/LF in DOS systems,
- -- and CR alone in System 7. We don't know of any system using LF/CR, but
- -- it seems reasonable to include this case for consistency. In addition,
- -- we recognize any of these sequences in any of the operating systems,
- -- for better behavior in treating foreign files (e.g. a Unix file with
- -- LF terminators transferred to a DOS system).
+ ---------------------------
+ -- Skip_Line_Terminators --
+ ---------------------------
procedure Skip_Line_Terminators
(P : in out Source_Ptr;
Physical : out Boolean)
is
- begin
- pragma Assert (Source (P) in Line_Terminator);
+ Chr : constant Character := Source (P);
- if Source (P) = CR then
+ begin
+ if Chr = CR then
if Source (P + 1) = LF then
P := P + 2;
else
P := P + 1;
end if;
- elsif Source (P) = LF then
- if Source (P + 1) = CR then
- P := P + 2;
- else
- P := P + 1;
- end if;
+ elsif Chr = LF then
+ P := P + 1;
- else -- Source (P) = FF or else Source (P) = VT
+ 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
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 --
-------------------
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;
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
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 need to
+ -- suppress the warning for freeing from an empty pool!
+
-- 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);
+ pragma Warnings (Off);
Free_Ptr (Tmp1);
-
- -- Note: we are using free here, because we used malloc
- -- or realloc directly to allocate the tables. That is
- -- because we were playing the big array trick.
+ pragma Warnings (On);
if S.Lines_Table /= null then
Memory.Free (To_Address (S.Lines_Table));
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 safetly refer to its data.
+ -- template always occurs first, we can safely refer to its data.
if S.Instantiation /= No_Location then
declare
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
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;
end;
end if;
end;
+
+ Set_Source_File_Index_Table (J);
end loop;
end Tree_Read;
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;
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;
function Source_First (S : SFI) return Source_Ptr is
begin
- return Source_File.Table (S).Source_First;
+ 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
- return Source_File.Table (S).Source_Last;
+ 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
- return Source_File.Table (S).Source_Text;
+ 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
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 --
------------------------------------------
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 --
----------------------
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 --
--------
OSDN Git Service
