diff options
-rw-r--r-- | gcc/ada/ChangeLog | 52 | ||||
-rw-r--r-- | gcc/ada/bindgen.adb | 2 | ||||
-rw-r--r-- | gcc/ada/exp_ch5.adb | 3 | ||||
-rw-r--r-- | gcc/ada/exp_unst.adb | 4 | ||||
-rw-r--r-- | gcc/ada/namet-sp.ads | 4 | ||||
-rw-r--r-- | gcc/ada/namet.adb | 952 | ||||
-rw-r--r-- | gcc/ada/namet.ads | 386 | ||||
-rw-r--r-- | gcc/ada/namet.h | 24 | ||||
-rw-r--r-- | gcc/ada/sem_elab.adb | 19 | ||||
-rw-r--r-- | gcc/ada/sem_prag.adb | 152 |
10 files changed, 897 insertions, 701 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1269d30..96cac54 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,55 @@ +2016-04-18 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Build_Pragma_Check_Equivalent): The mapping + that relates operations of the parent type to the operations of + the derived type has three distinct sources: + a) explicit operations of the derived type carry an + Overridden_Operation that designates the operation in the + ancestor. + b) Implicit operations that are inherited by the derived type + carry an alias that may be an explicit subprogram (in which case + it may have an Overridden_ Operation indicator) or may also be + inherited and carry its own alias. + c) If the parent type is an interface, the operation of the + derived type does not override, but the interface operation + indicates the operation that implements it. + * sem_prag.adb: Minor reformatting. + * sem_prag.adb (Check_External_Property): Update + the comment on usage. Reimplement. + +2016-04-18 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Assignment_Statement): In restricted + profiles such as ZFP, ceiling priority is not available. + +2016-04-18 Bob Duff <duff@adacore.com> + + * namet-sp.ads: Minor typo fix, ironically in 'Spelling_Checker'. + +2016-04-18 Bob Duff <duff@adacore.com> + + * sem_elab.adb (Output_Calls): Use + Get_Name_String, to clearly indicate that the global Name_Buffer + is being used. The previous code used Is_Internal_Name, which + returns a Boolean, but also has a side effect of setting the + Name_Buffer. Then it called the other Is_Internal_Name, which uses + the Name_Buffer for its input. And then it called Error_Msg_N, + again using the Name_Buffer. We haven't eliminated the global + usage here, but we've made it a bit clearer. + This also allows us to have a side-effect-free version of + Is_Internal_Name. + * namet.ads, namet.adb: Provide a type Bounded_String, along with + routines that can be used without using global variables. Provide + Global_Name_Buffer so existing code can continue to use the + global. Mark the routines that use globals as obsolete. New code + shouldn't call the obsolete ones, and we should clean up existing + code from time to time. + Name_Find_Str is renamed as Name_Find. + * namet.h: Changed as necessary to interface to the new version + of Namet. + * bindgen.adb, exp_unst.adb: Name_Find_Str is renamed as + Name_Find. + 2016-04-18 Yannick Moy <moy@adacore.com> * sem_util.adb, sem_util.ads (Has_Full_Default_Initialization): used diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index c4f8c76..5388fbb 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -2922,7 +2922,7 @@ package body Bindgen is Osint.Fail ("bind environment value """ & Value & """ too long"); end if; - Bind_Environment.Set (Name_Find_Str (Key), Name_Find_Str (Value)); + Bind_Environment.Set (Name_Find (Key), Name_Find (Value)); end Set_Bind_Env; ----------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index f743322..25a9fe0 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1693,9 +1693,10 @@ package body Exp_Ch5 is -- The attribute Priority applied to protected objects has been -- previously expanded into a call to the Get_Ceiling run-time - -- subprogram. + -- subprogram. In restricted profiles this is not available. if Nkind (Ent) = N_Function_Call + and then RTE_Available (RE_Get_Ceiling) and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) or else Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling)) diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index d705308..fbc6a7b 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -161,7 +161,7 @@ package body Exp_Unst is function AREC_Name (J : Pos; S : String) return Name_Id is begin - return Name_Find_Str ("AREC" & Img_Pos (J) & S); + return Name_Find ("AREC" & Img_Pos (J) & S); end AREC_Name; -------------------- @@ -244,7 +244,7 @@ package body Exp_Unst is if No (C) then return Chars (Ent); elsif Chars (Defining_Identifier (C)) = Chars (Ent) then - return Name_Find_Str + return Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index)); else Next (C); diff --git a/gcc/ada/namet-sp.ads b/gcc/ada/namet-sp.ads index 87e0824..1f42029 100644 --- a/gcc/ada/namet-sp.ads +++ b/gcc/ada/namet-sp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -31,7 +31,7 @@ -- This child package contains a spell checker for Name_Id values. It is -- separated off as a child package, because of the extra dependencies, --- in particular on GNAT.UTF_32_ Spelling_Checker. There are a number of +-- in particular on GNAT.UTF_32_Spelling_Checker. There are a number of -- packages that use Namet that do not need the spell checking feature, -- and this separation helps in dealing with older versions of GNAT. diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 902f347..20359f6 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -73,16 +73,14 @@ package body Namet is -- Local Subprograms -- ----------------------- - function Hash return Hash_Index_Type; + function Hash (Buf : Bounded_String) return Hash_Index_Type; pragma Inline (Hash); - -- Compute hash code for name stored in Name_Buffer (length in Name_Len) + -- Compute hash code for name stored in Buf - procedure Strip_Qualification_And_Suffixes; - -- Given an encoded entity name in Name_Buffer, remove package body + procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String); + -- Given an encoded entity name in Buf, remove package body -- suffix as described for Strip_Package_Body_Suffix, and also remove - -- all qualification, i.e. names followed by two underscores. The - -- contents of Name_Buffer is modified by this call, and on return - -- Name_Buffer and Name_Len reflect the stripped name. + -- all qualification, i.e. names followed by two underscores. ----------------------------- -- Add_Char_To_Name_Buffer -- @@ -90,10 +88,7 @@ package body Namet is procedure Add_Char_To_Name_Buffer (C : Character) is begin - if Name_Len < Name_Buffer'Last then - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := C; - end if; + Append (Global_Name_Buffer, C); end Add_Char_To_Name_Buffer; ---------------------------- @@ -102,11 +97,7 @@ package body Namet is procedure Add_Nat_To_Name_Buffer (V : Nat) is begin - if V >= 10 then - Add_Nat_To_Name_Buffer (V / 10); - end if; - - Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10)); + Append (Global_Name_Buffer, V); end Add_Nat_To_Name_Buffer; ---------------------------- @@ -115,171 +106,56 @@ package body Namet is procedure Add_Str_To_Name_Buffer (S : String) is begin - for J in S'Range loop - Add_Char_To_Name_Buffer (S (J)); - end loop; + Append (Global_Name_Buffer, S); end Add_Str_To_Name_Buffer; - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - 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. - - Max_Chain_Length : Int := 0; - -- Maximum length of all chains - - Probes : Int := 0; - -- Used to compute average number of probes - - Nsyms : Int := 0; - -- Number of symbols in table - - Verbosity : constant Int range 1 .. 3 := 1; - pragma Warnings (Off, Verbosity); - -- This constant indicates the level of verbosity in the output from - -- this procedure. Currently this can only be changed by editing the - -- declaration above and recompiling. That's good enough in practice, - -- since we very rarely need to use this debug option. Settings are: - -- - -- 1 => print basic summary information - -- 2 => in addition print number of entries per hash chain - -- 3 => in addition print content of entries - - Zero : constant Int := Character'Pos ('0'); + ------------ + -- Append -- + ------------ + procedure Append (Buf : in out Bounded_String; C : Character) is begin - if not Debug_Flag_H then - return; + if Buf.Length < Buf.Chars'Last then + Buf.Length := Buf.Length + 1; + Buf.Chars (Buf.Length) := C; end if; + end Append; - for J in F'Range loop - F (J) := 0; - end loop; - - for J in Hash_Index_Type loop - if Hash_Table (J) = No_Name then - F (0) := F (0) + 1; - - 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; - - Nsyms := Nsyms + 1; - Probes := Probes + (1 + C) * 100; - - 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 < F'Last then - F (C) := F (C) + 1; - else - F (F'Last) := F (F'Last) + 1; - end if; - - if Verbosity >= 3 then - N := Hash_Table (J); - while N /= No_Name loop - S := Name_Entries.Table (N).Name_Chars_Index; - - Write_Str (" "); - - for J in 1 .. Name_Entries.Table (N).Name_Len loop - Write_Char (Name_Chars.Table (S + Int (J))); - end loop; + procedure Append (Buf : in out Bounded_String; V : Nat) is + begin + if V >= 10 then + Append (Buf, V / 10); + end if; - Write_Eol; + Append (Buf, Character'Val (Character'Pos ('0') + V rem 10)); + end Append; - N := Name_Entries.Table (N).Hash_Link; - end loop; - end if; - end; - end if; + procedure Append (Buf : in out Bounded_String; S : String) is + begin + for J in S'Range loop + Append (Buf, S (J)); end loop; + end Append; - Write_Eol; - - for J in F'Range loop - if F (J) /= 0 then - Write_Str ("Number of hash chains of length "); - - if J < 10 then - Write_Char (' '); - end if; - - Write_Int (J); - - if J = F'Last then - Write_Str (" or greater"); - end if; - - Write_Str (" = "); - Write_Int (F (J)); - Write_Eol; - end if; + procedure Append (Buf : in out Bounded_String; Id : Name_Id) is + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + S : constant Int := Name_Entries.Table (Id).Name_Chars_Index; + begin + for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop + Append (Buf, Name_Chars.Table (S + Int (J))); end loop; + end Append; - -- 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 (Zero + Probes / 10)); - Write_Char (Character'Val (Zero + 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; - - ----------------------------- - -- Get_Decoded_Name_String -- - ----------------------------- + -------------------- + -- Append_Decoded -- + -------------------- - procedure Get_Decoded_Name_String (Id : Name_Id) is + procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is C : Character; P : Natural; begin - Get_Name_String (Id); + Append (Buf, Id); -- Skip scan if we already know there are no encodings @@ -291,12 +167,12 @@ package body Namet is P := 1; loop - if P = Name_Len then + if P = Buf.Length then Name_Entries.Table (Id).Name_Has_No_Encodings := True; return; else - C := Name_Buffer (P); + C := Buf.Chars (P); exit when C = 'U' or else @@ -313,10 +189,10 @@ package body Namet is Decode : declare New_Len : Natural; Old : Positive; - New_Buf : String (1 .. Name_Buffer'Last); + New_Buf : String (1 .. Buf.Chars'Last); procedure Copy_One_Character; - -- Copy a character from Name_Buffer to New_Buf. Includes case + -- Copy a character from Buf.Chars to New_Buf. Includes case -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it. function Hex (N : Natural) return Word; @@ -333,14 +209,14 @@ package body Namet is C : Character; begin - C := Name_Buffer (Old); + C := Buf.Chars (Old); -- U (upper half insertion case) if C = 'U' - and then Old < Name_Len - and then Name_Buffer (Old + 1) not in 'A' .. 'Z' - and then Name_Buffer (Old + 1) /= '_' + and then Old < Buf.Length + and then Buf.Chars (Old + 1) not in 'A' .. 'Z' + and then Buf.Chars (Old + 1) /= '_' then Old := Old + 1; @@ -360,8 +236,8 @@ package body Namet is -- WW (wide wide character insertion) elsif C = 'W' - and then Old < Name_Len - and then Name_Buffer (Old + 1) = 'W' + and then Old < Buf.Length + and then Buf.Chars (Old + 1) = 'W' then Old := Old + 2; Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len); @@ -369,9 +245,9 @@ package body Namet is -- W (wide character insertion) elsif C = 'W' - and then Old < Name_Len - and then Name_Buffer (Old + 1) not in 'A' .. 'Z' - and then Name_Buffer (Old + 1) /= '_' + and then Old < Buf.Length + and then Buf.Chars (Old + 1) not in 'A' .. 'Z' + and then Buf.Chars (Old + 1) /= '_' then Old := Old + 1; Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len); @@ -394,7 +270,7 @@ package body Namet is begin for J in 1 .. N loop - C := Name_Buffer (Old); + C := Buf.Chars (Old); Old := Old + 1; pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f'); @@ -427,12 +303,12 @@ package body Namet is -- Loop through characters of name - while Old <= Name_Len loop + while Old <= Buf.Length loop -- Case of character literal, put apostrophes around character - if Name_Buffer (Old) = 'Q' - and then Old < Name_Len + if Buf.Chars (Old) = 'Q' + and then Old < Buf.Length then Old := Old + 1; Insert_Character ('''); @@ -441,10 +317,10 @@ package body Namet is -- Case of operator name - elsif Name_Buffer (Old) = 'O' - and then Old < Name_Len - and then Name_Buffer (Old + 1) not in 'A' .. 'Z' - and then Name_Buffer (Old + 1) /= '_' + elsif Buf.Chars (Old) = 'O' + and then Old < Buf.Length + and then Buf.Chars (Old + 1) not in 'A' .. 'Z' + and then Buf.Chars (Old + 1) /= '_' then Old := Old + 1; @@ -485,8 +361,8 @@ package body Namet is J := Map'First; loop - exit when Name_Buffer (Old) = Map (J) - and then Name_Buffer (Old + 1) = Map (J + 1); + exit when Buf.Chars (Old) = Map (J) + and then Buf.Chars (Old + 1) = Map (J + 1); J := J + 4; end loop; @@ -503,8 +379,8 @@ package body Namet is -- Skip past original operator name in input - while Old <= Name_Len - and then Name_Buffer (Old) in 'a' .. 'z' + while Old <= Buf.Length + and then Buf.Chars (Old) in 'a' .. 'z' loop Old := Old + 1; end loop; @@ -515,8 +391,8 @@ package body Namet is else -- Copy original operator name from input to output - while Old <= Name_Len - and then Name_Buffer (Old) in 'a' .. 'z' + while Old <= Buf.Length + and then Buf.Chars (Old) in 'a' .. 'z' loop Copy_One_Character; end loop; @@ -534,87 +410,88 @@ package body Namet is -- Copy new buffer as result - Name_Len := New_Len; - Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len); + Buf.Length := New_Len; + Buf.Chars (1 .. New_Len) := New_Buf (1 .. New_Len); end Decode; - end Get_Decoded_Name_String; + end Append_Decoded; - ------------------------------------------- - -- Get_Decoded_Name_String_With_Brackets -- - ------------------------------------------- + ---------------------------------- + -- Append_Decoded_With_Brackets -- + ---------------------------------- - procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is + procedure Append_Decoded_With_Brackets + (Buf : in out Bounded_String; Id : Name_Id) is P : Natural; begin -- Case of operator name, normal decoding is fine - if Name_Buffer (1) = 'O' then - Get_Decoded_Name_String (Id); + if Buf.Chars (1) = 'O' then + Append_Decoded (Buf, Id); -- For character literals, normal decoding is fine - elsif Name_Buffer (1) = 'Q' then - Get_Decoded_Name_String (Id); + elsif Buf.Chars (1) = 'Q' then + Append_Decoded (Buf, Id); -- Only remaining issue is U/W/WW sequences else - Get_Name_String (Id); + Append (Buf, Id); P := 1; - while P < Name_Len loop - if Name_Buffer (P + 1) in 'A' .. 'Z' then + while P < Buf.Length loop + if Buf.Chars (P + 1) in 'A' .. 'Z' then P := P + 1; -- Uhh encoding - elsif Name_Buffer (P) = 'U' then - for J in reverse P + 3 .. P + Name_Len loop - Name_Buffer (J + 3) := Name_Buffer (J); + elsif Buf.Chars (P) = 'U' then + for J in reverse P + 3 .. P + Buf.Length loop + Buf.Chars (J + 3) := Buf.Chars (J); end loop; - Name_Len := Name_Len + 3; - Name_Buffer (P + 3) := Name_Buffer (P + 2); - Name_Buffer (P + 2) := Name_Buffer (P + 1); - Name_Buffer (P) := '['; - Name_Buffer (P + 1) := '"'; - Name_Buffer (P + 4) := '"'; - Name_Buffer (P + 5) := ']'; + Buf.Length := Buf.Length + 3; + Buf.Chars (P + 3) := Buf.Chars (P + 2); + Buf.Chars (P + 2) := Buf.Chars (P + 1); + Buf.Chars (P) := '['; + Buf.Chars (P + 1) := '"'; + Buf.Chars (P + 4) := '"'; + Buf.Chars (P + 5) := ']'; P := P + 6; -- WWhhhhhhhh encoding - elsif Name_Buffer (P) = 'W' - and then P + 9 <= Name_Len - and then Name_Buffer (P + 1) = 'W' - and then Name_Buffer (P + 2) not in 'A' .. 'Z' - and then Name_Buffer (P + 2) /= '_' + elsif Buf.Chars (P) = 'W' + and then P + 9 <= Buf.Length + and then Buf.Chars (P + 1) = 'W' + and then Buf.Chars (P + 2) not in 'A' .. 'Z' + and then Buf.Chars (P + 2) /= '_' then - Name_Buffer (P + 12 .. Name_Len + 2) := - Name_Buffer (P + 10 .. Name_Len); - Name_Buffer (P) := '['; - Name_Buffer (P + 1) := '"'; - Name_Buffer (P + 10) := '"'; - Name_Buffer (P + 11) := ']'; - Name_Len := Name_Len + 2; + Buf.Chars (P + 12 .. Buf.Length + 2) := + Buf.Chars (P + 10 .. Buf.Length); + Buf.Chars (P) := '['; + Buf.Chars (P + 1) := '"'; + Buf.Chars (P + 10) := '"'; + Buf.Chars (P + 11) := ']'; + Buf.Length := Buf.Length + 2; P := P + 12; -- Whhhh encoding - elsif Name_Buffer (P) = 'W' - and then P < Name_Len - and then Name_Buffer (P + 1) not in 'A' .. 'Z' - and then Name_Buffer (P + 1) /= '_' + elsif Buf.Chars (P) = 'W' + and then P < Buf.Length + and then Buf.Chars (P + 1) not in 'A' .. 'Z' + and then Buf.Chars (P + 1) /= '_' then - Name_Buffer (P + 8 .. P + Name_Len + 3) := - Name_Buffer (P + 5 .. Name_Len); - Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4); - Name_Buffer (P) := '['; - Name_Buffer (P + 1) := '"'; - Name_Buffer (P + 6) := '"'; - Name_Buffer (P + 7) := ']'; - Name_Len := Name_Len + 3; + Buf.Chars (P + 8 .. P + Buf.Length + 3) := + Buf.Chars (P + 5 .. Buf.Length); + Buf.Chars (P + 2 .. P + 5) := Buf.Chars (P + 1 .. P + 4); + Buf.Chars (P) := '['; + Buf.Chars (P + 1) := '"'; + Buf.Chars (P + 6) := '"'; + Buf.Chars (P + 7) := ']'; + Buf.Length := Buf.Length + 3; P := P + 8; else @@ -622,6 +499,253 @@ package body Namet is end if; end loop; end if; + end Append_Decoded_With_Brackets; + + -------------------- + -- Append_Encoded -- + -------------------- + + procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code) is + procedure Set_Hex_Chars (C : Char_Code); + -- Stores given value, which is in the range 0 .. 255, as two hex + -- digits (using lower case a-f) in Buf.Chars, incrementing Buf.Length. + + ------------------- + -- Set_Hex_Chars -- + ------------------- + + procedure Set_Hex_Chars (C : Char_Code) is + Hexd : constant String := "0123456789abcdef"; + N : constant Natural := Natural (C); + begin + Buf.Chars (Buf.Length + 1) := Hexd (N / 16 + 1); + Buf.Chars (Buf.Length + 2) := Hexd (N mod 16 + 1); + Buf.Length := Buf.Length + 2; + end Set_Hex_Chars; + + -- Start of processing for Append_Encoded + + begin + Buf.Length := Buf.Length + 1; + + if In_Character_Range (C) then + declare + CC : constant Character := Get_Character (C); + begin + if CC in 'a' .. 'z' or else CC in '0' .. '9' then + Buf.Chars (Buf.Length) := CC; + else + Buf.Chars (Buf.Length) := 'U'; + Set_Hex_Chars (C); + end if; + end; + + elsif In_Wide_Character_Range (C) then + Buf.Chars (Buf.Length) := 'W'; + Set_Hex_Chars (C / 256); + Set_Hex_Chars (C mod 256); + + else + Buf.Chars (Buf.Length) := 'W'; + Buf.Length := Buf.Length + 1; + Buf.Chars (Buf.Length) := 'W'; + Set_Hex_Chars (C / 2 ** 24); + Set_Hex_Chars ((C / 2 ** 16) mod 256); + Set_Hex_Chars ((C / 256) mod 256); + Set_Hex_Chars (C mod 256); + end if; + end Append_Encoded; + + ------------------------ + -- Append_Unqualified -- + ------------------------ + + procedure Append_Unqualified + (Buf : in out Bounded_String; Id : Name_Id) is + begin + Append (Buf, Id); + Strip_Qualification_And_Suffixes (Buf); + end Append_Unqualified; + + -------------------------------- + -- Append_Unqualified_Decoded -- + -------------------------------- + + procedure Append_Unqualified_Decoded + (Buf : in out Bounded_String; Id : Name_Id) is + begin + Append_Decoded (Buf, Id); + Strip_Qualification_And_Suffixes (Buf); + end Append_Unqualified_Decoded; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + 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. + + Max_Chain_Length : Int := 0; + -- Maximum length of all chains + + Probes : Int := 0; + -- Used to compute average number of probes + + Nsyms : Int := 0; + -- Number of symbols in table + + Verbosity : constant Int range 1 .. 3 := 1; + pragma Warnings (Off, Verbosity); + -- This constant indicates the level of verbosity in the output from + -- this procedure. Currently this can only be changed by editing the + -- declaration above and recompiling. That's good enough in practice, + -- since we very rarely need to use this debug option. Settings are: + -- + -- 1 => print basic summary information + -- 2 => in addition print number of entries per hash chain + -- 3 => in addition print content of entries + + Zero : constant Int := Character'Pos ('0'); + + begin + if not Debug_Flag_H then + return; + end if; + + for J in F'Range loop + F (J) := 0; + end loop; + + for J in Hash_Index_Type loop + if Hash_Table (J) = No_Name then + F (0) := F (0) + 1; + + 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; + + Nsyms := Nsyms + 1; + Probes := Probes + (1 + C) * 100; + + 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 < F'Last then + F (C) := F (C) + 1; + else + F (F'Last) := F (F'Last) + 1; + end if; + + if Verbosity >= 3 then + N := Hash_Table (J); + while N /= No_Name loop + S := Name_Entries.Table (N).Name_Chars_Index; + + Write_Str (" "); + + for J in 1 .. Name_Entries.Table (N).Name_Len loop + Write_Char (Name_Chars.Table (S + Int (J))); + end loop; + + Write_Eol; + + N := Name_Entries.Table (N).Hash_Link; + end loop; + end if; + end; + end if; + end loop; + + Write_Eol; + + for J in F'Range loop + if F (J) /= 0 then + Write_Str ("Number of hash chains of length "); + + if J < 10 then + Write_Char (' '); + end if; + + Write_Int (J); + + if J = F'Last then + Write_Str (" or greater"); + 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 (Zero + Probes / 10)); + Write_Char (Character'Val (Zero + 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; + + ----------------------------- + -- Get_Decoded_Name_String -- + ----------------------------- + + procedure Get_Decoded_Name_String (Id : Name_Id) is + begin + Global_Name_Buffer.Length := 0; + Append_Decoded (Global_Name_Buffer, Id); + end Get_Decoded_Name_String; + + ------------------------------------------- + -- Get_Decoded_Name_String_With_Brackets -- + ------------------------------------------- + + procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is + begin + Global_Name_Buffer.Length := 0; + Append_Decoded_With_Brackets (Global_Name_Buffer, Id); end Get_Decoded_Name_String_With_Brackets; ------------------------ @@ -650,45 +774,17 @@ package body Namet is -- Get_Name_String -- --------------------- - -- Procedure version leaving result in Name_Buffer, length in Name_Len - procedure Get_Name_String (Id : Name_Id) is - S : Int; - begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); - - S := Name_Entries.Table (Id).Name_Chars_Index; - Name_Len := Natural (Name_Entries.Table (Id).Name_Len); - - for J in 1 .. Name_Len loop - Name_Buffer (J) := Name_Chars.Table (S + Int (J)); - end loop; + Global_Name_Buffer.Length := 0; + Append (Global_Name_Buffer, Id); end Get_Name_String; - --------------------- - -- Get_Name_String -- - --------------------- - - -- Function version returning a string - function Get_Name_String (Id : Name_Id) return String is - S : Int; - + Buf : Bounded_String; begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); - S := Name_Entries.Table (Id).Name_Chars_Index; - - declare - R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len)); - - begin - for J in R'Range loop - R (J) := Name_Chars.Table (S + Int (J)); - end loop; - - return R; - end; + Append (Buf, Id); + return +Buf; end Get_Name_String; -------------------------------- @@ -696,17 +792,8 @@ package body Namet is -------------------------------- procedure Get_Name_String_And_Append (Id : Name_Id) is - S : Int; - begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); - - S := Name_Entries.Table (Id).Name_Chars_Index; - - for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J)); - end loop; + Append (Global_Name_Buffer, Id); end Get_Name_String_And_Append; ----------------------------- @@ -765,8 +852,8 @@ package body Namet is procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is begin - Get_Decoded_Name_String (Id); - Strip_Qualification_And_Suffixes; + Global_Name_Buffer.Length := 0; + Append_Unqualified_Decoded (Global_Name_Buffer, Id); end Get_Unqualified_Decoded_Name_String; --------------------------------- @@ -775,15 +862,15 @@ package body Namet is procedure Get_Unqualified_Name_String (Id : Name_Id) is begin - Get_Name_String (Id); - Strip_Qualification_And_Suffixes; + Global_Name_Buffer.Length := 0; + Append_Unqualified (Global_Name_Buffer, Id); end Get_Unqualified_Name_String; ---------- -- Hash -- ---------- - function Hash return Hash_Index_Type is + function Hash (Buf : Bounded_String) return Hash_Index_Type is -- This hash function looks at every character, in order to make it -- likely that similar strings get different hash values. The rotate by @@ -800,8 +887,8 @@ package body Namet is Result : Unsigned_16 := 0; begin - for J in 1 .. Name_Len loop - Result := Rotate_Left (Result, 7) xor Character'Pos (Name_Buffer (J)); + for J in 1 .. Buf.Length loop + Result := Rotate_Left (Result, 7) xor Character'Pos (Buf.Chars (J)); end loop; return Hash_Index_Type (Result); @@ -816,55 +903,47 @@ package body Namet is null; end Initialize; + ---------------- + -- Insert_Str -- + ---------------- + + procedure Insert_Str + (Buf : in out Bounded_String; S : String; Index : Positive) is + SL : constant Natural := S'Length; + begin + Buf.Chars (Index + SL .. Buf.Length + SL) := + Buf.Chars (Index .. Buf.Length); + Buf.Chars (Index .. Index + SL - 1) := S; + Buf.Length := Buf.Length + SL; + end Insert_Str; + ------------------------------- -- Insert_Str_In_Name_Buffer -- ------------------------------- procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is - SL : constant Natural := S'Length; begin - Name_Buffer (Index + SL .. Name_Len + SL) := - Name_Buffer (Index .. Name_Len); - Name_Buffer (Index .. Index + SL - 1) := S; - Name_Len := Name_Len + SL; + Insert_Str (Global_Name_Buffer, S, Index); end Insert_Str_In_Name_Buffer; ---------------------- -- Is_Internal_Name -- ---------------------- - -- Version taking an argument - - function Is_Internal_Name (Id : Name_Id) return Boolean is - begin - if Id in Error_Name_Or_No_Name then - return False; - else - Get_Name_String (Id); - return Is_Internal_Name; - end if; - end Is_Internal_Name; - - ---------------------- - -- Is_Internal_Name -- - ---------------------- - - -- Version taking its input from Name_Buffer - - function Is_Internal_Name return Boolean is + function Is_Internal_Name (Buf : Bounded_String) return Boolean is J : Natural; begin - -- AAny name starting with underscore is internal + -- Any name starting or ending with underscore is internal - if Name_Buffer (1) = '_' - or else Name_Buffer (Name_Len) = '_' + if Buf.Chars (1) = '_' + or else Buf.Chars (Buf.Length) = '_' then return True; -- Allow quoted character - elsif Name_Buffer (1) = ''' then + elsif Buf.Chars (1) = ''' then return False; -- All other cases, scan name @@ -873,30 +952,30 @@ package body Namet is -- Test backwards, because we only want to test the last entity -- name if the name we have is qualified with other entities. - J := Name_Len; + J := Buf.Length; while J /= 0 loop -- Skip stuff between brackets (A-F OK there) - if Name_Buffer (J) = ']' then + if Buf.Chars (J) = ']' then loop J := J - 1; - exit when J = 1 or else Name_Buffer (J) = '['; + exit when J = 1 or else Buf.Chars (J) = '['; end loop; -- Test for internal letter - elsif Is_OK_Internal_Letter (Name_Buffer (J)) then + elsif Is_OK_Internal_Letter (Buf.Chars (J)) then return True; -- Quit if we come to terminating double underscore (note that -- if the current character is an underscore, we know that -- there is a previous character present, since we already - -- filtered out the case of Name_Buffer (1) = '_' above. + -- filtered out the case of Buf.Chars (1) = '_' above. - elsif Name_Buffer (J) = '_' - and then Name_Buffer (J - 1) = '_' - and then Name_Buffer (J - 2) /= '_' + elsif Buf.Chars (J) = '_' + and then Buf.Chars (J - 1) = '_' + and then Buf.Chars (J - 2) /= '_' then return False; end if; @@ -908,6 +987,22 @@ package body Namet is return False; end Is_Internal_Name; + function Is_Internal_Name (Id : Name_Id) return Boolean is + Buf : Bounded_String; + begin + if Id in Error_Name_Or_No_Name then + return False; + else + Append (Buf, Id); + return Is_Internal_Name (Buf); + end if; + end Is_Internal_Name; + + function Is_Internal_Name return Boolean is + begin + return Is_Internal_Name (Global_Name_Buffer); + end Is_Internal_Name; + --------------------------- -- Is_OK_Internal_Letter -- --------------------------- @@ -979,11 +1074,13 @@ package body Namet is -- Name_Enter -- ---------------- - function Name_Enter return Name_Id is + function Name_Enter + (Buf : Bounded_String := Global_Name_Buffer) return Name_Id + is begin Name_Entries.Append ((Name_Chars_Index => Name_Chars.Last, - Name_Len => Short (Name_Len), + Name_Len => Short (Buf.Length), Byte_Info => 0, Int_Info => 0, Boolean1_Info => False, @@ -994,8 +1091,8 @@ package body Namet is -- Set corresponding string entry in the Name_Chars table - for J in 1 .. Name_Len loop - Name_Chars.Append (Name_Buffer (J)); + for J in 1 .. Buf.Length loop + Name_Chars.Append (Buf.Chars (J)); end loop; Name_Chars.Append (ASCII.NUL); @@ -1025,7 +1122,9 @@ package body Namet is -- Name_Find -- --------------- - function Name_Find return Name_Id is + function Name_Find + (Buf : Bounded_String := Global_Name_Buffer) return Name_Id + is New_Id : Name_Id; -- Id of entry in hash search, and value to be returned @@ -1038,13 +1137,13 @@ package body Namet is begin -- Quick handling for one character names - if Name_Len = 1 then - return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1))); + if Buf.Length = 1 then + return Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1))); -- Otherwise search hash table for existing matching entry else - Hash_Index := Namet.Hash; + Hash_Index := Namet.Hash (Buf); New_Id := Hash_Table (Hash_Index); if New_Id = No_Name then @@ -1052,7 +1151,7 @@ package body Namet is else Search : loop - if Name_Len /= + if Buf.Length /= Integer (Name_Entries.Table (New_Id).Name_Len) then goto No_Match; @@ -1060,8 +1159,8 @@ package body Namet is S := Name_Entries.Table (New_Id).Name_Chars_Index; - for J in 1 .. Name_Len loop - if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then + for J in 1 .. Buf.Length loop + if Name_Chars.Table (S + Int (J)) /= Buf.Chars (J) then goto No_Match; end if; end loop; @@ -1087,7 +1186,7 @@ package body Namet is Name_Entries.Append ((Name_Chars_Index => Name_Chars.Last, - Name_Len => Short (Name_Len), + Name_Len => Short (Buf.Length), Hash_Link => No_Name, Name_Has_No_Encodings => False, Int_Info => 0, @@ -1098,8 +1197,8 @@ package body Namet is -- Set corresponding string entry in the Name_Chars table - for J in 1 .. Name_Len loop - Name_Chars.Append (Name_Buffer (J)); + for J in 1 .. Buf.Length loop + Name_Chars.Append (Buf.Chars (J)); end loop; Name_Chars.Append (ASCII.NUL); @@ -1108,16 +1207,12 @@ package body Namet is end if; end Name_Find; - ------------------- - -- Name_Find_Str -- - ------------------- - - function Name_Find_Str (S : String) return Name_Id is + function Name_Find (S : String) return Name_Id is + Buf : Bounded_String; begin - Name_Len := S'Length; - Name_Buffer (1 .. Name_Len) := S; - return Name_Find; - end Name_Find_Str; + Append (Buf, S); + return Name_Find (Buf); + end Name_Find; ------------- -- Nam_In -- @@ -1319,29 +1414,7 @@ package body Namet is function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean is begin - if N1 = N2 then - return True; - end if; - - declare - L1 : constant Int := Int (Name_Entries.Table (N1).Name_Len); - L2 : constant Int := Int (Name_Entries.Table (N2).Name_Len); - - begin - if L1 /= L2 then - return False; - end if; - - declare - use Name_Chars; - I1 : constant Int := Name_Entries.Table (N1).Name_Chars_Index; - I2 : constant Int := Name_Entries.Table (N2).Name_Chars_Index; - - begin - return (Name_Chars.Table (1 + I1 .. I1 + L1) = - Name_Chars.Table (1 + I2 .. I2 + L2)); - end; - end; + return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2); end Name_Equals; ------------------ @@ -1394,11 +1467,17 @@ package body Namet is -- Set_Character_Literal_Name -- -------------------------------- + procedure Set_Character_Literal_Name + (Buf : in out Bounded_String; C : Char_Code) is + begin + Buf.Length := 0; + Append (Buf, 'Q'); + Append_Encoded (Buf, C); + end Set_Character_Literal_Name; + procedure Set_Character_Literal_Name (C : Char_Code) is begin - Name_Buffer (1) := 'Q'; - Name_Len := 1; - Store_Encoded_Character (C); + Set_Character_Literal_Name (Global_Name_Buffer, C); end Set_Character_Literal_Name; ----------------------------- @@ -1456,89 +1535,43 @@ package body Namet is ----------------------------- procedure Store_Encoded_Character (C : Char_Code) is - procedure Set_Hex_Chars (C : Char_Code); - -- Stores given value, which is in the range 0 .. 255, as two hex - -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len. - - ------------------- - -- Set_Hex_Chars -- - ------------------- - - procedure Set_Hex_Chars (C : Char_Code) is - Hexd : constant String := "0123456789abcdef"; - N : constant Natural := Natural (C); - begin - Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1); - Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1); - Name_Len := Name_Len + 2; - end Set_Hex_Chars; - - -- Start of processing for Store_Encoded_Character - begin - Name_Len := Name_Len + 1; - - if In_Character_Range (C) then - declare - CC : constant Character := Get_Character (C); - begin - if CC in 'a' .. 'z' or else CC in '0' .. '9' then - Name_Buffer (Name_Len) := CC; - else - Name_Buffer (Name_Len) := 'U'; - Set_Hex_Chars (C); - end if; - end; - - elsif In_Wide_Character_Range (C) then - Name_Buffer (Name_Len) := 'W'; - Set_Hex_Chars (C / 256); - Set_Hex_Chars (C mod 256); - - else - Name_Buffer (Name_Len) := 'W'; - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := 'W'; - Set_Hex_Chars (C / 2 ** 24); - Set_Hex_Chars ((C / 2 ** 16) mod 256); - Set_Hex_Chars ((C / 256) mod 256); - Set_Hex_Chars (C mod 256); - end if; + Append_Encoded (Global_Name_Buffer, C); end Store_Encoded_Character; -------------------------------------- -- Strip_Qualification_And_Suffixes -- -------------------------------------- - procedure Strip_Qualification_And_Suffixes is + procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String) is J : Integer; begin -- Strip package body qualification string off end - for J in reverse 2 .. Name_Len loop - if Name_Buffer (J) = 'X' then - Name_Len := J - 1; + for J in reverse 2 .. Buf.Length loop + if Buf.Chars (J) = 'X' then + Buf.Length := J - 1; exit; end if; - exit when Name_Buffer (J) /= 'b' - and then Name_Buffer (J) /= 'n' - and then Name_Buffer (J) /= 'p'; + exit when Buf.Chars (J) /= 'b' + and then Buf.Chars (J) /= 'n' + and then Buf.Chars (J) /= 'p'; end loop; -- Find rightmost __ or $ separator if one exists. First we position -- to start the search. If we have a character constant, position -- just before it, otherwise position to last character but one - if Name_Buffer (Name_Len) = ''' then - J := Name_Len - 2; - while J > 0 and then Name_Buffer (J) /= ''' loop + if Buf.Chars (Buf.Length) = ''' then + J := Buf.Length - 2; + while J > 0 and then Buf.Chars (J) /= ''' loop J := J - 1; end loop; else - J := Name_Len - 1; + J := Buf.Length - 1; end if; -- Loop to search for rightmost __ or $ (homonym) separator @@ -1547,28 +1580,28 @@ package body Namet is -- If $ separator, homonym separator, so strip it and keep looking - if Name_Buffer (J) = '$' then - Name_Len := J - 1; - J := Name_Len - 1; + if Buf.Chars (J) = '$' then + Buf.Length := J - 1; + J := Buf.Length - 1; -- Else check for __ found - elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then + elsif Buf.Chars (J) = '_' and then Buf.Chars (J + 1) = '_' then -- Found __ so see if digit follows, and if so, this is a -- homonym separator, so strip it and keep looking. - if Name_Buffer (J + 2) in '0' .. '9' then - Name_Len := J - 1; - J := Name_Len - 1; + if Buf.Chars (J + 2) in '0' .. '9' then + Buf.Length := J - 1; + J := Buf.Length - 1; -- If not a homonym separator, then we simply strip the -- separator and everything that precedes it, and we are done else - Name_Buffer (1 .. Name_Len - J - 1) := - Name_Buffer (J + 2 .. Name_Len); - Name_Len := Name_Len - J - 1; + Buf.Chars (1 .. Buf.Length - J - 1) := + Buf.Chars (J + 2 .. Buf.Length); + Buf.Length := Buf.Length - J - 1; exit; end if; @@ -1579,6 +1612,15 @@ package body Namet is end Strip_Qualification_And_Suffixes; --------------- + -- To_String -- + --------------- + + function To_String (X : Bounded_String) return String is + begin + return X.Chars (1 .. X.Length); + end To_String; + + --------------- -- Tree_Read -- --------------- @@ -1625,10 +1667,8 @@ package body Namet is -------- procedure wn (Id : Name_Id) is - S : Int; - begin - if not Id'Valid then + if Id not in Name_Entries.First .. Name_Entries.Last then Write_Str ("<invalid name_id>"); elsif Id = No_Name then @@ -1638,12 +1678,12 @@ package body Namet is Write_Str ("<Error_Name>"); else - S := Name_Entries.Table (Id).Name_Chars_Index; - Name_Len := Natural (Name_Entries.Table (Id).Name_Len); - - for J in 1 .. Name_Len loop - Write_Char (Name_Chars.Table (S + Int (J))); - end loop; + declare + Buf : Bounded_String; + begin + Append (Buf, Id); + Write_Str (Buf.Chars (1 .. Buf.Length)); + end; end if; Write_Eol; @@ -1654,10 +1694,11 @@ package body Namet is ---------------- procedure Write_Name (Id : Name_Id) is + Buf : Bounded_String; begin if Id >= First_Name_Id then - Get_Name_String (Id); - Write_Str (Name_Buffer (1 .. Name_Len)); + Append (Buf, Id); + Write_Str (Buf.Chars (1 .. Buf.Length)); end if; end Write_Name; @@ -1666,10 +1707,11 @@ package body Namet is ------------------------ procedure Write_Name_Decoded (Id : Name_Id) is + Buf : Bounded_String; begin if Id >= First_Name_Id then - Get_Decoded_Name_String (Id); - Write_Str (Name_Buffer (1 .. Name_Len)); + Append_Decoded (Buf, Id); + Write_Str (Buf.Chars (1 .. Buf.Length)); end if; end Write_Name_Decoded; diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index fa30a8a..873897f 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -51,7 +51,7 @@ package Namet is -- Upper half (16#80# bit set) and wide characters are -- stored in an encoded form (Uhh for upper half char, -- Whhhh for wide characters, WWhhhhhhhh as provided by --- the routine Store_Encoded_Character, where hh are hex +-- the routine Append_Encoded, where hh are hex -- digits for the character code using lower case a-f). -- Normally the use of U or W in other internal names is -- avoided, but these letters may be used in internal @@ -149,21 +149,30 @@ package Namet is -- and the Boolean field is initialized to False, when a new Name table entry -- is created. - Name_Buffer : String (1 .. 4 * Max_Line_Length); - -- This buffer is used to set the name to be stored in the table for the - -- Name_Find call, and to retrieve the name for the Get_Name_String call. - -- The limit here is intended to be an infinite value that ensures that we - -- never overflow the buffer (names this long are too absurd to worry). - - Name_Len : Natural := 0; - -- Length of name stored in Name_Buffer. Used as an input parameter for - -- Name_Find, and as an output value by Get_Name_String, or Write_Name. - -- Note: in normal usage, all users of Name_Buffer/Name_Len are expected - -- to initialize Name_Len appropriately. The reason we preinitialize to - -- zero here is that some circuitry (e.g. Osint.Write_Program_Name) does - -- a save/restore on Name_Len and Name_Buffer (1 .. Name_Len), and we do - -- not want some arbitrary junk value to result in saving an arbitrarily - -- long slice which would waste time and blow the stack. + type Bounded_String (Max_Length : Natural := 4 * Max_Line_Length) is limited + -- The default here is intended to be an infinite value that ensures that + -- we never overflow the buffer (names this long are too absurd to worry). + record + Length : Natural := 0; + Chars : String (1 .. Max_Length); + end record; + + -- To create a Name_Id, you can declare a Bounded_String as a local + -- variable, and Append things onto it, and finally call Name_Find. + -- You can also use a String, as in: + -- X := Name_Find (Some_String & "_some_suffix"); + + -- For historical reasons, we also have the Global_Name_Buffer below, + -- which is used by most of the code via the renamings. New code ought + -- to avoid the global. + + Global_Name_Buffer : Bounded_String; + Name_Buffer : String renames Global_Name_Buffer.Chars; + Name_Len : Natural renames Global_Name_Buffer.Length; + + -- Note that there is some circuitry (e.g. Osint.Write_Program_Name) that + -- does a save/restore on Name_Len and Name_Buffer (1 .. Name_Len). This + -- works in part because Name_Len is default-initialized to 0. ----------------------------- -- Types for Namet Package -- @@ -309,41 +318,106 @@ package Namet is -- Subprograms -- ----------------- - procedure Add_Char_To_Name_Buffer (C : Character); - pragma Inline (Add_Char_To_Name_Buffer); - -- Add given character to the end of the string currently stored in the - -- Name_Buffer, incrementing Name_Len. + function To_String (X : Bounded_String) return String; + function "+" (X : Bounded_String) return String renames To_String; + + function Name_Find + (Buf : Bounded_String := Global_Name_Buffer) return Name_Id; + function Name_Find (S : String) return Name_Id; + -- Name_Find searches the names table to see if the string has already been + -- stored. If so, the Id of the existing entry is returned. Otherwise a new + -- entry is created with its Name_Table_Int fields set to zero/false. Note + -- that it is permissible for Buf.Length to be zero to lookup the empty + -- name string. + + function Name_Enter + (Buf : Bounded_String := Global_Name_Buffer) return Name_Id; + -- Name_Enter is similar to Name_Find. The difference is that it does not + -- search the table for an existing match, and also subsequent Name_Find + -- calls using the same name will not locate the entry created by this + -- call. Thus multiple calls to Name_Enter with the same name will create + -- multiple entries in the name table with different Name_Id values. This + -- is useful in the case of created names, which are never expected to be + -- looked up. Note: Name_Enter should never be used for one character + -- names, since these are efficiently located without hashing by Name_Find + -- in any case. - procedure Add_Nat_To_Name_Buffer (V : Nat); - -- Add decimal representation of given value to the end of the string - -- currently stored in Name_Buffer, incrementing Name_Len as required. + function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean; + -- Return whether N1 and N2 denote the same character sequence - procedure Add_Str_To_Name_Buffer (S : String); - -- Add characters of string S to the end of the string currently stored in - -- the Name_Buffer, incrementing Name_Len by the length of the string. + function Get_Name_String (Id : Name_Id) return String; + -- Returns the characters of Id as a String. The lower bound is 1. + + -- The following Append procedures ignore any characters that don't fit in + -- Buf. + + procedure Append (Buf : in out Bounded_String; C : Character); + -- Append C onto Buf + pragma Inline (Append); + + procedure Append (Buf : in out Bounded_String; V : Nat); + -- Append decimal representation of V onto Buf + + procedure Append (Buf : in out Bounded_String; S : String); + -- Append S onto Buf + + procedure Append (Buf : in out Bounded_String; Id : Name_Id); + -- Append the characters of Id onto Buf. It is an error to call this with + -- one of the special name Id values (No_Name or Error_Name). + + procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id); + -- Same as Append, except that the result is decoded, so that upper half + -- characters and wide characters appear as originally found in the source + -- program text, operators have their source forms (special characters and + -- enclosed in quotes), and character literals appear surrounded by + -- apostrophes. + + procedure Append_Decoded_With_Brackets + (Buf : in out Bounded_String; Id : Name_Id); + -- Same as Append_Decoded, except that the brackets notation (Uhh + -- replaced by ["hh"], Whhhh replaced by ["hhhh"], WWhhhhhhhh replaced by + -- ["hhhhhhhh"]) is used for all non-lower half characters, regardless of + -- how Opt.Wide_Character_Encoding_Method is set, and also in that + -- characters in the range 16#80# .. 16#FF# are converted to brackets + -- notation in all cases. This routine can be used when there is a + -- requirement for a canonical representation not affected by the + -- character set options (e.g. in the binder generation of symbols). + + procedure Append_Unqualified + (Buf : in out Bounded_String; Id : Name_Id); + -- Same as Append, except that qualification (as defined in unit + -- Exp_Dbug) is removed (including both preceding __ delimited names, and + -- also the suffixes used to indicate package body entities and to + -- distinguish between overloaded entities). Note that names are not + -- qualified until just before the call to gigi, so this routine is only + -- needed by processing that occurs after gigi has been called. This + -- includes all ASIS processing, since ASIS works on the tree written + -- after gigi has been called. - procedure Finalize; - -- Called at the end of a use of the Namet package (before a subsequent - -- call to Initialize). Currently this routine is only used to generate - -- debugging output. + procedure Append_Unqualified_Decoded + (Buf : in out Bounded_String; Id : Name_Id); + -- Same as Append_Unqualified, but decoded as for Append_Decoded + + procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code); + -- Appends given character code at the end of Buf. Lower case letters and + -- digits are stored unchanged. Other 8-bit characters are stored using the + -- Uhh encoding (hh = hex code), other 16-bit wide character values are + -- stored using the Whhhh (hhhh = hex code) encoding, and other 32-bit wide + -- wide character values are stored using the WWhhhhhhhh (hhhhhhhh = hex + -- code). Note that this procedure does not fold upper case letters (they + -- are stored using the Uhh encoding). + + procedure Set_Character_Literal_Name + (Buf : in out Bounded_String; C : Char_Code); + -- This procedure sets the proper encoded name for the character literal + -- for the given character code. - procedure Get_Decoded_Name_String (Id : Name_Id); - -- Same calling sequence an interface as Get_Name_String, except that the - -- result is decoded, so that upper half characters and wide characters - -- appear as originally found in the source program text, operators have - -- their source forms (special characters and enclosed in quotes), and - -- character literals appear surrounded by apostrophes. + procedure Insert_Str + (Buf : in out Bounded_String; S : String; Index : Positive); + -- Inserts S in Buf, starting at Index. Any existing characters at or past + -- this location get moved beyond the inserted string. - procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id); - -- This routine is similar to Decoded_Name, except that the brackets - -- notation (Uhh replaced by ["hh"], Whhhh replaced by ["hhhh"], - -- WWhhhhhhhh replaced by ["hhhhhhhh"]) is used for all non-lower half - -- characters, regardless of how Opt.Wide_Character_Encoding_Method is - -- set, and also in that characters in the range 16#80# .. 16#FF# are - -- converted to brackets notation in all cases. This routine can be used - -- when there is a requirement for a canonical representation not affected - -- by the character set options (e.g. in the binder generation of - -- symbols). + function Is_Internal_Name (Buf : Bounded_String) return Boolean; procedure Get_Last_Two_Chars (N : Name_Id; @@ -353,21 +427,6 @@ package Namet is -- C2 is last character. If name is less than two characters long then both -- C1 and C2 are set to ASCII.NUL on return. - procedure Get_Name_String (Id : Name_Id); - -- Get_Name_String is used to retrieve the string associated with an entry - -- in the names table. The resulting string is stored in Name_Buffer and - -- Name_Len is set. It is an error to call Get_Name_String with one of the - -- special name Id values (No_Name or Error_Name). - - function Get_Name_String (Id : Name_Id) return String; - -- This functional form returns the result as a string without affecting - -- the contents of either Name_Buffer or Name_Len. The lower bound is 1. - - procedure Get_Name_String_And_Append (Id : Name_Id); - -- Like Get_Name_String but the resulting characters are appended to the - -- current contents of the entry stored in Name_Buffer, and Name_Len is - -- incremented to include the added characters. - function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean; function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean; function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean; @@ -381,48 +440,23 @@ package Namet is pragma Inline (Get_Name_Table_Int); -- Fetches the Int value associated with the given name - procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id); - -- Similar to the above except that qualification (as defined in unit - -- Exp_Dbug) is removed (including both preceding __ delimited names, and - -- also the suffix used to indicate package body entities). Note that - -- names are not qualified until just before the call to gigi, so this - -- routine is only needed by processing that occurs after gigi has been - -- called. This includes all ASIS processing, since ASIS works on the tree - -- written after gigi has been called. - - procedure Get_Unqualified_Name_String (Id : Name_Id); - -- Similar to the above except that qualification (as defined in unit - -- Exp_Dbug) is removed (including both preceding __ delimited names, and - -- also the suffixes used to indicate package body entities and to - -- distinguish between overloaded entities). Note that names are not - -- qualified until just before the call to gigi, so this routine is only - -- needed by processing that occurs after gigi has been called. This - -- includes all ASIS processing, since ASIS works on the tree written - -- after gigi has been called. - - procedure Initialize; - -- This is a dummy procedure. It is retained for easy compatibility with - -- clients who used to call Initialize when this call was required. Now - -- initialization is performed automatically during package elaboration. - -- Note that this change fixes problems which existed prior to the change - -- of Initialize being called more than once. See also Reinitialize which - -- allows reinitialization of the tables. + procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean); + procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean); + procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean); + -- Sets the Boolean value associated with the given name - procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive); - -- Inserts given string in name buffer, starting at Index. Any existing - -- characters at or past this location get moved beyond the inserted string - -- and Name_Len is incremented by the length of the string. + procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); + pragma Inline (Set_Name_Table_Byte); + -- Sets the Byte value associated with the given name - function Is_Internal_Name return Boolean; - -- Like the form with an Id argument, except that the name to be tested is - -- passed in Name_Buffer and Name_Len (which are not affected by the call). - -- Name_Buffer (it loads these as for Get_Name_String). + procedure Set_Name_Table_Int (Id : Name_Id; Val : Int); + pragma Inline (Set_Name_Table_Int); + -- Sets the Int value associated with the given name function Is_Internal_Name (Id : Name_Id) return Boolean; -- Returns True if the name is an internal name (i.e. contains a character -- for which Is_OK_Internal_Letter is true, or if the name starts or ends - -- with an underscore. This call destroys the value of Name_Len and - -- Name_Buffer (it loads these as for Get_Name_String). + -- with an underscore. -- -- Note: if the name is qualified (has a double underscore), then only the -- final entity name is considered, not the qualifying names. Consider for @@ -454,52 +488,15 @@ package Namet is function Length_Of_Name (Id : Name_Id) return Nat; pragma Inline (Length_Of_Name); -- Returns length of given name in characters. This is the length of the - -- encoded name, as stored in the names table, the result is equivalent to - -- calling Get_Name_String and reading Name_Len, except that a call to - -- Length_Of_Name does not affect the contents of Name_Len and Name_Buffer. - - procedure Lock; - -- Lock name tables before calling back end. We reserve some extra space - -- before locking to avoid unnecessary inefficiencies when we unlock. - - function Name_Chars_Address return System.Address; - -- Return starting address of name characters table (used in Back_End call - -- to Gigi). - - function Name_Enter return Name_Id; - -- Name_Enter has the same calling interface as Name_Find. The difference - -- is that it does not search the table for an existing match, and also - -- subsequent Name_Find calls using the same name will not locate the - -- entry created by this call. Thus multiple calls to Name_Enter with the - -- same name will create multiple entries in the name table with different - -- Name_Id values. This is useful in the case of created names, which are - -- never expected to be looked up. Note: Name_Enter should never be used - -- for one character names, since these are efficiently located without - -- hashing by Name_Find in any case. - - function Name_Entries_Address return System.Address; - -- Return starting address of Names table (used in Back_End call to Gigi) - - function Name_Entries_Count return Nat; - -- Return current number of entries in the names table - - function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean; - -- Return whether N1 and N2 denote the same character sequence + -- encoded name, as stored in the names table. - function Name_Find return Name_Id; - -- Name_Find is called with a string stored in Name_Buffer whose length is - -- in Name_Len (i.e. the characters of the name are in subscript positions - -- 1 to Name_Len in Name_Buffer). It searches the names table to see if the - -- string has already been stored. If so the Id of the existing entry is - -- returned. Otherwise a new entry is created with its Name_Table_Int - -- fields set to zero/false. The contents of Name_Buffer and Name_Len are - -- not modified by this call. Note that it is permissible for Name_Len to - -- be set to zero to lookup the null name string. - - function Name_Find_Str (S : String) return Name_Id; - -- Similar to Name_Find, except that the string is provided as an argument. - -- This call destroys the contents of Name_Buffer and Name_Len (by storing - -- the given string there. + procedure Initialize; + -- This is a dummy procedure. It is retained for easy compatibility with + -- clients who used to call Initialize when this call was required. Now + -- initialization is performed automatically during package elaboration. + -- Note that this change fixes problems which existed prior to the change + -- of Initialize being called more than once. See also Reinitialize which + -- allows reinitialization of the tables. procedure Reinitialize; -- Clears the name tables and removes all existing entries from the table. @@ -511,34 +508,18 @@ package Namet is -- compilation to another, but we can't keep the entity info, since this -- refers to tree nodes, which are destroyed between each main source file. - procedure Set_Character_Literal_Name (C : Char_Code); - -- This procedure sets the proper encoded name for the character literal - -- for the given character code. On return Name_Buffer and Name_Len are - -- set to reflect the stored name. - - procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); - pragma Inline (Set_Name_Table_Byte); - -- Sets the Byte value associated with the given name - - procedure Set_Name_Table_Int (Id : Name_Id; Val : Int); - pragma Inline (Set_Name_Table_Int); - -- Sets the Int value associated with the given name + procedure Finalize; + -- Called at the end of a use of the Namet package (before a subsequent + -- call to Initialize). Currently this routine is only used to generate + -- debugging output. - procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean); - procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean); - procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean); - -- Sets the Boolean value associated with the given name + procedure Lock; + -- Lock name tables before calling back end. We reserve some extra space + -- before locking to avoid unnecessary inefficiencies when we unlock. - procedure Store_Encoded_Character (C : Char_Code); - -- Stores given character code at the end of Name_Buffer, updating the - -- value in Name_Len appropriately. Lower case letters and digits are - -- stored unchanged. Other 8-bit characters are stored using the Uhh - -- encoding (hh = hex code), other 16-bit wide character values are stored - -- using the Whhhh (hhhh = hex code) encoding, and other 32-bit wide wide - -- character values are stored using the WWhhhhhhhh (hhhhhhhh = hex code). - -- Note that this procedure does not fold upper case letters (they are - -- stored using the Uhh encoding). If folding is required, it must be done - -- by the caller prior to the call. + procedure Unlock; + -- Unlocks the name table to allow use of the extra space reserved by the + -- call to Lock. See gnat1drv for details of the need for this. procedure Tree_Read; -- Initializes internal tables from current tree file using the relevant @@ -549,22 +530,65 @@ package Namet is -- Writes out internal tables to current tree file using the relevant -- Table.Tree_Write routines. - procedure Unlock; - -- Unlocks the name table to allow use of the extra space reserved by the - -- call to Lock. See gnat1drv for details of the need for this. - procedure Write_Name (Id : Name_Id); -- Write_Name writes the characters of the specified name using the - -- standard output procedures in package Output. No end of line is - -- written, just the characters of the name. On return Name_Buffer and - -- Name_Len are set as for a call to Get_Name_String. The name is written + -- standard output procedures in package Output. The name is written -- in encoded form (i.e. including Uhh, Whhh, Qx, _op as they appear in -- the name table). If Id is Error_Name, or No_Name, no text is output. procedure Write_Name_Decoded (Id : Name_Id); -- Like Write_Name, except that the name written is the decoded name, as - -- described for Get_Decoded_Name_String, and the resulting value stored - -- in Name_Len and Name_Buffer is the decoded name. + -- described for Append_Decoded. + + function Name_Chars_Address return System.Address; + -- Return starting address of name characters table (used in Back_End call + -- to Gigi). + + function Name_Entries_Address return System.Address; + -- Return starting address of Names table (used in Back_End call to Gigi) + + function Name_Entries_Count return Nat; + -- Return current number of entries in the names table + + -------------------------- + -- Obsolete Subprograms -- + -------------------------- + + -- The following routines operate on Global_Name_Buffer. New code should + -- use the routines above, and declare Bounded_Strings as local + -- variables. Existing code can be improved incrementally by removing calls + -- to the following. ???If we eliminate all of these, we can remove + -- Global_Name_Buffer. But be sure to look at namet.h first. + + -- To see what these do, look at the bodies. They are all trivially defined + -- in terms of routines above. + + procedure Add_Char_To_Name_Buffer (C : Character); + pragma Inline (Add_Char_To_Name_Buffer); + + procedure Add_Nat_To_Name_Buffer (V : Nat); + + procedure Add_Str_To_Name_Buffer (S : String); + + procedure Get_Decoded_Name_String (Id : Name_Id); + + procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id); + + procedure Get_Name_String (Id : Name_Id); + + procedure Get_Name_String_And_Append (Id : Name_Id); + + procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id); + + procedure Get_Unqualified_Name_String (Id : Name_Id); + + procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive); + + function Is_Internal_Name return Boolean; + + procedure Set_Character_Literal_Name (C : Char_Code); + + procedure Store_Encoded_Character (C : Char_Code); ------------------------------ -- File and Unit Name Types -- @@ -629,6 +653,8 @@ package Namet is -- <No_Name>, <invalid name>). Unlike Write_Name, this call does not affect -- the contents of Name_Buffer or Name_Len. +private + --------------------------- -- Table Data Structures -- --------------------------- @@ -637,8 +663,6 @@ package Namet is -- names. The definitions are in the private part of the package spec, -- rather than the body, since they are referenced directly by gigi. -private - -- This table stores the actual string names. Although logically there is -- no need for a terminating character (since the length is stored in the -- name entry table), we still store a NUL character at the end of every @@ -673,8 +697,8 @@ private Name_Has_No_Encodings : Boolean; -- This flag is set True if the name entry is known not to contain any -- special character encodings. This is used to speed up repeated calls - -- to Get_Decoded_Name_String. A value of False means that it is not - -- known whether the name contains any such encodings. + -- to Append_Decoded. A value of False means that it is not known + -- whether the name contains any such encodings. Hash_Link : Name_Id; -- Link to next entry in names table for same hash code diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index 82af02d..32d110b 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -25,7 +25,7 @@ /* This is the C file that corresponds to the Ada package specification Namet. It was created manually from files namet.ads and namet.adb. - Some subprograms from Sinput are also made acessable here. */ + Some subprograms from Sinput are also made accessible here. */ #ifdef __cplusplus extern "C" { @@ -52,16 +52,26 @@ extern struct Name_Entry *Names_Ptr; #define Name_Chars_Ptr namet__name_chars__table extern char *Name_Chars_Ptr; -#define Name_Buffer namet__name_buffer -extern char Name_Buffer[]; +/* The global name buffer. */ +struct Bounded_String +{ + Nat Max_Length; + Nat Length; + char Chars[1]; + /* The 1 here is wrong, but it doesn't matter, because all the code either + goes by Length, or NUL-terminates the string before processing it. */ +}; + +#define Global_Name_Buffer namet__global_name_buffer +extern struct Bounded_String Global_Name_Buffer; -extern Int namet__name_len; -#define Name_Len namet__name_len +#define Name_Buffer Global_Name_Buffer.Chars +#define Name_Len Global_Name_Buffer.Length -/* Get_Name_String returns a null terminated C string for the specified name. +/* Get_Name_String returns a NUL terminated C string for the specified name. We could use the official Ada routine for this purpose, but since the strings we want are sitting in the name strings table in exactly the form - we need them (null terminated), we just point to the name directly. */ + we need them (NUL terminated), we just point to the name directly. */ static char *Get_Name_String (Name_Id); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 92118ab..1dd350a 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -3287,11 +3287,11 @@ package body Sem_Elab is -- Determine whether to emit an error message based on the combination -- of flags Check_Elab_Flag and Flag. - function Is_Printable_Error_Name (Nm : Name_Id) return Boolean; - -- An internal function, used to determine if a name, Nm, is either - -- a non-internal name, or is an internal name that is printable - -- by the error message circuits (i.e. it has a single upper - -- case letter at the end). + function Is_Printable_Error_Name return Boolean; + -- An internal function, used to determine if a name, stored in the + -- Name_Buffer, is either a non-internal name, or is an internal name + -- that is printable by the error message circuits (i.e. it has a single + -- upper case letter at the end). ---------- -- Emit -- @@ -3310,9 +3310,9 @@ package body Sem_Elab is -- Is_Printable_Error_Name -- ----------------------------- - function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is + function Is_Printable_Error_Name return Boolean is begin - if not Is_Internal_Name (Nm) then + if not Is_Internal_Name then return True; elsif Name_Len = 1 then @@ -3335,6 +3335,7 @@ package body Sem_Elab is Error_Msg_Sloc := Elab_Call.Table (J).Cloc; Ent := Elab_Call.Table (J).Ent; + Get_Name_String (Chars (Ent)); -- Dynamic elaboration model, warnings controlled by -gnatwl @@ -3344,7 +3345,7 @@ package body Sem_Elab is Error_Msg_NE ("\\?l?& instantiated #", N, Ent); elsif Is_Init_Proc (Ent) then Error_Msg_N ("\\?l?initialization procedure called #", N); - elsif Is_Printable_Error_Name (Chars (Ent)) then + elsif Is_Printable_Error_Name then Error_Msg_NE ("\\?l?& called #", N, Ent); else Error_Msg_N ("\\?l?called #", N); @@ -3359,7 +3360,7 @@ package body Sem_Elab is Error_Msg_NE ("\\?$?& instantiated #", N, Ent); elsif Is_Init_Proc (Ent) then Error_Msg_N ("\\?$?initialization procedure called #", N); - elsif Is_Printable_Error_Name (Chars (Ent)) then + elsif Is_Printable_Error_Name then Error_Msg_NE ("\\?$?& called #", N, Ent); else Error_Msg_N ("\\?$?called #", N); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 118d43d..c55054b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -25188,9 +25188,10 @@ package body Sem_Prag is Enabled : Boolean; Constit : Entity_Id); -- Determine whether a property denoted by name Prop_Nam is present - -- in both the refined state and constituent Constit. Flag Enabled - -- should be set when the property applies to the refined state. If - -- this is not the case, emit an error message. + -- in the refined state. Emit an error if this is not the case. Flag + -- Enabled should be set when the property applies to the refined + -- state. Constit denotes the constituent (if any) which introduces + -- the property in the refinement. procedure Match_State; -- Determine whether the state being refined appears in list @@ -25511,27 +25512,21 @@ package body Sem_Prag is Constit : Entity_Id) is begin - Error_Msg_Name_1 := Prop_Nam; - - -- The property is enabled in the related Abstract_State pragma - -- that defines the state (SPARK RM 7.2.8(2)). - - if Enabled then - if No (Constit) then - SPARK_Msg_NE - ("external state & requires at least one constituent with " - & "property %", State, State_Id); - end if; - -- The property is missing in the declaration of the state, but -- a constituent is introducing it in the state refinement -- (SPARK RM 7.2.8(2)). - elsif Present (Constit) then - Error_Msg_Name_2 := Chars (Constit); + if not Enabled and then Present (Constit) then + Error_Msg_Name_1 := Prop_Nam; + Error_Msg_Name_2 := Chars (State_Id); SPARK_Msg_NE - ("external state & lacks property % set by constituent %", - State, State_Id); + ("constituent & introduces external property % in refinement " + & "of state %", State, Constit); + + Error_Msg_Sloc := Sloc (State_Id); + SPARK_Msg_N + ("\property is missing in abstract state declaration #", + State); end if; end Check_External_Property; @@ -25746,10 +25741,8 @@ package body Sem_Prag is Analyze_Constituent (Constit); end if; - -- The set of properties that all external constituents yield must - -- match that of the refined state. There are two cases to detect: - -- the refined state lacks a property or has an extra property - -- (SPARK RM 7.2.8(2)). + -- Verify that external constituents do not introduce new external + -- property in the state refinement (SPARK RM 7.2.8(2)). if Is_External_State (State_Id) then Check_External_Property @@ -26050,14 +26043,20 @@ package body Sem_Prag is if Present (New_E) then Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); end if; - end if; - if not Is_Abstract_Subprogram (Inher_Id) - and then Nkind (N) = N_Function_Call - and then Present (Entity (Name (N))) - and then Is_Abstract_Subprogram (Entity (Name (N))) - then - Error_Msg_N ("cannot call abstract subprogram", N); + -- Check that there are no calls left to abstract operations + -- if the current subprogram is not abstract. + + if Nkind (Parent (N)) = N_Function_Call + and then N = Name (Parent (N)) + and then not Is_Abstract_Subprogram (Subp_Id) + and then Is_Abstract_Subprogram (Entity (N)) + then + Error_Msg_Sloc := Sloc (Current_Scope); + Error_Msg_NE + ("cannot call abstract subprogram in inherited condition " + & "for&#", N, Current_Scope); + end if; -- The whole expression will be reanalyzed @@ -26140,13 +26139,47 @@ package body Sem_Prag is -- operations of the descendant. Note that the descendant type may -- not be frozen yet, so we cannot use the dispatch table directly. - declare + -- Note : the construction of the map involves a full traversal of + -- the list of primitive operations, as well as a scan of the + -- declarations in the scope of the operation. Given that class-wide + -- conditions are typically short expressions, it might be much more + -- efficient to collect the identifiers in the expression first, and + -- then determine the ones that have to be mapped. Optimization ??? + + Primitive_Mapping : declare + function Overridden_Ancestor (S : Entity_Id) return Entity_Id; + -- Given the controlling type of the overridden operation and a + -- primitive of the current type, find the corresponding operation + -- of the parent type. + + ------------------------- + -- Overridden_Ancestor -- + ------------------------- + + function Overridden_Ancestor (S : Entity_Id) return Entity_Id is + Anc : Entity_Id; + + begin + Anc := S; + while Present (Overridden_Operation (Anc)) loop + exit when Scope (Anc) = Scope (Inher_Id); + Anc := Overridden_Operation (Anc); + end loop; + + return Anc; + end Overridden_Ancestor; + + -- Local variables + Old_Typ : constant Entity_Id := Find_Dispatching_Type (Inher_Id); Typ : constant Entity_Id := Find_Dispatching_Type (Subp_Id); Decl : Node_Id; + Old_Elmt : Elmt_Id; Old_Prim : Entity_Id; Prim : Entity_Id; + -- Start of processing for Primitive_Mapping + begin Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id))); @@ -26163,12 +26196,7 @@ package body Sem_Prag is and then Present (Overridden_Operation (Prim)) and then Find_Dispatching_Type (Prim) = Typ then - Old_Prim := Overridden_Operation (Prim); - while Present (Overridden_Operation (Old_Prim)) - and then Scope (Old_Prim) /= Scope (Inher_Id) - loop - Old_Prim := Overridden_Operation (Old_Prim); - end loop; + Old_Prim := Overridden_Ancestor (Prim); Append_Elmt (Old_Prim, Map); Append_Elmt (Prim, Map); @@ -26178,6 +26206,13 @@ package body Sem_Prag is Next (Decl); end loop; + -- Now examine inherited operations. These do not override, but + -- have an alias, which is the entity used in a call. In turn + -- that alias may be inherited or comes from source, in which + -- case it may override an earlier operation. We only need to + -- examine inherited functions, that may appear within the + -- inherited expression. + Prim := First_Entity (Scope (Subp_Id)); while Present (Prim) loop if not Comes_From_Source (Prim) @@ -26185,11 +26220,22 @@ package body Sem_Prag is and then Present (Alias (Prim)) then Old_Prim := Alias (Prim); - while Present (Alias (Old_Prim)) - and then Scope (Old_Prim) /= Scope (Inher_Id) - loop - Old_Prim := Alias (Old_Prim); - end loop; + + if Comes_From_Source (Old_Prim) then + Old_Prim := Overridden_Ancestor (Old_Prim); + + else + while Present (Alias (Old_Prim)) + and then Scope (Old_Prim) /= Scope (Inher_Id) + loop + Old_Prim := Alias (Old_Prim); + + if Comes_From_Source (Old_Prim) then + Old_Prim := Overridden_Ancestor (Old_Prim); + exit; + end if; + end loop; + end if; Append_Elmt (Old_Prim, Map); Append_Elmt (Prim, Map); @@ -26198,11 +26244,31 @@ package body Sem_Prag is Next_Entity (Prim); end loop; + -- If the parent operation is an interface operation, the + -- overriding indicator is not present. Instead, we get from + -- the interface operation the primitive of the current type + -- that implements it. + + if Is_Interface (Old_Typ) then + Old_Elmt := First_Elmt (Collect_Primitive_Operations (Old_Typ)); + while Present (Old_Elmt) loop + Old_Prim := Node (Old_Elmt); + Prim := Find_Primitive_Covering_Interface (Typ, Old_Prim); + + if Present (Prim) then + Append_Elmt (Old_Prim, Map); + Append_Elmt (Prim, Map); + end if; + + Next_Elmt (Old_Elmt); + end loop; + end if; + if Map /= No_Elist then Append_Elmt (Old_Typ, Map); Append_Elmt (Typ, Map); end if; - end; + end Primitive_Mapping; end if; -- Copy the original pragma while performing substitutions (if |