Skip to content

R
riscv-gcc-1
Commit 3e20cb68 by Arnaud Charlet
Options

[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
parent 1f55088d
Showing with 195 additions and 65 deletions
gcc/ada/ChangeLog
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
......
gcc/ada/bindgen.adb
......@@ -2922,7 +2922,7 @@ package body Bindgen is
Osint.Fail ("bind environment value """ & Value & """ too long");
end if;
Bind_Environment.Set (Name_Find_Str (Key), Name_Find_Str (Value));
Bind_Environment.Set (Name_Find (Key), Name_Find (Value));
end Set_Bind_Env;
-----------------
......
gcc/ada/exp_ch5.adb
......@@ -1693,9 +1693,10 @@ package body Exp_Ch5 is
-- The attribute Priority applied to protected objects has been
-- previously expanded into a call to the Get_Ceiling run-time
-- subprogram.
-- subprogram. In restricted profiles this is not available.
if Nkind (Ent) = N_Function_Call
and then RTE_Available (RE_Get_Ceiling)
and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling)
or else
Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))
......
gcc/ada/exp_unst.adb
......@@ -161,7 +161,7 @@ package body Exp_Unst is
function AREC_Name (J : Pos; S : String) return Name_Id is
begin
return Name_Find_Str ("AREC" & Img_Pos (J) & S);
return Name_Find ("AREC" & Img_Pos (J) & S);
end AREC_Name;
--------------------
......@@ -244,7 +244,7 @@ package body Exp_Unst is
if No (C) then
return Chars (Ent);
elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
return Name_Find_Str
return Name_Find
(Get_Name_String (Chars (Ent)) & Img_Pos (Index));
else
Next (C);
......
gcc/ada/namet-sp.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -31,7 +31,7 @@
-- This child package contains a spell checker for Name_Id values. It is
-- separated off as a child package, because of the extra dependencies,
-- in particular on GNAT.UTF_32_ Spelling_Checker. There are a number of
-- in particular on GNAT.UTF_32_Spelling_Checker. There are a number of
-- packages that use Namet that do not need the spell checking feature,
-- and this separation helps in dealing with older versions of GNAT.
......
gcc/ada/namet.h
......@@ -25,7 +25,7 @@
/* This is the C file that corresponds to the Ada package specification
Namet. It was created manually from files namet.ads and namet.adb.
Some subprograms from Sinput are also made acessable here. */
Some subprograms from Sinput are also made accessible here. */
#ifdef __cplusplus
extern "C" {
......@@ -52,16 +52,26 @@ extern struct Name_Entry *Names_Ptr;
#define Name_Chars_Ptr namet__name_chars__table
extern char *Name_Chars_Ptr;
#define Name_Buffer namet__name_buffer
extern char Name_Buffer[];
/* The global name buffer. */
struct Bounded_String
{
Nat Max_Length;
Nat Length;
char Chars[1];
/* The 1 here is wrong, but it doesn't matter, because all the code either
goes by Length, or NUL-terminates the string before processing it. */
};
#define Global_Name_Buffer namet__global_name_buffer
extern struct Bounded_String Global_Name_Buffer;
extern Int namet__name_len;
#define Name_Len namet__name_len
#define Name_Buffer Global_Name_Buffer.Chars
#define Name_Len Global_Name_Buffer.Length
/* Get_Name_String returns a null terminated C string for the specified name.
/* Get_Name_String returns a NUL terminated C string for the specified name.
We could use the official Ada routine for this purpose, but since the
strings we want are sitting in the name strings table in exactly the form
we need them (null terminated), we just point to the name directly. */
we need them (NUL terminated), we just point to the name directly. */
static char *Get_Name_String (Name_Id);
......
gcc/ada/sem_elab.adb
......@@ -3287,11 +3287,11 @@ package body Sem_Elab is
-- Determine whether to emit an error message based on the combination
-- of flags Check_Elab_Flag and Flag.
function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
-- An internal function, used to determine if a name, Nm, is either
-- a non-internal name, or is an internal name that is printable
-- by the error message circuits (i.e. it has a single upper
-- case letter at the end).
function Is_Printable_Error_Name return Boolean;
-- An internal function, used to determine if a name, stored in the
-- Name_Buffer, is either a non-internal name, or is an internal name
-- that is printable by the error message circuits (i.e. it has a single
-- upper case letter at the end).
----------
-- Emit --
......@@ -3310,9 +3310,9 @@ package body Sem_Elab is
-- Is_Printable_Error_Name --
-----------------------------
function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
function Is_Printable_Error_Name return Boolean is
begin
if not Is_Internal_Name (Nm) then
if not Is_Internal_Name then
return True;
elsif Name_Len = 1 then
......@@ -3335,6 +3335,7 @@ package body Sem_Elab is
Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
Ent := Elab_Call.Table (J).Ent;
Get_Name_String (Chars (Ent));
-- Dynamic elaboration model, warnings controlled by -gnatwl
......@@ -3344,7 +3345,7 @@ package body Sem_Elab is
Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\\?l?initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
elsif Is_Printable_Error_Name then
Error_Msg_NE ("\\?l?& called #", N, Ent);
else
Error_Msg_N ("\\?l?called #", N);
......@@ -3359,7 +3360,7 @@ package body Sem_Elab is
Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\\?$?initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
elsif Is_Printable_Error_Name then
Error_Msg_NE ("\\?$?& called #", N, Ent);
else
Error_Msg_N ("\\?$?called #", N);
......
gcc/ada/sem_prag.adb
......@@ -25188,9 +25188,10 @@ package body Sem_Prag is
Enabled : Boolean;
Constit : Entity_Id);
-- Determine whether a property denoted by name Prop_Nam is present
-- in both the refined state and constituent Constit. Flag Enabled
-- should be set when the property applies to the refined state. If
-- this is not the case, emit an error message.
-- in the refined state. Emit an error if this is not the case. Flag
-- Enabled should be set when the property applies to the refined
-- state. Constit denotes the constituent (if any) which introduces
-- the property in the refinement.
procedure Match_State;
-- Determine whether the state being refined appears in list
......@@ -25511,27 +25512,21 @@ package body Sem_Prag is
Constit : Entity_Id)
is
begin
Error_Msg_Name_1 := Prop_Nam;
-- The property is enabled in the related Abstract_State pragma
-- that defines the state (SPARK RM 7.2.8(2)).
if Enabled then
if No (Constit) then
SPARK_Msg_NE
("external state & requires at least one constituent with "
& "property %", State, State_Id);
end if;
-- The property is missing in the declaration of the state, but
-- a constituent is introducing it in the state refinement
-- (SPARK RM 7.2.8(2)).
elsif Present (Constit) then
Error_Msg_Name_2 := Chars (Constit);
if not Enabled and then Present (Constit) then
Error_Msg_Name_1 := Prop_Nam;
Error_Msg_Name_2 := Chars (State_Id);
SPARK_Msg_NE
("external state & lacks property % set by constituent %",
State, State_Id);
("constituent & introduces external property % in refinement "
& "of state %", State, Constit);
Error_Msg_Sloc := Sloc (State_Id);
SPARK_Msg_N
("\property is missing in abstract state declaration #",
State);
end if;
end Check_External_Property;
......@@ -25746,10 +25741,8 @@ package body Sem_Prag is
Analyze_Constituent (Constit);
end if;
-- The set of properties that all external constituents yield must
-- match that of the refined state. There are two cases to detect:
-- the refined state lacks a property or has an extra property
-- (SPARK RM 7.2.8(2)).
-- Verify that external constituents do not introduce new external
-- property in the state refinement (SPARK RM 7.2.8(2)).
if Is_External_State (State_Id) then
Check_External_Property
......@@ -26050,14 +26043,20 @@ package body Sem_Prag is
if Present (New_E) then
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
end if;
end if;
if not Is_Abstract_Subprogram (Inher_Id)
and then Nkind (N) = N_Function_Call
and then Present (Entity (Name (N)))
and then Is_Abstract_Subprogram (Entity (Name (N)))
then
Error_Msg_N ("cannot call abstract subprogram", N);
-- Check that there are no calls left to abstract operations
-- if the current subprogram is not abstract.
if Nkind (Parent (N)) = N_Function_Call
and then N = Name (Parent (N))
and then not Is_Abstract_Subprogram (Subp_Id)
and then Is_Abstract_Subprogram (Entity (N))
then
Error_Msg_Sloc := Sloc (Current_Scope);
Error_Msg_NE
("cannot call abstract subprogram in inherited condition "
& "for&#", N, Current_Scope);
end if;
-- The whole expression will be reanalyzed
......@@ -26140,13 +26139,47 @@ package body Sem_Prag is
-- operations of the descendant. Note that the descendant type may
-- not be frozen yet, so we cannot use the dispatch table directly.
declare
-- Note : the construction of the map involves a full traversal of
-- the list of primitive operations, as well as a scan of the
-- declarations in the scope of the operation. Given that class-wide
-- conditions are typically short expressions, it might be much more
-- efficient to collect the identifiers in the expression first, and
-- then determine the ones that have to be mapped. Optimization ???
Primitive_Mapping : declare
function Overridden_Ancestor (S : Entity_Id) return Entity_Id;
-- Given the controlling type of the overridden operation and a
-- primitive of the current type, find the corresponding operation
-- of the parent type.
-------------------------
-- Overridden_Ancestor --
-------------------------
function Overridden_Ancestor (S : Entity_Id) return Entity_Id is
Anc : Entity_Id;
begin
Anc := S;
while Present (Overridden_Operation (Anc)) loop
exit when Scope (Anc) = Scope (Inher_Id);
Anc := Overridden_Operation (Anc);
end loop;
return Anc;
end Overridden_Ancestor;
-- Local variables
Old_Typ : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
Typ : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
Decl : Node_Id;
Old_Elmt : Elmt_Id;
Old_Prim : Entity_Id;
Prim : Entity_Id;
-- Start of processing for Primitive_Mapping
begin
Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id)));
......@@ -26163,12 +26196,7 @@ package body Sem_Prag is
and then Present (Overridden_Operation (Prim))
and then Find_Dispatching_Type (Prim) = Typ
then
Old_Prim := Overridden_Operation (Prim);
while Present (Overridden_Operation (Old_Prim))
and then Scope (Old_Prim) /= Scope (Inher_Id)
loop
Old_Prim := Overridden_Operation (Old_Prim);
end loop;
Old_Prim := Overridden_Ancestor (Prim);
Append_Elmt (Old_Prim, Map);
Append_Elmt (Prim, Map);
......@@ -26178,6 +26206,13 @@ package body Sem_Prag is
Next (Decl);
end loop;
-- Now examine inherited operations. These do not override, but
-- have an alias, which is the entity used in a call. In turn
-- that alias may be inherited or comes from source, in which
-- case it may override an earlier operation. We only need to
-- examine inherited functions, that may appear within the
-- inherited expression.
Prim := First_Entity (Scope (Subp_Id));
while Present (Prim) loop
if not Comes_From_Source (Prim)
......@@ -26185,11 +26220,22 @@ package body Sem_Prag is
and then Present (Alias (Prim))
then
Old_Prim := Alias (Prim);
while Present (Alias (Old_Prim))
and then Scope (Old_Prim) /= Scope (Inher_Id)
loop
Old_Prim := Alias (Old_Prim);
end loop;
if Comes_From_Source (Old_Prim) then
Old_Prim := Overridden_Ancestor (Old_Prim);
else
while Present (Alias (Old_Prim))
and then Scope (Old_Prim) /= Scope (Inher_Id)
loop
Old_Prim := Alias (Old_Prim);
if Comes_From_Source (Old_Prim) then
Old_Prim := Overridden_Ancestor (Old_Prim);
exit;
end if;
end loop;
end if;
Append_Elmt (Old_Prim, Map);
Append_Elmt (Prim, Map);
......@@ -26198,11 +26244,31 @@ package body Sem_Prag is
Next_Entity (Prim);
end loop;
-- If the parent operation is an interface operation, the
-- overriding indicator is not present. Instead, we get from
-- the interface operation the primitive of the current type
-- that implements it.
if Is_Interface (Old_Typ) then
Old_Elmt := First_Elmt (Collect_Primitive_Operations (Old_Typ));
while Present (Old_Elmt) loop
Old_Prim := Node (Old_Elmt);
Prim := Find_Primitive_Covering_Interface (Typ, Old_Prim);
if Present (Prim) then
Append_Elmt (Old_Prim, Map);
Append_Elmt (Prim, Map);
end if;
Next_Elmt (Old_Elmt);
end loop;
end if;
if Map /= No_Elist then
Append_Elmt (Old_Typ, Map);
Append_Elmt (Typ, Map);
end if;
end;
end Primitive_Mapping;
end if;
-- Copy the original pragma while performing substitutions (if
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment