+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
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;
-----------------
-- 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))
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;
--------------------
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);
-- --
-- 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- --
-- 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.
-- 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 --
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;
----------------------------
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;
----------------------------
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
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
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;
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;
-- 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);
-- 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);
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');
-- 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 (''');
-- 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;
-- not we have some kind of internal error, and a constraint
-- error may be raised.
- J := Map'First;
- loop
- exit when Name_Buffer (Old) = Map (J)
- and then Name_Buffer (Old + 1) = Map (J + 1);
- J := J + 4;
- end loop;
+ J := Map'First;
+ loop
+ exit when Buf.Chars (Old) = Map (J)
+ and then Buf.Chars (Old + 1) = Map (J + 1);
+ J := J + 4;
+ end loop;
+
+ -- Special operator name
+
+ if Map (J + 2) /= ' ' then
+ Insert_Character (Map (J + 2));
+
+ if Map (J + 3) /= ' ' then
+ Insert_Character (Map (J + 3));
+ end if;
+
+ Insert_Character ('"');
+
+ -- Skip past original operator name in input
+
+ while Old <= Buf.Length
+ and then Buf.Chars (Old) in 'a' .. 'z'
+ loop
+ Old := Old + 1;
+ end loop;
+
+ -- For other operator names, leave them in lower case,
+ -- surrounded by apostrophes
+
+ else
+ -- Copy original operator name from input to output
+
+ while Old <= Buf.Length
+ and then Buf.Chars (Old) in 'a' .. 'z'
+ loop
+ Copy_One_Character;
+ end loop;
+
+ Insert_Character ('"');
+ end if;
+ end;
+
+ -- Else copy one character and keep going
+
+ else
+ Copy_One_Character;
+ end if;
+ end loop;
+
+ -- Copy new buffer as result
+
+ Buf.Length := New_Len;
+ Buf.Chars (1 .. New_Len) := New_Buf (1 .. New_Len);
+ end Decode;
+ end Append_Decoded;
+
+ ----------------------------------
+ -- Append_Decoded_With_Brackets --
+ ----------------------------------
+
+ 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 Buf.Chars (1) = 'O' then
+ Append_Decoded (Buf, Id);
+
+ -- For character literals, normal decoding is fine
+
+ elsif Buf.Chars (1) = 'Q' then
+ Append_Decoded (Buf, Id);
+
+ -- Only remaining issue is U/W/WW sequences
+
+ else
+ Append (Buf, Id);
+
+ P := 1;
+ while P < Buf.Length loop
+ if Buf.Chars (P + 1) in 'A' .. 'Z' then
+ P := P + 1;
+
+ -- Uhh encoding
+
+ 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;
+
+ 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 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
+ 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 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
+ 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
+ P := P + 1;
+ 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 (" ");
- -- Special operator name
+ for J in 1 .. Name_Entries.Table (N).Name_Len loop
+ Write_Char (Name_Chars.Table (S + Int (J)));
+ end loop;
- if Map (J + 2) /= ' ' then
- Insert_Character (Map (J + 2));
+ Write_Eol;
- if Map (J + 3) /= ' ' then
- Insert_Character (Map (J + 3));
- end if;
+ N := Name_Entries.Table (N).Hash_Link;
+ end loop;
+ end if;
+ end;
+ end if;
+ end loop;
- Insert_Character ('"');
+ Write_Eol;
- -- Skip past original operator name in input
+ for J in F'Range loop
+ if F (J) /= 0 then
+ Write_Str ("Number of hash chains of length ");
- while Old <= Name_Len
- and then Name_Buffer (Old) in 'a' .. 'z'
- loop
- Old := Old + 1;
- end loop;
+ if J < 10 then
+ Write_Char (' ');
+ end if;
- -- For other operator names, leave them in lower case,
- -- surrounded by apostrophes
+ Write_Int (J);
- else
- -- Copy original operator name from input to output
+ if J = F'Last then
+ Write_Str (" or greater");
+ end if;
- while Old <= Name_Len
- and then Name_Buffer (Old) in 'a' .. 'z'
- loop
- Copy_One_Character;
- end loop;
+ Write_Str (" = ");
+ Write_Int (F (J));
+ Write_Eol;
+ end if;
+ end loop;
- Insert_Character ('"');
- end if;
- end;
+ -- Print out average number of probes, in the case where Name_Find is
+ -- called for a string that is already in the table.
- -- Else copy one character and keep going
+ 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;
- else
- Copy_One_Character;
- end if;
- end loop;
+ 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;
- -- Copy new buffer as result
+ -----------------------------
+ -- Get_Decoded_Name_String --
+ -----------------------------
- Name_Len := New_Len;
- Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
- end Decode;
+ 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;
-------------------------------------------
-------------------------------------------
procedure Get_Decoded_Name_String_With_Brackets (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);
-
- -- For character literals, normal decoding is fine
-
- elsif Name_Buffer (1) = 'Q' then
- Get_Decoded_Name_String (Id);
-
- -- Only remaining issue is U/W/WW sequences
-
- else
- Get_Name_String (Id);
-
- P := 1;
- while P < Name_Len loop
- if Name_Buffer (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);
- 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) := ']';
- 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) /= '_'
- 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;
- 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) /= '_'
- 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;
- P := P + 8;
-
- else
- P := P + 1;
- end if;
- end loop;
- end if;
+ Global_Name_Buffer.Length := 0;
+ Append_Decoded_With_Brackets (Global_Name_Buffer, Id);
end Get_Decoded_Name_String_With_Brackets;
------------------------
-- 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;
--------------------------------
--------------------------------
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;
-----------------------------
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;
---------------------------------
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
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);
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
-- 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;
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 --
---------------------------
-- 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,
-- 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);
-- 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
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
else
Search : loop
- if Name_Len /=
+ if Buf.Length /=
Integer (Name_Entries.Table (New_Id).Name_Len)
then
goto No_Match;
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;
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,
-- 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);
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 --
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;
------------------
-- 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;
-----------------------------
-----------------------------
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
-- 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;
end loop;
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 --
---------------
--------
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
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;
----------------
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;
------------------------
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;
-- 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
-- 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 --
-- 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;
-- 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;
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
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.
-- 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
-- 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 --
-- <No_Name>, <invalid name>). Unlike Write_Name, this call does not affect
-- the contents of Name_Buffer or Name_Len.
+private
+
---------------------------
-- Table Data Structures --
---------------------------
-- 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
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
/* 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" {
#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);
-- 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 --
-- 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
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
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);
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);
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
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;
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
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
-- 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)));
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);
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)
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);
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
projects / gcc.git / commitdiff