diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 11 | ||||
| -rw-r--r-- | gcc/ada/namet.adb | 171 | ||||
| -rw-r--r-- | gcc/ada/namet.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 38 |
4 files changed, 151 insertions, 75 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6c0f2d5..3d1b464 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +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. diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index fc9eeee..fc8b4e2 100644 --- a/gcc/ada/namet.adb +++ b/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; ----------------------------- diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 9d57220..8eb5683 100644 --- a/gcc/ada/namet.ads +++ b/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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 920706b..8abe3cd 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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 |