Skip to content

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

[multiple changes] 

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

	* sem_ch6.adb (Check_Overriding_Indicator, New_Overloaded_Entity): When
	setting attribute Overridden_Operation do not reference the entities
	generated by Derive_Subprograms but their aliased entity (which
	is the primitive inherited from the parent type).

2010-10-26  Bob Duff  <duff@adacore.com>

	* namet.adb, namet.ads: Minor cleanup.

From-SVN: r165948
parent 3019e9b6
Showing with 151 additions and 75 deletions
gcc/ada/ChangeLog
2010-10-26 Javier Miranda <miranda@adacore.com>
* sem_ch6.adb (Check_Overriding_Indicator, New_Overloaded_Entity): When
setting attribute Overridden_Operation do not reference the entities
generated by Derive_Subprograms but their aliased entity (which
is the primitive inherited from the parent type).
2010-10-26 Bob Duff <duff@adacore.com>
* namet.adb, namet.ads: Minor cleanup.
2010-10-26 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Make-lang.in: Update dependencies.
......
gcc/ada/namet.adb
......@@ -123,11 +123,12 @@ package body Namet is
--------------
procedure Finalize is
Max_Chain_Length : constant := 50;
-- Max length of chains for which specific information is output
F : array (Int range 0 .. 50) of Int;
-- N'th entry is the number of chains of length N, except last entry,
-- which is the number of chains of length F'Last or more.
F : array (Int range 0 .. Max_Chain_Length) of Int;
-- N'th entry is number of chains of length N
Max_Chain_Length : Int := 0;
-- Maximum length of all chains
Probes : Int := 0;
-- Used to compute average number of probes
......@@ -135,49 +136,68 @@ package body Namet is
Nsyms : Int := 0;
-- Number of symbols in table
Verbosity : constant Int range 1 .. 3 := 1;
pragma Warnings (Off, Verbosity);
-- 1 => print basic summary information
-- 2 => in addition print number of entries per hash chain
-- 3 => in addition print content of entries
begin
if Debug_Flag_H then
for J in F'Range loop
F (J) := 0;
end loop;
if not Debug_Flag_H then
return;
end if;
for J in Hash_Index_Type loop
if Hash_Table (J) = No_Name then
F (0) := F (0) + 1;
for J in F'Range loop
F (J) := 0;
end loop;
else
Write_Str ("Hash_Table (");
Write_Int (J);
Write_Str (") has ");
for J in Hash_Index_Type loop
if Hash_Table (J) = No_Name then
F (0) := F (0) + 1;
declare
C : Int := 1;
N : Name_Id;
S : Int;
else
declare
C : Int;
N : Name_Id;
S : Int;
begin
C := 0;
N := Hash_Table (J);
while N /= No_Name loop
N := Name_Entries.Table (N).Hash_Link;
C := C + 1;
end loop;
begin
C := 0;
N := Hash_Table (J);
Nsyms := Nsyms + 1;
Probes := Probes + (1 + C) * 100;
while N /= No_Name loop
N := Name_Entries.Table (N).Hash_Link;
C := C + 1;
end loop;
if C > Max_Chain_Length then
Max_Chain_Length := C;
end if;
if Verbosity >= 2 then
Write_Str ("Hash_Table (");
Write_Int (J);
Write_Str (") has ");
Write_Int (C);
Write_Str (" entries");
Write_Eol;
end if;
if C < Max_Chain_Length then
F (C) := F (C) + 1;
else
F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
end if;
if C < F'Last then
F (C) := F (C) + 1;
else
F (F'Last) := F (F'Last) + 1;
end if;
N := Hash_Table (J);
N := Hash_Table (J);
while N /= No_Name loop
S := Name_Entries.Table (N).Name_Chars_Index;
while N /= No_Name loop
S := Name_Entries.Table (N).Name_Chars_Index;
if Verbosity >= 3 then
Write_Str (" ");
for J in 1 .. Name_Entries.Table (N).Name_Len loop
......@@ -185,50 +205,61 @@ package body Namet is
end loop;
Write_Eol;
N := Name_Entries.Table (N).Hash_Link;
end loop;
end;
end if;
end loop;
Write_Eol;
end if;
for J in Int range 0 .. Max_Chain_Length loop
if F (J) /= 0 then
Write_Str ("Number of hash chains of length ");
N := Name_Entries.Table (N).Hash_Link;
end loop;
end;
end if;
end loop;
if J < 10 then
Write_Char (' ');
end if;
Write_Eol;
Write_Int (J);
for J in F'Range loop
if F (J) /= 0 then
Write_Str ("Number of hash chains of length ");
if J = Max_Chain_Length then
Write_Str (" or greater");
end if;
if J < 10 then
Write_Char (' ');
end if;
Write_Str (" = ");
Write_Int (F (J));
Write_Eol;
Write_Int (J);
if J /= 0 then
Nsyms := Nsyms + F (J);
Probes := Probes + F (J) * (1 + J) * 100;
end if;
if J = F'Last then
Write_Str (" or greater");
end if;
end loop;
Write_Eol;
Write_Str ("Average number of probes for lookup = ");
Probes := Probes / Nsyms;
Write_Int (Probes / 200);
Write_Char ('.');
Probes := (Probes mod 200) / 2;
Write_Char (Character'Val (48 + Probes / 10));
Write_Char (Character'Val (48 + Probes mod 10));
Write_Eol;
Write_Eol;
end if;
Write_Str (" = ");
Write_Int (F (J));
Write_Eol;
end if;
end loop;
-- Print out average number of probes, in the case where Name_Find is
-- called for a string that is already in the table.
Write_Eol;
Write_Str ("Average number of probes for lookup = ");
Probes := Probes / Nsyms;
Write_Int (Probes / 200);
Write_Char ('.');
Probes := (Probes mod 200) / 2;
Write_Char (Character'Val (48 + Probes / 10));
Write_Char (Character'Val (48 + Probes mod 10));
Write_Eol;
Write_Str ("Max_Chain_Length = ");
Write_Int (Max_Chain_Length);
Write_Eol;
Write_Str ("Name_Chars'Length = ");
Write_Int (Name_Chars.Last - Name_Chars.First + 1);
Write_Eol;
Write_Str ("Name_Entries'Length = ");
Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1));
Write_Eol;
Write_Str ("Nsyms = ");
Write_Int (Nsyms);
Write_Eol;
end Finalize;
-----------------------------
......
gcc/ada/namet.ads
......@@ -70,7 +70,7 @@ package Namet is
-- followed by an upper case letter or an underscore.
-- Character literals Character literals have names that are used only for
-- debugging and error message purposes. The form is a
-- debugging and error message purposes. The form is an
-- upper case Q followed by a single lower case letter,
-- or by a Uxx/Wxxxx/WWxxxxxxx encoding as described for
-- identifiers. The Set_Character_Literal_Name procedure
......@@ -139,8 +139,8 @@ package Namet is
-----------------------------
-- Name_Id values are used to identify entries in the names table. Except
-- for the special values No_Name, and Error_Name, they are subscript
-- values for the Names table defined in package Namet.
-- for the special values No_Name and Error_Name, they are subscript values
-- for the Names table defined in this package.
-- Note that with only a few exceptions, which are clearly documented, the
-- type Name_Id should be regarded as a private type. In particular it is
......
gcc/ada/sem_ch6.adb
......@@ -4672,7 +4672,25 @@ package body Sem_Ch6 is
end if;
elsif Is_Subprogram (Subp) then
Set_Overridden_Operation (Subp, Overridden_Subp);
if No (Overridden_Operation (Subp)) then
-- For entities generated by Derive_Subprograms the overridden
-- operation is the inherited primitive (which is available
-- through the attribute alias)
if (Is_Dispatching_Operation (Subp)
or else Is_Dispatching_Operation (Overridden_Subp))
and then not Comes_From_Source (Overridden_Subp)
and then Find_Dispatching_Type (Overridden_Subp)
= Find_Dispatching_Type (Subp)
and then Present (Alias (Overridden_Subp))
and then Comes_From_Source (Alias (Overridden_Subp))
then
Set_Overridden_Operation (Subp, Alias (Overridden_Subp));
else
Set_Overridden_Operation (Subp, Overridden_Subp);
end if;
end if;
end if;
-- If primitive flag is set or this is a protected operation, then
......@@ -8142,7 +8160,23 @@ package body Sem_Ch6 is
end if;
Enter_Overloaded_Entity (S);
Set_Overridden_Operation (S, E);
-- For entities generated by Derive_Subprograms the
-- overridden operation is the inherited primitive
-- (which is available through the attribute alias).
if not (Comes_From_Source (E))
and then Is_Dispatching_Operation (E)
and then Find_Dispatching_Type (E)
= Find_Dispatching_Type (S)
and then Present (Alias (E))
and then Comes_From_Source (Alias (E))
then
Set_Overridden_Operation (S, Alias (E));
else
Set_Overridden_Operation (S, E);
end if;
Check_Overriding_Indicator (S, E, Is_Primitive => True);
-- If S is a user-defined subprogram or a null procedure
......
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