Skip to content

R
riscv-gcc-1
Commit cabadd1c by Arnaud Charlet
Options

[multiple changes] 

2009-06-25  Emmanuel Briot  <briot@adacore.com>

	* gnatcmd.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads, prj-nmsc.adb,
	prj-env.adb, prj-env.ads (Slash): removed, no longer used
	(Source_Data): no longer use Path.Name to point to a locally removed
	file. Instead we use the field Locally_Removed which is clearer

2009-06-25  Arnaud Charlet  <charlet@adacore.com>

	* gcc-interface/Make-lang.in: Remove references to sem_maps.o

	* sem_maps.adb, sem_maps.ads: Removed, not used.

From-SVN: r148931
parent 9763f8c8
Showing with 61 additions and 639 deletions
gcc/ada/ChangeLog
2009-06-25 Emmanuel Briot <briot@adacore.com>
* gnatcmd.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads, prj-nmsc.adb,
prj-env.adb, prj-env.ads (Slash): removed, no longer used
(Source_Data): no longer use Path.Name to point to a locally removed
file. Instead we use the field Locally_Removed which is clearer
2009-06-25 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Make-lang.in: Remove references to sem_maps.o
* sem_maps.adb, sem_maps.ads: Removed, not used.
2009-06-25 Ed Falis <falis@adacore.com>
* s-vxwext-rtp.ads: Add missing declaration
......
gcc/ada/gcc-interface/Make-lang.in
......@@ -157,7 +157,7 @@ GNAT_ADA_OBJS = ada/s-bitops.o ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-exc
ada/sem_ch12.o ada/sem_ch13.o ada/sem_ch2.o ada/sem_ch3.o ada/sem_ch4.o \
ada/sem_ch5.o ada/sem_ch6.o ada/sem_ch7.o ada/sem_ch8.o ada/sem_ch9.o \
ada/sem_case.o ada/sem_disp.o ada/sem_dist.o ada/sem_elab.o ada/sem_elim.o \
ada/sem_eval.o ada/sem_intr.o ada/sem_maps.o ada/sem_mech.o ada/sem_prag.o \
ada/sem_eval.o ada/sem_intr.o ada/sem_mech.o ada/sem_prag.o \
ada/sem_res.o ada/sem_smem.o ada/sem_type.o ada/sem_util.o ada/sem_vfpt.o \
ada/sem_warn.o ada/sinfo-cn.o ada/sinfo.o ada/sinput.o ada/sinput-d.o \
ada/sinput-l.o ada/snames.o ada/sprint.o ada/stand.o ada/stringt.o \
......@@ -3686,19 +3686,6 @@ ada/sem_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_maps.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/gnat.ads \
ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \
ada/nlists.adb ada/opt.ads ada/output.ads ada/sem_maps.ads \
ada/sem_maps.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \
ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_mech.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \
......
gcc/ada/gnatcmd.adb
......@@ -417,7 +417,7 @@ procedure GNATCmd is
if The_Command = List then
if Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).Path.Name /= Slash
and then not Unit.File_Names (Impl).Locally_Removed
then
-- There is a body, check if it is for this project
......@@ -427,7 +427,7 @@ procedure GNATCmd is
Subunit := False;
if Unit.File_Names (Spec) = null
or else Unit.File_Names (Spec).Path.Name = Slash
or else Unit.File_Names (Spec).Locally_Removed
then
-- We have a body with no spec: we need to check if
-- this is a subunit, because gnatls will complain
......@@ -456,7 +456,7 @@ procedure GNATCmd is
end if;
elsif Unit.File_Names (Spec) /= null
and then Unit.File_Names (Spec).Path.Name /= Slash
and then not Unit.File_Names (Spec).Locally_Removed
then
-- We have a spec with no body. Check if it is for this
-- project.
......@@ -478,7 +478,7 @@ procedure GNATCmd is
elsif The_Command = Stack then
if Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).Path.Name /= Slash
and then not Unit.File_Names (Impl).Locally_Removed
then
-- There is a body. Check if .ci files for this project
-- must be added.
......@@ -489,7 +489,7 @@ procedure GNATCmd is
Subunit := False;
if Unit.File_Names (Spec) = null
or else Unit.File_Names (Spec).Path.Name = Slash
or else Unit.File_Names (Spec).Locally_Removed
then
-- We have a body with no spec: we need to check
-- if this is a subunit, because .ci files are not
......@@ -523,7 +523,7 @@ procedure GNATCmd is
end if;
elsif Unit.File_Names (Spec) /= null
and then Unit.File_Names (Spec).Path.Name /= Slash
and then not Unit.File_Names (Spec).Locally_Removed
then
-- Spec with no body, check if it is for this project
......@@ -552,7 +552,7 @@ procedure GNATCmd is
if Unit.File_Names (Kind) /= null
and then Check_Project
(Unit.File_Names (Kind).Project, Project)
and then Unit.File_Names (Kind).Path.Name /= Slash
and then not Unit.File_Names (Kind).Locally_Removed
then
Get_Name_String
(Unit.File_Names (Kind).Path.Display_Name);
......
gcc/ada/make.adb
......@@ -3609,7 +3609,7 @@ package body Make is
if Uid /= Prj.No_Unit_Index then
if Uid.File_Names (Impl) /= null
and then
Uid.File_Names (Impl).Path.Name /= Slash
not Uid.File_Names (Impl).Locally_Removed
then
Sfile := Uid.File_Names (Impl).File;
Source_Index :=
......@@ -3617,7 +3617,7 @@ package body Make is
elsif Uid.File_Names (Spec) /= null
and then
Uid.File_Names (Spec).Path.Name /= Slash
not Uid.File_Names (Spec).Locally_Removed
then
Sfile := Uid.File_Names (Spec).File;
Source_Index :=
......@@ -7002,7 +7002,7 @@ package body Make is
-- locally removed.
if Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).Path.Name /= Slash
and then not Unit.File_Names (Impl).Locally_Removed
then
-- And it is a source for the specified project
......@@ -7049,7 +7049,7 @@ package body Make is
end if;
elsif Unit.File_Names (Spec) /= null
and then Unit.File_Names (Spec).Path.Name /= Slash
and then not Unit.File_Names (Spec).Locally_Removed
and then Check_Project (Unit.File_Names (Spec).Project)
then
-- If there is no source for the body, but there is a source
......
gcc/ada/mlib-prj.adb
......@@ -946,7 +946,7 @@ package body MLib.Prj is
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= No_Unit_Index loop
if Unit.File_Names (Impl) /= null
and then Unit.File_Names (Impl).Path.Name /= Slash
and then not Unit.File_Names (Impl).Locally_Removed
then
if Check_Project (Unit.File_Names (Impl).Project) then
if Unit.File_Names (Spec) = null then
......@@ -975,7 +975,7 @@ package body MLib.Prj is
end if;
elsif Unit.File_Names (Spec) /= null
and then Unit.File_Names (Spec).Path.Name /= Slash
and then not Unit.File_Names (Spec).Locally_Removed
and then Check_Project (Unit.File_Names (Spec).Project)
then
Add_ALI_For (Unit.File_Names (Spec).File);
......
gcc/ada/prj-env.adb
......@@ -622,7 +622,8 @@ package body Prj.Env is
Last := Write (File, S (S'First)'Address, S'Length);
if Last /= S'Length then
Prj.Com.Fail ("Disk full");
Prj.Com.Fail
("Disk full when creating " & Get_Name_String (File_Name));
end if;
if Current_Verbosity = High then
......@@ -650,7 +651,8 @@ package body Prj.Env is
Last := Write (File, S0'Address, S0'Length);
if Last /= S'Length + 1 then
Prj.Com.Fail ("Disk full");
Prj.Com.Fail
("Disk full when creating " & Get_Name_String (File_Name));
end if;
if Current_Verbosity = High then
......@@ -676,6 +678,7 @@ package body Prj.Env is
while Current_Unit /= No_Unit_Index loop
if Current_Unit.File_Names (Spec) /= null
and then Current_Unit.File_Names (Spec).Naming_Exception
and then not Current_Unit.File_Names (Spec).Locally_Removed
then
Put (Current_Unit.Name,
Current_Unit.File_Names (Spec).File,
......@@ -685,6 +688,7 @@ package body Prj.Env is
if Current_Unit.File_Names (Impl) /= null
and then Current_Unit.File_Names (Impl).Naming_Exception
and then not Current_Unit.File_Names (Impl).Locally_Removed
then
Put (Current_Unit.Name,
Current_Unit.File_Names (Impl).File,
......@@ -718,7 +722,8 @@ package body Prj.Env is
GNAT.OS_Lib.Close (File, Status);
if not Status then
Prj.Com.Fail ("disk full");
Prj.Com.Fail
("Disk full when creating " & Get_Name_String (File_Name));
end if;
if Opt.Verbose_Mode then
......@@ -744,18 +749,17 @@ package body Prj.Env is
begin
Fmap.Reset_Tables;
-- ??? Shouldn't we iterate on source files instead ?
Unit := Units_Htable.Get_First (In_Tree.Units_HT);
while Unit /= No_Unit_Index loop
-- Process only if the unit has a valid name
if Unit.Name /= No_Name then
Data := Unit.File_Names (Spec);
for S in Spec_Or_Body loop
Data := Unit.File_Names (S);
-- If there is a spec put it in the mapping
if Data /= null then
if Data.Path.Name = Slash then
if Data.Locally_Removed then
Fmap.Add_Forbidden_File_Name (Data.File);
else
Fmap.Add_To_File_Map
......@@ -764,22 +768,7 @@ package body Prj.Env is
Path_Name => File_Name_Type (Data.Path.Name));
end if;
end if;
Data := Unit.File_Names (Impl);
-- If there is a body (or subunit) put it in the mapping
if Data /= null then
if Data.Path.Name = Slash then
Fmap.Add_Forbidden_File_Name (Data.File);
else
Fmap.Add_To_File_Map
(Unit_Name => Unit_Name_Type (Unit.Name),
File_Name => Data.File,
Path_Name => File_Name_Type (Data.Path.Name));
end if;
end if;
end if;
end loop;
Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
end loop;
......@@ -971,7 +960,6 @@ package body Prj.Env is
exit when Source = No_Source;
if Source.Language.Name = Language
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
and then Source.Path.Name /= No_Path
then
......@@ -997,7 +985,13 @@ package body Prj.Env is
Get_Name_String (Source.File);
Put_Name_Buffer;
Get_Name_String (Source.Path.Name);
if Source.Locally_Removed then
Name_Len := 1;
Name_Buffer (1 .. Name_Len) := "/";
else
Get_Name_String (Source.Path.Name);
end if;
Put_Name_Buffer;
end if;
......
gcc/ada/prj-env.ads
......@@ -56,6 +56,8 @@ package Prj.Env is
-- since the latter would have to match exactly the index of that language
-- for the specified project, and that is not information available in
-- buildgpr.adb.
--
-- See fmap for a description of the format of the mapping file
procedure Set_Mapping_File_Initial_State_To_Empty
(In_Tree : Project_Tree_Ref);
......
gcc/ada/prj-nmsc.adb
......@@ -4569,7 +4569,7 @@ package body Prj.Nmsc is
-- Check that the unit is part of the project
if UData.File_Names (Impl) /= null
and then UData.File_Names (Impl).Path.Name /= Slash
and then not UData.File_Names (Impl).Locally_Removed
then
if Check_Project
(UData.File_Names (Impl).Project,
......@@ -4618,7 +4618,7 @@ package body Prj.Nmsc is
end if;
elsif UData.File_Names (Spec) /= null
and then UData.File_Names (Spec).Path.Name /= Slash
and then not UData.File_Names (Spec).Locally_Removed
and then Check_Project
(UData.File_Names (Spec).Project,
Project, Extending)
......@@ -7802,7 +7802,6 @@ package body Prj.Nmsc is
Source : Source_Id := No_Source;
OK : Boolean;
Excluded : File_Found;
Index : Unit_Index;
begin
Excluded := Excluded_Sources_Htable.Get_First;
......@@ -7821,27 +7820,12 @@ package body Prj.Nmsc is
or else Is_Extending (Project, Source.Project)
then
OK := True;
Source.Locally_Removed := True;
if Source.Unit /= No_Unit_Index then
Index :=
Units_Htable.Get
(In_Tree.Units_HT, Source.Unit.Name);
if Index.File_Names (Source.Kind) /= null then
Index.File_Names (Source.Kind).Path.Name := Slash;
Index.File_Names (Source.Kind).Naming_Exception :=
False;
-- ??? Should we simply set (can be done from the
-- source)
-- Index.File_Names (Source.Kind) := null;
end if;
end if;
if Source /= No_Source then
Source.Locally_Removed := True;
Source.In_Interfaces := False;
end if;
Name_Len := 1;
Name_Buffer (1 .. Name_Len) := "/";
Source.Path.Name := Name_Find;
Source.In_Interfaces := False;
if Current_Verbosity = High then
Write_Str ("Removing file ");
......@@ -8134,12 +8118,12 @@ package body Prj.Nmsc is
if UData.File_Names (Unit_Kind) = null
or else
(UData.File_Names (Unit_Kind).File = Canonical_File
and then UData.File_Names (Unit_Kind).Path.Name = Slash)
and then UData.File_Names (Unit_Kind).Locally_Removed)
or else Is_Extending
(Project.Extends, UData.File_Names (Unit_Kind).Project)
then
if UData.File_Names (Unit_Kind) /= null
and then UData.File_Names (Unit_Kind).Path.Name = Slash
and then UData.File_Names (Unit_Kind).Locally_Removed
then
Remove_Forbidden_File_Name
(UData.File_Names (Unit_Kind).File);
......
gcc/ada/prj.adb
......@@ -53,7 +53,6 @@ package body Prj is
Default_Ada_Spec_Suffix_Id : File_Name_Type;
Default_Ada_Body_Suffix_Id : File_Name_Type;
Slash_Id : Path_Name_Type;
-- Initialized in Prj.Initialize, then never modified
subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
......@@ -620,9 +619,6 @@ package body Prj is
Name_Len := 4;
Name_Buffer (1 .. 4) := ".adb";
Default_Ada_Body_Suffix_Id := Name_Find;
Name_Len := 1;
Name_Buffer (1) := '/';
Slash_Id := Name_Find;
Prj.Attr.Initialize;
Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
......@@ -1134,15 +1130,6 @@ package body Prj is
In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element;
end Set_Spec_Suffix;
-----------
-- Slash --
-----------
function Slash return Path_Name_Type is
begin
return Slash_Id;
end Slash;
-----------------------
-- Spec_Suffix_Id_Of --
-----------------------
......@@ -1464,7 +1451,8 @@ package body Prj is
function Is_Compilable (Source : Source_Id) return Boolean is
begin
return Source.Language.Config.Compiler_Driver /= Empty_File_Name;
return Source.Language.Config.Compiler_Driver /= Empty_File_Name
and then not Source.Locally_Removed;
end Is_Compilable;
----------------------------
......
gcc/ada/prj.ads
......@@ -121,10 +121,6 @@ package Prj is
-- The name for the standard GNAT suffix for Ada body source file name
-- ".adb". Initialized by Prj.Initialize.
function Slash return Path_Name_Type;
pragma Inline (Slash);
-- "/", used as the path of locally removed files
Config_Project_File_Extension : String := ".cgpr";
Project_File_Extension : String := ".gpr";
-- The standard config and user project file name extensions. They are not
......@@ -692,8 +688,6 @@ package Prj is
Path : Path_Information := No_Path_Information;
-- Path name of the source
-- Path.Name is set to Slash for an excluded file that does not belong
-- in the project in fact
Source_TS : Time_Stamp_Type := Empty_Time_Stamp;
-- Time stamp of the source file
......
gcc/ada/sem_maps.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ M A P S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2007, 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 Atree; use Atree;
with Einfo; use Einfo;
with Namet; use Namet;
with Output; use Output;
with Sinfo; use Sinfo;
with Uintp; use Uintp;
package body Sem_Maps is
-----------------------
-- Local Subprograms --
-----------------------
function Find_Assoc (M : Map; E : Entity_Id) return Assoc_Index;
-- Standard hash table search. M is the map to be searched, E is the
-- entity to be searched for, and Assoc_Index is the resulting
-- association, or is set to No_Assoc if there is no association.
function Find_Header_Size (N : Int) return Header_Index;
-- Find largest power of two smaller than the number of entries in
-- the table. This load factor of 2 may be adjusted later if needed.
procedure Write_Map (E : Entity_Id);
pragma Warnings (Off, Write_Map);
-- For debugging purposes
---------------------
-- Add_Association --
---------------------
procedure Add_Association
(M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local)
is
Info : constant Map_Info := Maps_Table.Table (M);
Offh : constant Header_Index := Info.Header_Offset;
Offs : constant Header_Index := Info.Header_Num;
J : constant Header_Index := Header_Index (O_Id) mod Offs;
K : constant Assoc_Index := Info.Assoc_Next;
begin
Associations_Table.Table (K) := (O_Id, N_Id, Kind, No_Assoc);
Maps_Table.Table (M).Assoc_Next := K + 1;
if Headers_Table.Table (Offh + J) /= No_Assoc then
-- Place new association at head of chain
Associations_Table.Table (K).Next := Headers_Table.Table (Offh + J);
end if;
Headers_Table.Table (Offh + J) := K;
end Add_Association;
------------------------
-- Build_Instance_Map --
------------------------
function Build_Instance_Map (M : Map) return Map is
Info : constant Map_Info := Maps_Table.Table (M);
Res : constant Map := New_Map (Int (Info.Assoc_Num));
Offh1 : constant Header_Index := Info.Header_Offset;
Offa1 : constant Assoc_Index := Info.Assoc_Offset;
Offh2 : constant Header_Index := Maps_Table.Table (Res).Header_Offset;
Offa2 : constant Assoc_Index := Maps_Table.Table (Res).Assoc_Offset;
A : Assoc;
A_Index : Assoc_Index;
begin
for J in 0 .. Info.Header_Num - 1 loop
A_Index := Headers_Table.Table (Offh1 + J);
if A_Index /= No_Assoc then
Headers_Table.Table (Offh2 + J) := A_Index + (Offa2 - Offa1);
end if;
end loop;
for J in 0 .. Info.Assoc_Num - 1 loop
A := Associations_Table.Table (Offa1 + J);
-- For local entities that come from source, create the
-- corresponding local entities in the instance. Entities that
-- do not come from source are etypes, and new ones will be
-- generated when analyzing the instance.
if No (A.New_Id)
and then A.Kind = S_Local
and then Comes_From_Source (A.Old_Id)
then
A.New_Id := New_Copy (A.Old_Id);
A.New_Id := New_Entity (Nkind (A.Old_Id), Sloc (A.Old_Id));
Set_Chars (A.New_Id, Chars (A.Old_Id));
end if;
if A.Next /= No_Assoc then
A.Next := A.Next + (Offa2 - Offa1);
end if;
Associations_Table.Table (Offa2 + J) := A;
end loop;
Maps_Table.Table (Res).Assoc_Next := Associations_Table.Last;
return Res;
end Build_Instance_Map;
-------------
-- Compose --
-------------
function Compose (Orig_Map : Map; New_Map : Map) return Map is
Res : constant Map := Copy (Orig_Map);
Off : constant Assoc_Index := Maps_Table.Table (Res).Assoc_Offset;
A : Assoc;
K : Assoc_Index;
begin
-- Iterate over the contents of Orig_Map, looking for entities
-- that are further mapped under New_Map.
for J in 0 .. Maps_Table.Table (Res).Assoc_Num - 1 loop
A := Associations_Table.Table (Off + J);
K := Find_Assoc (New_Map, A.New_Id);
if K /= No_Assoc then
Associations_Table.Table (Off + J).New_Id
:= Associations_Table.Table (K).New_Id;
end if;
end loop;
return Res;
end Compose;
----------
-- Copy --
----------
function Copy (M : Map) return Map is
Info : constant Map_Info := Maps_Table.Table (M);
Res : constant Map := New_Map (Int (Info.Assoc_Num));
Offh1 : constant Header_Index := Info.Header_Offset;
Offa1 : constant Assoc_Index := Info.Assoc_Offset;
Offh2 : constant Header_Index := Maps_Table.Table (Res).Header_Offset;
Offa2 : constant Assoc_Index := Maps_Table.Table (Res).Assoc_Offset;
A : Assoc;
A_Index : Assoc_Index;
begin
for J in 0 .. Info.Header_Num - 1 loop
A_Index := Headers_Table.Table (Offh1 + J) + (Offa2 - Offa1);
if A_Index /= No_Assoc then
Headers_Table.Table (Offh2 + J) := A_Index + (Offa2 - Offa1);
end if;
end loop;
for J in 0 .. Info.Assoc_Num - 1 loop
A := Associations_Table.Table (Offa1 + J);
A.Next := A.Next + (Offa2 - Offa1);
Associations_Table.Table (Offa2 + J) := A;
end loop;
Maps_Table.Table (Res).Assoc_Next := Associations_Table.Last;
return Res;
end Copy;
----------------
-- Find_Assoc --
----------------
function Find_Assoc (M : Map; E : Entity_Id) return Assoc_Index is
Offh : constant Header_Index := Maps_Table.Table (M).Header_Offset;
Offs : constant Header_Index := Maps_Table.Table (M).Header_Num;
J : constant Header_Index := Header_Index (E) mod Offs;
A : Assoc;
A_Index : Assoc_Index;
begin
A_Index := Headers_Table.Table (Offh + J);
if A_Index = No_Assoc then
return A_Index;
else
A := Associations_Table.Table (A_Index);
while Present (A.Old_Id) loop
if A.Old_Id = E then
return A_Index;
elsif A.Next = No_Assoc then
return No_Assoc;
else
A_Index := A.Next;
A := Associations_Table.Table (A.Next);
end if;
end loop;
return No_Assoc;
end if;
end Find_Assoc;
----------------------
-- Find_Header_Size --
----------------------
function Find_Header_Size (N : Int) return Header_Index is
Siz : Header_Index;
begin
Siz := 2;
while 2 * Siz < Header_Index (N) loop
Siz := 2 * Siz;
end loop;
return Siz;
end Find_Header_Size;
------------
-- Lookup --
------------
function Lookup (M : Map; E : Entity_Id) return Entity_Id is
Offh : constant Header_Index := Maps_Table.Table (M).Header_Offset;
Offs : constant Header_Index := Maps_Table.Table (M).Header_Num;
J : constant Header_Index := Header_Index (E) mod Offs;
A : Assoc;
begin
if Headers_Table.Table (Offh + J) = No_Assoc then
return Empty;
else
A := Associations_Table.Table (Headers_Table.Table (Offh + J));
while Present (A.Old_Id) loop
if A.Old_Id = E then
return A.New_Id;
elsif A.Next = No_Assoc then
return Empty;
else
A := Associations_Table.Table (A.Next);
end if;
end loop;
return Empty;
end if;
end Lookup;
-------------
-- New_Map --
-------------
function New_Map (Num_Assoc : Int) return Map is
Header_Size : constant Header_Index := Find_Header_Size (Num_Assoc);
Res : Map_Info;
begin
-- Allocate the tables for the new map at the current end of the
-- global tables.
Associations_Table.Increment_Last;
Headers_Table.Increment_Last;
Maps_Table.Increment_Last;
Res.Header_Offset := Headers_Table.Last;
Res.Header_Num := Header_Size;
Res.Assoc_Offset := Associations_Table.Last;
Res.Assoc_Next := Associations_Table.Last;
Res.Assoc_Num := Assoc_Index (Num_Assoc);
Headers_Table.Set_Last (Headers_Table.Last + Header_Size);
Associations_Table.Set_Last
(Associations_Table.Last + Assoc_Index (Num_Assoc));
Maps_Table.Table (Maps_Table.Last) := Res;
for J in 1 .. Header_Size loop
Headers_Table.Table (Headers_Table.Last - J) := No_Assoc;
end loop;
return Maps_Table.Last;
end New_Map;
------------------------
-- Update_Association --
------------------------
procedure Update_Association
(M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local)
is
J : constant Assoc_Index := Find_Assoc (M, O_Id);
begin
Associations_Table.Table (J).New_Id := N_Id;
Associations_Table.Table (J).Kind := Kind;
end Update_Association;
---------------
-- Write_Map --
---------------
procedure Write_Map (E : Entity_Id) is
M : constant Map := Map (UI_To_Int (Renaming_Map (E)));
Info : constant Map_Info := Maps_Table.Table (M);
Offh : constant Header_Index := Info.Header_Offset;
Offa : constant Assoc_Index := Info.Assoc_Offset;
A : Assoc;
begin
Write_Str ("Size : ");
Write_Int (Int (Info.Assoc_Num));
Write_Eol;
Write_Str ("Headers");
Write_Eol;
for J in 0 .. Info.Header_Num - 1 loop
Write_Int (Int (Offh + J));
Write_Str (" : ");
Write_Int (Int (Headers_Table.Table (Offh + J)));
Write_Eol;
end loop;
for J in 0 .. Info.Assoc_Num - 1 loop
A := Associations_Table.Table (Offa + J);
Write_Int (Int (Offa + J));
Write_Str (" : ");
Write_Name (Chars (A.Old_Id));
Write_Str (" ");
Write_Int (Int (A.Old_Id));
Write_Str (" ==> ");
Write_Int (Int (A.New_Id));
Write_Str (" next = ");
Write_Int (Int (A.Next));
Write_Eol;
end loop;
end Write_Map;
end Sem_Maps;
gcc/ada/sem_maps.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ M A P S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2007, 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. --
-- --
------------------------------------------------------------------------------
-- This package contains the operations on the renaming maps used for
-- generic analysis and instantiation. Renaming maps are created when
-- a generic unit is analyzed, in order to capture all references to
-- global variables within the unit. The renaming map of a generic unit
-- copied prior to each instantiation, and then updated by mapping the
-- formals into the actuals and the local entities into entities local to
-- the instance. When the generic tree is copied to produce the instance,
-- all references are updated by means of the renaming map.
-- Map composition of renaming maps takes place for nested instantiations,
-- for generic child units, and for formal packages.
-- For additional details, see the documentation in sem_ch12
with Table;
with Types; use Types;
package Sem_Maps is
type Map is new Int;
type Assoc is private;
type Scope_Kind is (S_Global, S_Formal, S_Local);
function New_Map (Num_Assoc : Int) return Map;
-- Build empty map with the given number of associations, and a
-- headers table of the appropriate size.
function Compose (Orig_Map : Map; New_Map : Map) return Map;
-- Update the associations in Orig_Map, so that if Orig_Map (e1) = e2
-- and New_Map (e2) = e3, then the image of e1 under the result is e3.
function Copy (M : Map) return Map;
-- Full copy of contents and headers
function Lookup (M : Map; E : Entity_Id) return Entity_Id;
-- Retrieve image of E under M, Empty if undefined
procedure Add_Association
(M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local);
-- Update M in place. On entry M (O_Id) must not be defined
procedure Update_Association
(M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local);
-- Update the entry in M for O_Id
function Build_Instance_Map (M : Map) return Map;
-- Copy renaming map of generic, and create new entities for all the
-- local entities within.
private
-- New maps are created when a generic is analyzed, and for each of
-- its instantiations. Maps are also updated for nested generics, for
-- child units, and for formal packages. As a result we need to allocate
-- maps dynamically.
-- When analyzing a generic, we do not know how many references are
-- in it. We build an initial map after generic analysis, using a static
-- structure that relies on the compiler's extensible table mechanism.
-- After constructing this initial map, all subsequent uses and updates
-- of this map do not modify its domain, so that dynamically allocated
-- maps have a fixed size and never need to be reallocated. Furthermore,
-- the headers of the hash table of a dynamically allocated map can be
-- chosen according to the total number of entries in the map, to
-- accommodate efficiently generic units of different sizes (Unchecked_
-- Conversion vs. Generic_Elementary_Functions, for example). So in
-- fact both components of a map have fixed size, and can be allocated
-- using the standard table mechanism. A Maps_Table holds records that
-- contain indices into the global Headers table and the Associations
-- table, and a Map is an index into the Maps_Table.
--
-- Maps_Table Headers_Table Associations_Table
--
-- |_____| |___________ |
-- |_____| | | | |
-- ------>|Map |------------------------------>|Associations|
-- |Info |------------->| |=========>| for one |
-- |_____| | |====| | unit |
-- | | | | |====>| |
-- |_____| |____________|
-- | | | |
type Header_Index is new Int;
type Assoc_Index is new Int;
No_Assoc : constant Assoc_Index := -1;
type Map_Info is record
Header_Offset : Header_Index;
Header_Num : Header_Index;
Assoc_Offset : Assoc_Index;
Assoc_Num : Assoc_Index;
Assoc_Next : Assoc_Index;
end record;
type Assoc is record
Old_Id : Entity_Id := Empty;
New_Id : Entity_Id := Empty;
Kind : Scope_Kind := S_Local;
Next : Assoc_Index := No_Assoc;
end record;
-- All maps are accessed through the following table. The map attribute
-- of a generic unit or an instance is an index into this table.
package Maps_Table is new Table.Table (
Table_Component_Type => Map_Info,
Table_Index_Type => Map,
Table_Low_Bound => 0,
Table_Initial => 100,
Table_Increment => 100,
Table_Name => "Maps_Table");
-- All headers for hash tables are allocated in one global table. Each
-- map stores the offset into this table at which its own headers start.
package Headers_Table is new Table.Table (
Table_Component_Type => Assoc_Index,
Table_Index_Type => Header_Index,
Table_Low_Bound => 0,
Table_Initial => 1000,
Table_Increment => 100,
Table_Name => "Headers_Table");
-- All associations are allocated in one global table. Each map stores
-- the offset into this table at which its own associations start.
package Associations_Table is new Table.Table (
Table_Component_Type => Assoc,
Table_Index_Type => Assoc_Index,
Table_Low_Bound => 1,
Table_Initial => 1000,
Table_Increment => 100,
Table_Name => "Associations_Table");
end Sem_Maps;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment