83dcc2bd35
gcc/ada/ * atree.ads: Make Default_Node a constant. Remove the modification of Comes_From_Source, and use a separate flag for that. Change Sloc to 0; it always overwritten, and never left as the No_Location value. (Print_Statistics): Move to spec so we can call it from gnat1drv. (Num_Nodes): Rename to clarify that this is approximate. Correct comment: nodes and entities are never deleted, the count is never decremented, and this is not used by Xref. (Initialize): Correct comment: Error_List is not created here. Other minor naming and comment changes. * atree.adb (Extend_Node, New_Copy, New_Entity, New_Node): Streamline these. Simplify and improve efficiency. Move code from Allocate_Initialize_Node to these, where it can be executed unconditionally. Take advantage of automatic zeroing of the Nodes table. (Allocate_Initialize_Node): Remove this. It was an efficiency bottleneck, and somewhat complicated, because it was called from 4 places, and had all sorts of conditionals to check where it was called from. Better to move most of that code to the call sites, where it can be executed (or not) unconditionally. (Allocate_New_Node): New procedure to partly replace Allocate_Initialize_Node (called from just 2 of those 4 places). (Comes_From_Source_Default): New flag written/read by Set_Comes_From_Source_Default/Get_Comes_From_Source_Default. This allows us to make Default_Node into a constant with all-zeros value. (Set_Paren_Count_Of_Copy): New procedure to avoid duplicated code. (Report): New procedure to encapsulate the call to the reporting procedure. (Atree_Private_Part): We now need a body for this package, to contain package body Nodes. (Approx_Num_Nodes_And_Entities): Was Num_Nodes. For efficiency, compute the answer from Nodes.Last. That way we don't need to increment a counter on every node creation. Other minor naming and comment changes. * gnat1drv.adb: Call Atree.Print_Statistics if -gnatd.A switch was given. Add comment documenting the new order dependency (we must process the command line before calling Atree.Initialize). * debug.adb: Document -gnatd.A. * einfo.adb, sinfo.adb: Remove useless Style_Checks pragmas. * nlists.ads (Allocate_List_Tables): Inline makes node creation a little faster. * nlists.adb (Initialize): Remove local constant E, which didn't seem to add clarity. * treepr.adb (Print_Init): Use renamed Approx_Num_Nodes_And_Entities function. * types.ads: Change the Low and High bounds as described above. * types.h: Change Low and High bounds to match types.ads. * sem_ch8.adb, namet.adb, namet.ads: Move the computation of Last_Name_Id from sem_ch8 to namet, and correct it to not assume Name_Ids are positive. * ali.adb, ali-util.adb, bindo-writers.adb, exp_dist.adb, fmap.adb, fname-uf.adb, osint.adb: Fix various hash functions to avoid assuming the various ranges are positive. Note that "mod" returns a nonnegative result when the second operand is positive. "rem" can return negative values in that case (in particular, if the first operand is negative, which it now is). * switch-c.adb: Allow switch -gnaten to control the value of Nodes_Size_In_Meg. * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Remove traling whitespaces. * opt.ads (Nodes_Size_In_Meg): New Variable.
532 lines
16 KiB
Ada
532 lines
16 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- F M A P --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2001-2020, 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. 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 COPYING3. If not, go to --
|
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Opt; use Opt;
|
|
with Osint; use Osint;
|
|
with Output; use Output;
|
|
with Table;
|
|
with Types; use Types;
|
|
|
|
pragma Warnings (Off);
|
|
-- This package is used also by gnatcoll
|
|
with System.OS_Lib; use System.OS_Lib;
|
|
pragma Warnings (On);
|
|
|
|
with Unchecked_Conversion;
|
|
|
|
with GNAT.HTable;
|
|
|
|
package body Fmap is
|
|
|
|
No_Mapping_File : Boolean := False;
|
|
-- Set to True when the specified mapping file cannot be read in
|
|
-- procedure Initialize, so that no attempt is made to open the mapping
|
|
-- file in procedure Update_Mapping_File.
|
|
|
|
Max_Buffer : constant := 1_500;
|
|
Buffer : String (1 .. Max_Buffer);
|
|
-- Used to buffer output when writing to a new mapping file
|
|
|
|
Buffer_Last : Natural := 0;
|
|
-- Index of last valid character in Buffer
|
|
|
|
type Mapping is record
|
|
Uname : Unit_Name_Type;
|
|
Fname : File_Name_Type;
|
|
end record;
|
|
|
|
package File_Mapping is new Table.Table (
|
|
Table_Component_Type => Mapping,
|
|
Table_Index_Type => Int,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => 1_000,
|
|
Table_Increment => 1_000,
|
|
Table_Name => "Fmap.File_Mapping");
|
|
-- Mapping table to map unit names to file names
|
|
|
|
package Path_Mapping is new Table.Table (
|
|
Table_Component_Type => Mapping,
|
|
Table_Index_Type => Int,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => 1_000,
|
|
Table_Increment => 1_000,
|
|
Table_Name => "Fmap.Path_Mapping");
|
|
-- Mapping table to map file names to path names
|
|
|
|
type Header_Num is range 0 .. 1_000;
|
|
|
|
function Hash (F : Unit_Name_Type) return Header_Num;
|
|
-- Function used to compute hash of unit name
|
|
|
|
No_Entry : constant Int := -1;
|
|
-- Signals no entry in following table
|
|
|
|
package Unit_Hash_Table is new GNAT.HTable.Simple_HTable (
|
|
Header_Num => Header_Num,
|
|
Element => Int,
|
|
No_Element => No_Entry,
|
|
Key => Unit_Name_Type,
|
|
Hash => Hash,
|
|
Equal => "=");
|
|
-- Hash table to map unit names to file names. Used in conjunction with
|
|
-- table File_Mapping above.
|
|
|
|
function Hash (F : File_Name_Type) return Header_Num;
|
|
-- Function used to compute hash of file name
|
|
|
|
package File_Hash_Table is new GNAT.HTable.Simple_HTable (
|
|
Header_Num => Header_Num,
|
|
Element => Int,
|
|
No_Element => No_Entry,
|
|
Key => File_Name_Type,
|
|
Hash => Hash,
|
|
Equal => "=");
|
|
-- Hash table to map file names to path names. Used in conjunction with
|
|
-- table Path_Mapping above.
|
|
|
|
Last_In_Table : Int := 0;
|
|
|
|
package Forbidden_Names is new GNAT.HTable.Simple_HTable (
|
|
Header_Num => Header_Num,
|
|
Element => Boolean,
|
|
No_Element => False,
|
|
Key => File_Name_Type,
|
|
Hash => Hash,
|
|
Equal => "=");
|
|
|
|
-----------------------------
|
|
-- Add_Forbidden_File_Name --
|
|
-----------------------------
|
|
|
|
procedure Add_Forbidden_File_Name (Name : File_Name_Type) is
|
|
begin
|
|
Forbidden_Names.Set (Name, True);
|
|
end Add_Forbidden_File_Name;
|
|
|
|
---------------------
|
|
-- Add_To_File_Map --
|
|
---------------------
|
|
|
|
procedure Add_To_File_Map
|
|
(Unit_Name : Unit_Name_Type;
|
|
File_Name : File_Name_Type;
|
|
Path_Name : File_Name_Type)
|
|
is
|
|
Unit_Entry : constant Int := Unit_Hash_Table.Get (Unit_Name);
|
|
File_Entry : constant Int := File_Hash_Table.Get (File_Name);
|
|
begin
|
|
if Unit_Entry = No_Entry or else
|
|
File_Mapping.Table (Unit_Entry).Fname /= File_Name
|
|
then
|
|
File_Mapping.Increment_Last;
|
|
Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last);
|
|
File_Mapping.Table (File_Mapping.Last) :=
|
|
(Uname => Unit_Name, Fname => File_Name);
|
|
end if;
|
|
|
|
if File_Entry = No_Entry or else
|
|
Path_Mapping.Table (File_Entry).Fname /= Path_Name
|
|
then
|
|
Path_Mapping.Increment_Last;
|
|
File_Hash_Table.Set (File_Name, Path_Mapping.Last);
|
|
Path_Mapping.Table (Path_Mapping.Last) :=
|
|
(Uname => Unit_Name, Fname => Path_Name);
|
|
end if;
|
|
end Add_To_File_Map;
|
|
|
|
----------
|
|
-- Hash --
|
|
----------
|
|
|
|
function Hash (F : File_Name_Type) return Header_Num is
|
|
begin
|
|
return Header_Num (Int (F) mod Header_Num'Range_Length);
|
|
end Hash;
|
|
|
|
function Hash (F : Unit_Name_Type) return Header_Num is
|
|
begin
|
|
return Header_Num (Int (F) mod Header_Num'Range_Length);
|
|
end Hash;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize (File_Name : String) is
|
|
FD : File_Descriptor;
|
|
Src : Source_Buffer_Ptr;
|
|
Hi : Source_Ptr;
|
|
|
|
First : Source_Ptr := 1;
|
|
Last : Source_Ptr := 0;
|
|
|
|
Uname : Unit_Name_Type;
|
|
Fname : File_Name_Type;
|
|
Pname : File_Name_Type;
|
|
|
|
procedure Empty_Tables;
|
|
-- Remove all entries in case of incorrect mapping file
|
|
|
|
function Find_File_Name return File_Name_Type;
|
|
-- Return Error_File_Name if the name buffer contains "/", otherwise
|
|
-- call Name_Find. "/" is the path name in the mapping file to indicate
|
|
-- that a source has been suppressed, and thus should not be found by
|
|
-- the compiler.
|
|
|
|
function Find_Unit_Name return Unit_Name_Type;
|
|
-- Return the unit name in the name buffer. Return Error_Unit_Name if
|
|
-- the name buffer contains "/".
|
|
|
|
procedure Get_Line;
|
|
-- Get a line from the mapping file, where a line is Src (First .. Last)
|
|
|
|
procedure Report_Truncated;
|
|
-- Report a warning when the mapping file is truncated
|
|
-- (number of lines is not a multiple of 3).
|
|
|
|
------------------
|
|
-- Empty_Tables --
|
|
------------------
|
|
|
|
procedure Empty_Tables is
|
|
begin
|
|
Unit_Hash_Table.Reset;
|
|
File_Hash_Table.Reset;
|
|
Path_Mapping.Set_Last (0);
|
|
File_Mapping.Set_Last (0);
|
|
Last_In_Table := 0;
|
|
end Empty_Tables;
|
|
|
|
--------------------
|
|
-- Find_File_Name --
|
|
--------------------
|
|
|
|
function Find_File_Name return File_Name_Type is
|
|
begin
|
|
if Name_Buffer (1 .. Name_Len) = "/" then
|
|
|
|
-- A path name of "/" is the indication that the source has been
|
|
-- "suppressed". Return Error_File_Name so that the compiler does
|
|
-- not find the source, even if it is in the include path.
|
|
|
|
return Error_File_Name;
|
|
|
|
else
|
|
return Name_Find;
|
|
end if;
|
|
end Find_File_Name;
|
|
|
|
--------------------
|
|
-- Find_Unit_Name --
|
|
--------------------
|
|
|
|
function Find_Unit_Name return Unit_Name_Type is
|
|
begin
|
|
return Unit_Name_Type (Find_File_Name);
|
|
end Find_Unit_Name;
|
|
|
|
--------------
|
|
-- Get_Line --
|
|
--------------
|
|
|
|
procedure Get_Line is
|
|
use ASCII;
|
|
|
|
begin
|
|
First := Last + 1;
|
|
|
|
-- If not at the end of file, skip the end of line
|
|
|
|
while First < Src'Last
|
|
and then (Src (First) = CR
|
|
or else Src (First) = LF
|
|
or else Src (First) = EOF)
|
|
loop
|
|
First := First + 1;
|
|
end loop;
|
|
|
|
-- If not at the end of file, find the end of this new line
|
|
|
|
if First < Src'Last and then Src (First) /= EOF then
|
|
Last := First;
|
|
|
|
while Last < Src'Last
|
|
and then Src (Last + 1) /= CR
|
|
and then Src (Last + 1) /= LF
|
|
and then Src (Last + 1) /= EOF
|
|
loop
|
|
Last := Last + 1;
|
|
end loop;
|
|
|
|
end if;
|
|
end Get_Line;
|
|
|
|
----------------------
|
|
-- Report_Truncated --
|
|
----------------------
|
|
|
|
procedure Report_Truncated is
|
|
begin
|
|
Write_Str ("warning: mapping file """);
|
|
Write_Str (File_Name);
|
|
Write_Line (""" is truncated");
|
|
end Report_Truncated;
|
|
|
|
-- Start of processing for Initialize
|
|
|
|
begin
|
|
Empty_Tables;
|
|
Read_Source_File (Name_Enter (File_Name), 1, Hi, Src, FD, Config);
|
|
|
|
if Null_Source_Buffer_Ptr (Src) then
|
|
if FD = Null_FD then
|
|
Write_Str ("warning: could not locate mapping file """);
|
|
else
|
|
Write_Str ("warning: no read access for mapping file """);
|
|
end if;
|
|
|
|
Write_Str (File_Name);
|
|
Write_Line ("""");
|
|
No_Mapping_File := True;
|
|
|
|
else
|
|
loop
|
|
-- Get the unit name
|
|
|
|
Get_Line;
|
|
|
|
-- Exit if end of file has been reached
|
|
|
|
exit when First > Last;
|
|
|
|
if (Last < First + 2) or else (Src (Last - 1) /= '%')
|
|
or else (Src (Last) /= 's' and then Src (Last) /= 'b')
|
|
then
|
|
Write_Line
|
|
("warning: mapping file """ & File_Name &
|
|
""" is incorrectly formatted");
|
|
Write_Line ("Line = """ & String (Src (First .. Last)) & '"');
|
|
Empty_Tables;
|
|
return;
|
|
end if;
|
|
|
|
Name_Len := Integer (Last - First + 1);
|
|
Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
|
|
Uname := Find_Unit_Name;
|
|
|
|
-- Get the file name
|
|
|
|
Get_Line;
|
|
|
|
-- If end of line has been reached, file is truncated
|
|
|
|
if First > Last then
|
|
Report_Truncated;
|
|
Empty_Tables;
|
|
return;
|
|
end if;
|
|
|
|
Name_Len := Integer (Last - First + 1);
|
|
Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
Fname := Find_File_Name;
|
|
|
|
-- Get the path name
|
|
|
|
Get_Line;
|
|
|
|
-- If end of line has been reached, file is truncated
|
|
|
|
if First > Last then
|
|
Report_Truncated;
|
|
Empty_Tables;
|
|
return;
|
|
end if;
|
|
|
|
Name_Len := Integer (Last - First + 1);
|
|
Name_Buffer (1 .. Name_Len) := String (Src (First .. Last));
|
|
Pname := Find_File_Name;
|
|
|
|
-- Add the mappings for this unit name
|
|
|
|
Add_To_File_Map (Uname, Fname, Pname);
|
|
end loop;
|
|
end if;
|
|
|
|
-- Record the length of the two mapping tables
|
|
|
|
Last_In_Table := File_Mapping.Last;
|
|
end Initialize;
|
|
|
|
----------------------
|
|
-- Mapped_File_Name --
|
|
----------------------
|
|
|
|
function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is
|
|
The_Index : constant Int := Unit_Hash_Table.Get (Unit);
|
|
|
|
begin
|
|
if The_Index = No_Entry then
|
|
return No_File;
|
|
else
|
|
return File_Mapping.Table (The_Index).Fname;
|
|
end if;
|
|
end Mapped_File_Name;
|
|
|
|
----------------------
|
|
-- Mapped_Path_Name --
|
|
----------------------
|
|
|
|
function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is
|
|
Index : Int := No_Entry;
|
|
|
|
begin
|
|
if Forbidden_Names.Get (File) then
|
|
return Error_File_Name;
|
|
end if;
|
|
|
|
Index := File_Hash_Table.Get (File);
|
|
|
|
if Index = No_Entry then
|
|
return No_File;
|
|
else
|
|
return Path_Mapping.Table (Index).Fname;
|
|
end if;
|
|
end Mapped_Path_Name;
|
|
|
|
------------------
|
|
-- Reset_Tables --
|
|
------------------
|
|
|
|
procedure Reset_Tables is
|
|
begin
|
|
File_Mapping.Init;
|
|
Path_Mapping.Init;
|
|
Unit_Hash_Table.Reset;
|
|
File_Hash_Table.Reset;
|
|
Forbidden_Names.Reset;
|
|
Last_In_Table := 0;
|
|
end Reset_Tables;
|
|
|
|
-------------------------
|
|
-- Update_Mapping_File --
|
|
-------------------------
|
|
|
|
procedure Update_Mapping_File (File_Name : String) is
|
|
File : File_Descriptor;
|
|
N_Bytes : Integer;
|
|
|
|
File_Entry : Int;
|
|
|
|
Status : Boolean;
|
|
-- For the call to Close
|
|
|
|
procedure Put_Line (Name : Name_Id);
|
|
-- Put Name as a line in the Mapping File
|
|
|
|
--------------
|
|
-- Put_Line --
|
|
--------------
|
|
|
|
procedure Put_Line (Name : Name_Id) is
|
|
begin
|
|
Get_Name_String (Name);
|
|
|
|
-- If the Buffer is full, write it to the file
|
|
|
|
if Buffer_Last + Name_Len + 1 > Buffer'Last then
|
|
N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
|
|
|
|
if N_Bytes < Buffer_Last then
|
|
Fail ("disk full");
|
|
end if;
|
|
|
|
Buffer_Last := 0;
|
|
end if;
|
|
|
|
-- Add the line to the Buffer
|
|
|
|
Buffer (Buffer_Last + 1 .. Buffer_Last + Name_Len) :=
|
|
Name_Buffer (1 .. Name_Len);
|
|
Buffer_Last := Buffer_Last + Name_Len + 1;
|
|
Buffer (Buffer_Last) := ASCII.LF;
|
|
end Put_Line;
|
|
|
|
-- Start of processing for Update_Mapping_File
|
|
|
|
begin
|
|
-- If the mapping file could not be read, then it will not be possible
|
|
-- to update it.
|
|
|
|
if No_Mapping_File then
|
|
return;
|
|
end if;
|
|
-- Only Update if there are new entries in the mappings
|
|
|
|
if Last_In_Table < File_Mapping.Last then
|
|
|
|
File := Open_Read_Write (Name => File_Name, Fmode => Binary);
|
|
|
|
if File /= Invalid_FD then
|
|
if Last_In_Table > 0 then
|
|
Lseek (File, 0, Seek_End);
|
|
end if;
|
|
|
|
for Unit in Last_In_Table + 1 .. File_Mapping.Last loop
|
|
Put_Line (Name_Id (File_Mapping.Table (Unit).Uname));
|
|
Put_Line (Name_Id (File_Mapping.Table (Unit).Fname));
|
|
File_Entry :=
|
|
File_Hash_Table.Get (File_Mapping.Table (Unit).Fname);
|
|
Put_Line (Name_Id (Path_Mapping.Table (File_Entry).Fname));
|
|
end loop;
|
|
|
|
-- Before closing the file, write the buffer to the file. It is
|
|
-- guaranteed that the Buffer is not empty, because Put_Line has
|
|
-- been called at least 3 times, and after a call to Put_Line, the
|
|
-- Buffer is not empty.
|
|
|
|
N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
|
|
|
|
if N_Bytes < Buffer_Last then
|
|
Fail ("disk full");
|
|
end if;
|
|
|
|
Close (File, Status);
|
|
|
|
if not Status then
|
|
Fail ("disk full");
|
|
end if;
|
|
|
|
elsif not Quiet_Output then
|
|
Write_Str ("warning: could not open mapping file """);
|
|
Write_Str (File_Name);
|
|
Write_Line (""" for update");
|
|
end if;
|
|
|
|
end if;
|
|
end Update_Mapping_File;
|
|
|
|
end Fmap;
|