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> 2010-10-26 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Make-lang.in: Update dependencies. * gcc-interface/Make-lang.in: Update dependencies.
......
gcc/ada/namet.adb
...@@ -123,11 +123,12 @@ package body Namet is ...@@ -123,11 +123,12 @@ package body Namet is
-------------- --------------
procedure Finalize is procedure Finalize is
Max_Chain_Length : constant := 50; F : array (Int range 0 .. 50) of Int;
-- Max length of chains for which specific information is output -- 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; Max_Chain_Length : Int := 0;
-- N'th entry is number of chains of length N -- Maximum length of all chains
Probes : Int := 0; Probes : Int := 0;
-- Used to compute average number of probes -- Used to compute average number of probes
...@@ -135,49 +136,68 @@ package body Namet is ...@@ -135,49 +136,68 @@ package body Namet is
Nsyms : Int := 0; Nsyms : Int := 0;
-- Number of symbols in table -- 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 begin
if Debug_Flag_H then if not Debug_Flag_H then
for J in F'Range loop return;
F (J) := 0; end if;
end loop;
for J in Hash_Index_Type loop for J in F'Range loop
if Hash_Table (J) = No_Name then F (J) := 0;
F (0) := F (0) + 1; end loop;
else for J in Hash_Index_Type loop
Write_Str ("Hash_Table ("); if Hash_Table (J) = No_Name then
Write_Int (J); F (0) := F (0) + 1;
Write_Str (") has ");
declare else
C : Int := 1; declare
N : Name_Id; C : Int;
S : 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 Nsyms := Nsyms + 1;
C := 0; Probes := Probes + (1 + C) * 100;
N := Hash_Table (J);
while N /= No_Name loop if C > Max_Chain_Length then
N := Name_Entries.Table (N).Hash_Link; Max_Chain_Length := C;
C := C + 1; end if;
end loop;
if Verbosity >= 2 then
Write_Str ("Hash_Table (");
Write_Int (J);
Write_Str (") has ");
Write_Int (C); Write_Int (C);
Write_Str (" entries"); Write_Str (" entries");
Write_Eol; Write_Eol;
end if;
if C < Max_Chain_Length then if C < F'Last then
F (C) := F (C) + 1; F (C) := F (C) + 1;
else else
F (Max_Chain_Length) := F (Max_Chain_Length) + 1; F (F'Last) := F (F'Last) + 1;
end if; end if;
N := Hash_Table (J); N := Hash_Table (J);
while N /= No_Name loop while N /= No_Name loop
S := Name_Entries.Table (N).Name_Chars_Index; S := Name_Entries.Table (N).Name_Chars_Index;
if Verbosity >= 3 then
Write_Str (" "); Write_Str (" ");
for J in 1 .. Name_Entries.Table (N).Name_Len loop for J in 1 .. Name_Entries.Table (N).Name_Len loop
...@@ -185,50 +205,61 @@ package body Namet is ...@@ -185,50 +205,61 @@ package body Namet is
end loop; end loop;
Write_Eol; Write_Eol;
N := Name_Entries.Table (N).Hash_Link; end if;
end loop;
end;
end if;
end loop;
Write_Eol;
for J in Int range 0 .. Max_Chain_Length loop N := Name_Entries.Table (N).Hash_Link;
if F (J) /= 0 then end loop;
Write_Str ("Number of hash chains of length "); end;
end if;
end loop;
if J < 10 then Write_Eol;
Write_Char (' ');
end if;
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 if J < 10 then
Write_Str (" or greater"); Write_Char (' ');
end if; end if;
Write_Str (" = "); Write_Int (J);
Write_Int (F (J));
Write_Eol;
if J /= 0 then if J = F'Last then
Nsyms := Nsyms + F (J); Write_Str (" or greater");
Probes := Probes + F (J) * (1 + J) * 100;
end if;
end if; end if;
end loop;
Write_Eol; Write_Str (" = ");
Write_Str ("Average number of probes for lookup = "); Write_Int (F (J));
Probes := Probes / Nsyms; Write_Eol;
Write_Int (Probes / 200); end if;
Write_Char ('.'); end loop;
Probes := (Probes mod 200) / 2;
Write_Char (Character'Val (48 + Probes / 10)); -- Print out average number of probes, in the case where Name_Find is
Write_Char (Character'Val (48 + Probes mod 10)); -- called for a string that is already in the table.
Write_Eol;
Write_Eol; Write_Eol;
end if; 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; end Finalize;
----------------------------- -----------------------------
......
gcc/ada/namet.ads
...@@ -70,7 +70,7 @@ package Namet is ...@@ -70,7 +70,7 @@ package Namet is
-- followed by an upper case letter or an underscore. -- followed by an upper case letter or an underscore.
-- Character literals Character literals have names that are used only for -- 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, -- upper case Q followed by a single lower case letter,
-- or by a Uxx/Wxxxx/WWxxxxxxx encoding as described for -- or by a Uxx/Wxxxx/WWxxxxxxx encoding as described for
-- identifiers. The Set_Character_Literal_Name procedure -- identifiers. The Set_Character_Literal_Name procedure
...@@ -139,8 +139,8 @@ package Namet is ...@@ -139,8 +139,8 @@ package Namet is
----------------------------- -----------------------------
-- Name_Id values are used to identify entries in the names table. Except -- 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 -- for the special values No_Name and Error_Name, they are subscript values
-- values for the Names table defined in package Namet. -- for the Names table defined in this package.
-- Note that with only a few exceptions, which are clearly documented, the -- 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 -- 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 ...@@ -4672,7 +4672,25 @@ package body Sem_Ch6 is
end if; end if;
elsif Is_Subprogram (Subp) then 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; end if;
-- If primitive flag is set or this is a protected operation, then -- If primitive flag is set or this is a protected operation, then
...@@ -8142,7 +8160,23 @@ package body Sem_Ch6 is ...@@ -8142,7 +8160,23 @@ package body Sem_Ch6 is
end if; end if;
Enter_Overloaded_Entity (S); 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); Check_Overriding_Indicator (S, E, Is_Primitive => True);
-- If S is a user-defined subprogram or a null procedure -- 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