OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r235123
This commit is contained in:
Arnaud Charlet 2016-04-18 12:44:09 +02:00
parent 1f55088db5
commit 3e20cb680f
10 changed files with 1014 additions and 818 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
gcc/ada/ChangeLog
View File

@ -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

2
gcc/ada/bindgen.adb
View File

@ -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;
-----------------

3
gcc/ada/exp_ch5.adb
View File

@ -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))

4
gcc/ada/exp_unst.adb
View File

@ -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);

4
gcc/ada/namet-sp.ads
View File

@ -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.

1188
gcc/ada/namet.adb
View File

File diff suppressed because it is too large Load Diff

384
gcc/ada/namet.ads
View File

@ -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).
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;
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.
-- 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;
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_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.
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 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 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.
function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean;
-- Return whether N1 and N2 denote the same character sequence
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.
function Get_Name_String (Id : Name_Id) return String;
-- Returns the characters of Id as a String. The lower bound is 1.
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).
-- 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 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 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.
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 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 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 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 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 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.
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.
-- encoded name, as stored in the names table.
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
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 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_Byte (Id : Name_Id; Val : Byte);
pragma Inline (Set_Name_Table_Byte);
-- Sets the Byte 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 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 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 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

24
gcc/ada/namet.h
View File

@ -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. */
};
extern Int namet__name_len;
#define Name_Len namet__name_len
#define Global_Name_Buffer namet__global_name_buffer
extern struct Bounded_String Global_Name_Buffer;
/* Get_Name_String returns a null terminated C string for the specified name.
#define Name_Buffer Global_Name_Buffer.Chars
#define Name_Len Global_Name_Buffer.Length
/* 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);

19
gcc/ada/sem_elab.adb
View File

@ -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);

152
gcc/ada/sem_prag.adb
View File

@ -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