mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 05:00:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2017-09-07  Nicolas Roche  <roche@adacore.com>

	* s-traces-default.adb, s-trafor-default.adb, s-trafor-default.ads,
	s-traces.adb, s-traces.ads, s-tratas-default.adb, s-tfsetr-default.adb,
	s-tfsetr-vxworks.adb, s-tratas.adb, s-tratas.ads, s-tasuti.adb,
	s-parame-hpux.ads, s-tassta.adb, s-taasde.adb, s-tasren.adb,
	s-taprob.adb, a-caldel.adb, s-parame.ads, Makefile.rtl, s-tpobop.adb,
	s-taenca.adb, s-parame-vxworks.ads: Remove support for System.Traces.

2017-09-07  Yannick Moy  <moy@adacore.com>

	* a-ngelfu.ads Add preconditions to all functions
	listed in Ada RM A.5.1(19-33) as having constraints on inputs.

2017-09-07  Arnaud Charlet  <charlet@adacore.com>

	* lib-xref.adb (Generate_Reference): ignore
	references to entities which are Part_Of single concurrent
	objects.

2017-09-07  Eric Botcazou  <ebotcazou@adacore.com>

	* sem_ch7.adb (Hide_Public_Entities): Add paragraph to main
	comment.

2017-09-07  Arnaud Charlet  <charlet@adacore.com>

	* a-taside.adb (Activation_Is_Complete): Raise Program_Error if
	Null_Task_Id is passed.

2017-09-07  Javier Miranda  <miranda@adacore.com>

	* einfo.ads, einfo.adb (Access_Disp_Table_Elab_Flag): New
	attribute. Defined for record types and subtypes.
	* exp_ch3.ads (Init_Secondary_Tags): Adding new formal
	(Init_Tags_List) to facilitate generating separate code in the
	IP routine to initialize the object components and for completing
	the elaboration of dispatch tables.
	* exp_ch3.adb (Build_Init_Procedure): Improve the code
	generated in the IP routines by means of keeping separate
	the initialization of the object components from the
	initialization of its dispatch tables.	(Init_Secondary_Tags):
	Adding new formal (Init_Tags_List) and adjusting calls to
	Ada.Tags.Set_Dynamic_Offset_To_Top since it has a new formal;
	adjusting also calls to Ada.Tags.Register_Interface_Offset
	because the type of one of its formals has been changed.
	* a-tags.ads, a-tags.adb (Register_Interface_Offset): Profile
	modified. Instead of receiving a pointer to an object this
	routine receives now a primary tag.
	(Set_Dyanic_Offset_To_Top): Profile modified. This routine receives an
	additional formal: the tag of the primary dispatch table.
	* exp_disp.ads (Elab_Flag_Needed): New subprogram.
	* exp_disp.adb (Elab_Flag_Needed): New subprogram.
	(Make_Tags): Adding the declaration of the elaboration flag (if needed).
	* exp_aggr.adb (Build_Record_Aggr_Code): Adding actual of new
	formal in calls to Init_Secondary_Tags.

2017-09-07  Javier Miranda  <miranda@adacore.com>

	* ghost.adb (Mark_And_Set_Ghost_Instantiation.Check_Ghost_Actuals): New
	subprogram.
	* sem_prag.adb (Pragma_Ghost): Add missing support for ghost
	applied to generic subprograms.

From-SVN: r251838
This commit is contained in:
Arnaud Charlet 2017-09-07 11:53:18 +02:00
parent 4b25afa16e
commit fe683ef6e1
28 changed files with 346 additions and 294 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
gcc/ada/ChangeLog
View File

@ -1,3 +1,67 @@
2017-09-07 Nicolas Roche <roche@adacore.com>
* s-traces-default.adb, s-trafor-default.adb, s-trafor-default.ads,
s-traces.adb, s-traces.ads, s-tratas-default.adb, s-tfsetr-default.adb,
s-tfsetr-vxworks.adb, s-tratas.adb, s-tratas.ads, s-tasuti.adb,
s-parame-hpux.ads, s-tassta.adb, s-taasde.adb, s-tasren.adb,
s-taprob.adb, a-caldel.adb, s-parame.ads, Makefile.rtl, s-tpobop.adb,
s-taenca.adb, s-parame-vxworks.ads: Remove support for System.Traces.
2017-09-07 Yannick Moy <moy@adacore.com>
* a-ngelfu.ads Add preconditions to all functions
listed in Ada RM A.5.1(19-33) as having constraints on inputs.
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* lib-xref.adb (Generate_Reference): ignore
references to entities which are Part_Of single concurrent
objects.
2017-09-07 Eric Botcazou <ebotcazou@adacore.com>
* sem_ch7.adb (Hide_Public_Entities): Add paragraph to main
comment.
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* a-taside.adb (Activation_Is_Complete): Raise Program_Error if
Null_Task_Id is passed.
2017-09-07 Javier Miranda <miranda@adacore.com>
* einfo.ads, einfo.adb (Access_Disp_Table_Elab_Flag): New
attribute. Defined for record types and subtypes.
* exp_ch3.ads (Init_Secondary_Tags): Adding new formal
(Init_Tags_List) to facilitate generating separate code in the
IP routine to initialize the object components and for completing
the elaboration of dispatch tables.
* exp_ch3.adb (Build_Init_Procedure): Improve the code
generated in the IP routines by means of keeping separate
the initialization of the object components from the
initialization of its dispatch tables. (Init_Secondary_Tags):
Adding new formal (Init_Tags_List) and adjusting calls to
Ada.Tags.Set_Dynamic_Offset_To_Top since it has a new formal;
adjusting also calls to Ada.Tags.Register_Interface_Offset
because the type of one of its formals has been changed.
* a-tags.ads, a-tags.adb (Register_Interface_Offset): Profile
modified. Instead of receiving a pointer to an object this
routine receives now a primary tag.
(Set_Dyanic_Offset_To_Top): Profile modified. This routine receives an
additional formal: the tag of the primary dispatch table.
* exp_disp.ads (Elab_Flag_Needed): New subprogram.
* exp_disp.adb (Elab_Flag_Needed): New subprogram.
(Make_Tags): Adding the declaration of the elaboration flag (if needed).
* exp_aggr.adb (Build_Record_Aggr_Code): Adding actual of new
formal in calls to Init_Secondary_Tags.
2017-09-07 Javier Miranda <miranda@adacore.com>
* ghost.adb (Mark_And_Set_Ghost_Instantiation.Check_Ghost_Actuals): New
subprogram.
* sem_prag.adb (Pragma_Ghost): Add missing support for ghost
applied to generic subprograms.
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* sem_util.adb (Check_Part_Of_Reference): rename Conc_Typ to Conc_Obj

2
gcc/ada/Makefile.rtl
View File

@ -73,7 +73,6 @@ GNATRTL_TASKING_OBJS= \
s-tpoben$(objext) \
s-tpobop$(objext) \
s-tposen$(objext) \
s-tratas$(objext) \
thread$(objext) \
$(EXTRA_GNATRTL_TASKING_OBJS)
@ -673,7 +672,6 @@ GNATRTL_NONTASKING_OBJS= \
s-ststop$(objext) \
s-tasloc$(objext) \
s-traceb$(objext) \
s-traces$(objext) \
s-traent$(objext) \
s-unstyp$(objext) \
s-utf_32$(objext) \

22
gcc/ada/a-caldel.adb
View File

@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2010, AdaCore --
-- Copyright (C) 1995-2017, AdaCore --
-- --
-- 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- --
@ -32,8 +32,6 @@
with System.OS_Primitives;
with System.Soft_Links;
with System.Traces;
with System.Parameters;
package body Ada.Calendar.Delays is
@ -42,8 +40,6 @@ package body Ada.Calendar.Delays is
use type SSL.Timed_Delay_Call;
use System.Traces;
-- Earlier, System.Time_Operations was used to implement the following
-- operations. The idea was to avoid sucking in the tasking packages. This
-- did not work. Logically, we can't have it both ways. There is no way to
@ -64,16 +60,8 @@ package body Ada.Calendar.Delays is
procedure Delay_For (D : Duration) is
begin
if System.Parameters.Runtime_Traces then
Send_Trace_Info (W_Delay, D);
end if;
SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay),
OSP.Relative);
if System.Parameters.Runtime_Traces then
Send_Trace_Info (M_Delay, D);
end if;
end Delay_For;
-----------------
@ -84,15 +72,7 @@ package body Ada.Calendar.Delays is
D : constant Duration := To_Duration (T);
begin
if System.Parameters.Runtime_Traces then
Send_Trace_Info (WU_Delay, D);
end if;
SSL.Timed_Delay.all (D, OSP.Absolute_Calendar);
if System.Parameters.Runtime_Traces then
Send_Trace_Info (M_Delay, D);
end if;
end Delay_Until;
--------------------

41
gcc/ada/a-ngelfu.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2012-2016, Free Software Foundation, Inc. --
-- Copyright (C) 2012-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -41,7 +41,16 @@ package Ada.Numerics.Generic_Elementary_Functions with
is
pragma Pure;
-- Preconditions in this unit are meant for analysis only, not for run-time
-- checking, so that the expected exceptions are raised when calling
-- Assert. This is enforced by setting the corresponding assertion policy
-- to Ignore. This is done in the generic spec so that it applies to all
-- instances.
pragma Assertion_Policy (Pre => Ignore);
function Sqrt (X : Float_Type'Base) return Float_Type'Base with
Pre => X >= 0.0,
Post => Sqrt'Result >= 0.0
and then (if X = 0.0 then Sqrt'Result = 0.0)
and then (if X = 1.0 then Sqrt'Result = 1.0)
@ -64,15 +73,18 @@ is
and then (if X >= Float_Type'Succ (0.0) then Sqrt'Result > 0.0);
function Log (X : Float_Type'Base) return Float_Type'Base with
Pre => X > 0.0,
Post => (if X = 1.0 then Log'Result = 0.0);
function Log (X, Base : Float_Type'Base) return Float_Type'Base with
Pre => X > 0.0 and Base > 0.0 and Base /= 1.0,
Post => (if X = 1.0 then Log'Result = 0.0);
function Exp (X : Float_Type'Base) return Float_Type'Base with
Post => (if X = 0.0 then Exp'Result = 1.0);
function "**" (Left, Right : Float_Type'Base) return Float_Type'Base with
Pre => (if Left = 0.0 then Right > 0.0) and Left >= 0.0,
Post => "**"'Result >= 0.0
and then (if Right = 0.0 then "**"'Result = 1.0)
and then (if Right = 1.0 then "**"'Result = Left)
@ -84,6 +96,7 @@ is
and then (if X = 0.0 then Sin'Result = 0.0);
function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base with
Pre => Cycle > 0.0,
Post => Sin'Result in -1.0 .. 1.0
and then (if X = 0.0 then Sin'Result = 0.0);
@ -92,6 +105,7 @@ is
and then (if X = 0.0 then Cos'Result = 1.0);
function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base with
Pre => Cycle > 0.0,
Post => Cos'Result in -1.0 .. 1.0
and then (if X = 0.0 then Cos'Result = 1.0);
@ -99,28 +113,40 @@ is
Post => (if X = 0.0 then Tan'Result = 0.0);
function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base with
Pre => Cycle > 0.0
and then abs Float_Type'Base'Remainder (X, Cycle) /= 0.25 * Cycle,
Post => (if X = 0.0 then Tan'Result = 0.0);
function Cot (X : Float_Type'Base) return Float_Type'Base;
function Cot (X : Float_Type'Base) return Float_Type'Base with
Pre => X /= 0.0;
function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base;
function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base with
Pre => Cycle > 0.0
and then X /= 0.0
and then Float_Type'Base'Remainder (X, Cycle) /= 0.0
and then abs Float_Type'Base'Remainder (X, Cycle) = 0.5 * Cycle;
function Arcsin (X : Float_Type'Base) return Float_Type'Base with
Pre => abs X <= 1.0,
Post => (if X = 0.0 then Arcsin'Result = 0.0);
function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base with
Pre => Cycle > 0.0 and abs X <= 1.0,
Post => (if X = 0.0 then Arcsin'Result = 0.0);
function Arccos (X : Float_Type'Base) return Float_Type'Base with
Pre => abs X <= 1.0,
Post => (if X = 1.0 then Arccos'Result = 0.0);
function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base with
Pre => Cycle > 0.0 and abs X <= 1.0,
Post => (if X = 1.0 then Arccos'Result = 0.0);
function Arctan
(Y : Float_Type'Base;
X : Float_Type'Base := 1.0) return Float_Type'Base
with
Pre => X /= 0.0 or Y /= 0.0,
Post => (if X > 0.0 and then Y = 0.0 then Arctan'Result = 0.0);
function Arctan
@ -128,12 +154,14 @@ is
X : Float_Type'Base := 1.0;
Cycle : Float_Type'Base) return Float_Type'Base
with
Pre => Cycle > 0.0 and (X /= 0.0 or Y /= 0.0),
Post => (if X > 0.0 and then Y = 0.0 then Arctan'Result = 0.0);
function Arccot
(X : Float_Type'Base;
Y : Float_Type'Base := 1.0) return Float_Type'Base
with
Pre => X /= 0.0 or Y /= 0.0,
Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0);
function Arccot
@ -141,6 +169,7 @@ is
Y : Float_Type'Base := 1.0;
Cycle : Float_Type'Base) return Float_Type'Base
with
Pre => Cycle > 0.0 and (X /= 0.0 or Y /= 0.0),
Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0);
function Sinh (X : Float_Type'Base) return Float_Type'Base with
@ -155,18 +184,22 @@ is
and then (if X = 0.0 then Tanh'Result = 0.0);
function Coth (X : Float_Type'Base) return Float_Type'Base with
Pre => X /= 0.0,
Post => abs Coth'Result >= 1.0;
function Arcsinh (X : Float_Type'Base) return Float_Type'Base with
Post => (if X = 0.0 then Arcsinh'Result = 0.0);
function Arccosh (X : Float_Type'Base) return Float_Type'Base with
Pre => X >= 1.0,
Post => Arccosh'Result >= 0.0
and then (if X = 1.0 then Arccosh'Result = 0.0);
function Arctanh (X : Float_Type'Base) return Float_Type'Base with
Pre => abs X /= 1.0,
Post => (if X = 0.0 then Arctanh'Result = 0.0);
function Arccoth (X : Float_Type'Base) return Float_Type'Base;
function Arccoth (X : Float_Type'Base) return Float_Type'Base with
Pre => X <= 1.0 and abs X /= 1.0;
end Ada.Numerics.Generic_Elementary_Functions;

19
gcc/ada/a-tags.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -906,22 +906,16 @@ package body Ada.Tags is
-------------------------------
procedure Register_Interface_Offset
(This : System.Address;
(Prim_T : Tag;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr)
is
Prim_DT : Dispatch_Table_Ptr;
Iface_Table : Interface_Data_Ptr;
Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T);
Iface_Table : constant Interface_Data_Ptr :=
To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
begin
-- "This" points to the primary DT and we must save Offset_Value in
-- the Offset_To_Top field of the corresponding dispatch table.
Prim_DT := DT (To_Tag_Ptr (This).all);
Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
-- Save Offset_Value in the table of interfaces of the primary DT.
-- This data will be used by the subprogram "Displace" to give support
-- to backward abstract interface type conversions.
@ -1008,6 +1002,7 @@ package body Ada.Tags is
procedure Set_Dynamic_Offset_To_Top
(This : System.Address;
Prim_T : Tag;
Interface_T : Tag;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr)
@ -1025,7 +1020,7 @@ package body Ada.Tags is
end if;
Register_Interface_Offset
(This, Interface_T, False, Offset_Value, Offset_Func);
(Prim_T, Interface_T, False, Offset_Value, Offset_Func);
end Set_Dynamic_Offset_To_Top;
----------------------

40
gcc/ada/a-tags.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -527,18 +527,18 @@ private
-- assumes that _size is always in slot one of the dispatch table.
procedure Register_Interface_Offset
(This : System.Address;
(Prim_T : Tag;
Interface_T : Tag;
Is_Static : Boolean;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr);
-- Register in the table of interfaces of the tagged type associated with
-- "This" object the offset of the record component associated with the
-- progenitor Interface_T (that is, the distance from "This" to the object
-- component containing the tag of the secondary dispatch table). In case
-- of constant offset, Is_Static is true and Offset_Value has such value.
-- In case of variable offset, Is_Static is false and Offset_Func is an
-- access to function that must be called to evaluate the offset.
-- Prim_T the offset of the record component associated with the progenitor
-- Interface_T (that is, the distance from "This" to the object component
-- containing the tag of the secondary dispatch table). In case of constant
-- offset, Is_Static is true and Offset_Value has such value. In case of
-- variable offset, Is_Static is false and Offset_Func is an access to
-- function that must be called to evaluate the offset.
procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the sake
@ -546,20 +546,24 @@ private
procedure Set_Dynamic_Offset_To_Top
(This : System.Address;
Prim_T : Tag;
Interface_T : Tag;
Offset_Value : SSE.Storage_Offset;
Offset_Func : Offset_To_Top_Function_Ptr);
-- Ada 2005 (AI-251): The compiler generates calls to this routine only
-- when initializing the Offset_To_Top field of dispatch tables associated
-- with tagged type whose parent has variable size components. "This" is
-- the object whose dispatch table is being initialized. Interface_T is the
-- interface for which the secondary dispatch table is being initialized,
-- and Offset_Value is the distance from "This" to the object component
-- containing the tag of the secondary dispatch table (a zero value means
-- that this interface shares the primary dispatch table). Offset_Func
-- references a function that must be called to evaluate the offset at
-- runtime. This routine also takes care of registering these values in
-- the table of interfaces of the type.
-- when initializing the Offset_To_Top field of dispatch tables of tagged
-- types that cover interface types whose parent type has variable size
-- components.
--
-- "This" is the object whose dispatch table is being initialized. Prim_T
-- is the primary tag of such object. Interface_T is the interface tag for
-- which the secondary dispatch table is being initialized, Offset_Value
-- is the distance from "This" to the object component containing the tag
-- of the secondary dispatch table (a zero value means that this interface
-- shares the primary dispatch table). Offset_Func references a function
-- that must be called to evaluate the offset at runtime. This routine also
-- takes care of registering these values in the table of interfaces of the
-- type.
procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
-- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's

8
gcc/ada/a-taside.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -92,7 +92,11 @@ is
function Activation_Is_Complete (T : Task_Id) return Boolean is
use type System.Tasking.Task_Id;
begin
return Convert_Ids (T).Common.Activator = null;
if T = Null_Task_Id then
raise Program_Error;
else
return Convert_Ids (T).Common.Activator = null;
end if;
end Activation_Is_Complete;
-----------------

22
gcc/ada/einfo.adb
View File

@ -249,6 +249,7 @@ package body Einfo is
-- BIP_Initialization_Call Node29
-- Subprograms_For_Type Elist29
-- Access_Disp_Table_Elab_Flag Node30
-- Anonymous_Object Node30
-- Corresponding_Equality Node30
-- Last_Aggregate_Assignment Node30
@ -724,6 +725,14 @@ package body Einfo is
return Elist16 (Implementation_Base_Type (Id));
end Access_Disp_Table;
function Access_Disp_Table_Elab_Flag (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Record_Type,
E_Record_Type_With_Private,
E_Record_Subtype));
return Node30 (Implementation_Base_Type (Id));
end Access_Disp_Table_Elab_Flag;
function Activation_Record_Component (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Constant,
@ -3817,6 +3826,14 @@ package body Einfo is
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
procedure Set_Access_Disp_Table_Elab_Flag (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Record_Type
and then Id = Implementation_Base_Type (Id));
pragma Assert (Is_Tagged_Type (Id));
Set_Node30 (Id, V);
end Set_Access_Disp_Table_Elab_Flag;
procedure Set_Anonymous_Designated_Type (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Variable);
@ -10855,6 +10872,11 @@ package body Einfo is
procedure Write_Field30_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Record_Type
| E_Record_Type_With_Private
=>
Write_Str ("Access_Disp_Table_Elab_Flag");
when E_Protected_Type
| E_Task_Type
=>

13
gcc/ada/einfo.ads
View File

@ -355,6 +355,14 @@ package Einfo is
-- used to expand dispatching calls through the primary dispatch table.
-- For an untagged record, contains No_Elist.
-- Access_Disp_Table_Elab_Flag (Node30) [implementation base type only]
-- Defined in E_Record_Type and E_Record_Subtype entities. Set in tagged
-- types whose dispatch table elaboration must be completed at runtime by
-- the IP routine to point to its pending elaboration flag entity. This
-- flag is needed when the elaboration of the dispatch table relies on
-- attribute 'Position applied to an object of the type; it is used by
-- the IP routine to avoid performing this elaboration twice.
-- Activation_Record_Component (Node31)
-- Defined in E_Variable, E_Constant, E_Loop_Parameter, E_In_Parameter,
-- E_Out_Parameter, E_In_Out_Parameter nodes. Used only if we are in
@ -6466,6 +6474,7 @@ package Einfo is
-- E_Record_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Access_Disp_Table (Elist16) (base type only)
-- Access_Disp_Table_Elab_Flag (Node30) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18)
@ -6911,6 +6920,7 @@ package Einfo is
function Abstract_States (Id : E) return L;
function Accept_Address (Id : E) return L;
function Access_Disp_Table (Id : E) return L;
function Access_Disp_Table_Elab_Flag (Id : E) return E;
function Activation_Record_Component (Id : E) return E;
function Actual_Subtype (Id : E) return E;
function Address_Taken (Id : E) return B;
@ -7602,6 +7612,7 @@ package Einfo is
procedure Set_Abstract_States (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Access_Disp_Table_Elab_Flag (Id : E; V : E);
procedure Set_Activation_Record_Component (Id : E; V : E);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
@ -8415,6 +8426,7 @@ package Einfo is
pragma Inline (Abstract_States);
pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table);
pragma Inline (Access_Disp_Table_Elab_Flag);
pragma Inline (Activation_Record_Component);
pragma Inline (Actual_Subtype);
pragma Inline (Address_Taken);
@ -8941,6 +8953,7 @@ package Einfo is
pragma Inline (Set_Abstract_States);
pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Access_Disp_Table_Elab_Flag);
pragma Inline (Set_Activation_Record_Component);
pragma Inline (Set_Actual_Subtype);
pragma Inline (Set_Address_Taken);

6
gcc/ada/exp_aggr.adb
View File

@ -3324,7 +3324,8 @@ package body Exp_Aggr is
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
Stmts_List => Assign);
Stmts_List => Assign,
Init_Tags_List => Assign);
end if;
end if;
@ -3859,7 +3860,8 @@ package body Exp_Aggr is
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
Stmts_List => L);
Stmts_List => L,
Init_Tags_List => L);
end if;
end if;

70
gcc/ada/exp_ch3.adb
View File

@ -2475,18 +2475,44 @@ package body Exp_Ch3 is
and then not Is_Interface (Rec_Type)
and then Has_Interfaces (Rec_Type)
then
Init_Secondary_Tags
(Typ => Rec_Type,
Target => Make_Identifier (Loc, Name_uInit),
Stmts_List => Init_Tags_List,
Fixed_Comps => True,
Variable_Comps => False);
end if;
declare
Elab_Sec_DT_Stmts_List : constant List_Id := New_List;
Prepend_To (Body_Stmts,
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List));
begin
Init_Secondary_Tags
(Typ => Rec_Type,
Target => Make_Identifier (Loc, Name_uInit),
Init_Tags_List => Init_Tags_List,
Stmts_List => Elab_Sec_DT_Stmts_List,
Fixed_Comps => True,
Variable_Comps => False);
Append_To (Elab_Sec_DT_Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of
(Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
Expression =>
New_Occurrence_Of (Standard_False, Loc)));
Prepend_List_To (Body_Stmts,
New_List (
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List),
Make_If_Statement (Loc,
Condition =>
New_Occurrence_Of
(Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
Then_Statements => Elab_Sec_DT_Stmts_List)));
end;
else
Prepend_To (Body_Stmts,
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List));
end if;
-- Case 2: CPP type. The imported C++ constructor takes care of
-- tags initialization. No action needed here because the IP
@ -2533,6 +2559,7 @@ package body Exp_Ch3 is
Init_Secondary_Tags
(Typ => Rec_Type,
Target => Make_Identifier (Loc, Name_uInit),
Init_Tags_List => Init_Tags_List,
Stmts_List => Init_Tags_List,
Fixed_Comps => True,
Variable_Comps => False);
@ -2606,6 +2633,7 @@ package body Exp_Ch3 is
Init_Secondary_Tags
(Typ => Rec_Type,
Target => Make_Identifier (Loc, Name_uInit),
Init_Tags_List => Init_Tags_List,
Stmts_List => Init_Tags_List,
Fixed_Comps => False,
Variable_Comps => True);
@ -8119,6 +8147,7 @@ package body Exp_Ch3 is
procedure Init_Secondary_Tags
(Typ : Entity_Id;
Target : Node_Id;
Init_Tags_List : List_Id;
Stmts_List : List_Id;
Fixed_Comps : Boolean := True;
Variable_Comps : Boolean := True)
@ -8156,7 +8185,7 @@ package body Exp_Ch3 is
-- Initialize pointer to secondary DT associated with the interface
if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
Append_To (Stmts_List,
Append_To (Init_Tags_List,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
@ -8190,6 +8219,7 @@ package body Exp_Ch3 is
-- Generate:
-- Set_Dynamic_Offset_To_Top
-- (This => Init,
-- Prim_T => Typ'Tag,
-- Interface_T => Iface'Tag,
-- Offset_Value => n,
-- Offset_Func => Fn'Address)
@ -8203,6 +8233,10 @@ package body Exp_Ch3 is
Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Iface))),
@ -8230,7 +8264,7 @@ package body Exp_Ch3 is
Offset_To_Top_Comp := Next_Entity (Tag_Comp);
pragma Assert (Present (Offset_To_Top_Comp));
Append_To (Stmts_List,
Append_To (Init_Tags_List,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
@ -8269,7 +8303,7 @@ package body Exp_Ch3 is
-- Generate:
-- Register_Interface_Offset
-- (This => Init,
-- (Prim_T => Typ'Tag,
-- Interface_T => Iface'Tag,
-- Is_Constant => True,
-- Offset_Value => n,
@ -8282,9 +8316,9 @@ package body Exp_Ch3 is
New_Occurrence_Of
(RTE (RE_Register_Interface_Offset), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc)),
Unchecked_Convert_To (RTE (RE_Tag),
New_Occurrence_Of
@ -8403,7 +8437,7 @@ package body Exp_Ch3 is
-- Initialize secondary tags
else
Append_To (Stmts_List,
Append_To (Init_Tags_List,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,

12
gcc/ada/exp_ch3.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -94,15 +94,17 @@ package Exp_Ch3 is
procedure Init_Secondary_Tags
(Typ : Entity_Id;
Target : Node_Id;
Init_Tags_List : List_Id;
Stmts_List : List_Id;
Fixed_Comps : Boolean := True;
Variable_Comps : Boolean := True);
-- Ada 2005 (AI-251): Initialize the tags of the secondary dispatch tables
-- of Typ. The generated code referencing tag fields of Target is appended
-- to Stmts_List. If Fixed_Comps is True then the tag components located at
-- fixed positions of Target are initialized; if Variable_Comps is True
-- then tags components located at variable positions of Target are
-- initialized.
-- to Init_Tags_List and the code required to complete the elaboration of
-- the dispatch tables of Typ is appended to Stmts_List. If Fixed_Comps is
-- True then the tag components located at fixed positions of Target are
-- initialized; if Variable_Comps is True then tags components located at
-- variable positions of Target are initialized.
function Make_Tag_Assignment (N : Node_Id) return Node_Id;
-- An object declaration that has an initialization for a tagged object

29
gcc/ada/exp_disp.adb
View File

@ -625,6 +625,17 @@ package body Exp_Disp is
raise Program_Error;
end Default_Prim_Op_Position;
----------------------
-- Elab_Flag_Needed --
----------------------
function Elab_Flag_Needed (Typ : Entity_Id) return Boolean is
begin
return Ada_Version >= Ada_2005
and then not Is_Interface (Typ)
and then Has_Interfaces (Typ);
end Elab_Flag_Needed;
-----------------------------
-- Expand_Dispatching_Call --
-----------------------------
@ -6670,6 +6681,24 @@ package body Exp_Disp is
pragma Assert (No (Access_Disp_Table (Typ)));
Set_Access_Disp_Table (Typ, New_Elmt_List);
-- If the elaboration of this tagged type needs a boolean flag then
-- define now its entity. It is initialized to True to indicate that
-- elaboration is still pending; set to False by the IP routine.
-- TypFxx : boolean := True;
if Elab_Flag_Needed (Typ) then
Set_Access_Disp_Table_Elab_Flag (Typ,
Make_Defining_Identifier (Loc,
New_External_Name (Tname, 'F', Suffix_Index => -1)));
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Access_Disp_Table_Elab_Flag (Typ),
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => New_Occurrence_Of (Standard_True, Loc)));
end if;
-- 1) Generate the primary tag entities
-- Primary dispatch table containing user-defined primitives

6
gcc/ada/exp_disp.ads
View File

@ -214,6 +214,12 @@ package Exp_Disp is
-- Return the number of primitives of the C++ part of the dispatch table.
-- For types that are not derivations of CPP types return 0.
function Elab_Flag_Needed (Typ : Entity_Id) return Boolean;
-- Return True if the elaboration of the tagged type Typ is completed at
-- runtime by the execution of code located in the IP routine and the
-- expander must generate an extra elaboration flag to avoid performing
-- such elaboration twice.
procedure Expand_Dispatching_Call (Call_Node : Node_Id);
-- Expand the call to the operation through the dispatch table and perform
-- the required tag checks when appropriate. For CPP types tag checks are

44
gcc/ada/ghost.adb
View File

@ -1303,6 +1303,43 @@ package body Ghost is
(N : Node_Id;
Gen_Id : Entity_Id)
is
procedure Check_Ghost_Actuals;
-- Check the context of ghost actuals
-------------------------
-- Check_Ghost_Actuals --
-------------------------
procedure Check_Ghost_Actuals is
Assoc : Node_Id := First (Generic_Associations (N));
Act : Node_Id;
begin
while Present (Assoc) loop
if Nkind (Assoc) /= N_Others_Choice then
Act := Explicit_Generic_Actual_Parameter (Assoc);
-- Within a nested instantiation, a defaulted actual is an
-- empty association, so nothing to check.
if No (Act) then
null;
elsif Comes_From_Source (Act)
and then Nkind (Act) in N_Has_Etype
and then Present (Etype (Act))
and then Is_Ghost_Entity (Etype (Act))
then
Check_Ghost_Context (Etype (Act), Act);
end if;
end if;
Next (Assoc);
end loop;
end Check_Ghost_Actuals;
-- Local variables
Policy : Name_Id := No_Name;
begin
@ -1336,6 +1373,13 @@ package body Ghost is
-- Install the appropriate Ghost mode
Install_Ghost_Mode (Policy);
-- Check ghost actuals. Given that this routine is unconditionally
-- invoked with subprogram and package instantiations, this check
-- verifies the context of all the ghost entities passed in generic
-- instantiations.
Check_Ghost_Actuals;
end Mark_And_Set_Ghost_Instantiation;
---------------------------------------

13
gcc/ada/lib-xref.adb
View File

@ -1126,6 +1126,19 @@ package body Lib.Xref is
-- Comment needed here for special SPARK code ???
if GNATprove_Mode then
-- Ignore reference to an entity that is a Part_Of single
-- concurrent object. Ideally we would prefer to add it as a
-- reference to the corresponding concurrent type, but it is quite
-- difficult (as such references are not currently added even for)
-- reads/writes of private protected components) and not worth the
-- effort.
if Ekind_In (Ent, E_Abstract_State, E_Constant, E_Variable)
and then Present (Encapsulating_State (Ent))
and then Is_Single_Concurrent_Object (Encapsulating_State (Ent))
then
return;
end if;
Ref := Sloc (Nod);
Def := Sloc (Ent);

11
gcc/ada/s-parame-hpux.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -181,15 +181,6 @@ package System.Parameters is
Max_Attribute_Count : constant := 32;
-- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
--------------------
Runtime_Traces : constant Boolean := False;
-- This constant indicates whether the runtime outputs traces to a
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------

11
gcc/ada/s-parame-vxworks.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -183,15 +183,6 @@ package System.Parameters is
Max_Attribute_Count : constant := 16;
-- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
--------------------
Runtime_Traces : constant Boolean := False;
-- This constant indicates whether the runtime outputs traces to a
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------

11
gcc/ada/s-parame.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -183,15 +183,6 @@ package System.Parameters is
Max_Attribute_Count : constant := 32;
-- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
--------------------
Runtime_Traces : constant Boolean := False;
-- This constant indicates whether the runtime outputs traces to a
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------

8
gcc/ada/s-taasde.adb
View File

@ -42,8 +42,6 @@ with System.Tasking.Initialization;
with System.Tasking.Debug;
with System.OS_Primitives;
with System.Interrupt_Management.Operations;
with System.Parameters;
with System.Traces.Tasking;
package body System.Tasking.Async_Delays is
@ -54,8 +52,6 @@ package body System.Tasking.Async_Delays is
package OSP renames System.OS_Primitives;
use Parameters;
use System.Traces;
use System.Traces.Tasking;
function To_System is new Ada.Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_Id);
@ -369,10 +365,6 @@ package body System.Tasking.Async_Delays is
-- the timer queue, but that is OK because we always restart the
-- next iteration at the head of the queue.
if Parameters.Runtime_Traces then
Send_Trace_Info (E_Kill, Dequeued.Self_Id);
end if;
STPO.Unlock (Timer_Server_ID);
STPO.Write_Lock (Dequeued.Self_Id);
Dequeued_Task := Dequeued.Self_Id;

28
gcc/ada/s-taenca.adb
View File

@ -36,7 +36,6 @@ with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Queuing;
with System.Tasking.Utilities;
with System.Parameters;
with System.Traces;
package body System.Tasking.Entry_Calls is
@ -46,7 +45,6 @@ package body System.Tasking.Entry_Calls is
use Task_Primitives;
use Protected_Objects.Entries;
use Protected_Objects.Operations;
use System.Traces;
-- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
-- internally. Those operations will raise Program_Error, which
@ -478,10 +476,6 @@ package body System.Tasking.Entry_Calls is
-- If this is a conditional call, it should be cancelled when it
-- becomes abortable. This is checked in the loop below.
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Completion);
end if;
Self_Id.Common.State := Entry_Caller_Sleep;
-- Try to remove calls to Sleep in the loop below by letting the caller
@ -515,9 +509,6 @@ package body System.Tasking.Entry_Calls is
Self_Id.Common.State := Runnable;
Utilities.Exit_One_ATC_Level (Self_Id);
if Parameters.Runtime_Traces then
Send_Trace_Info (M_Call_Complete);
end if;
end Wait_For_Completion;
--------------------------------------
@ -567,10 +558,6 @@ package body System.Tasking.Entry_Calls is
-- is allowed to wake up at any time, not just when the condition is
-- signaled. See same loop in the ordinary Wait_For_Completion, above.
if Parameters.Runtime_Traces then
Send_Trace_Info (WT_Completion, Wakeup_Time);
end if;
loop
Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
exit when Entry_Call.State >= Done;
@ -579,10 +566,6 @@ package body System.Tasking.Entry_Calls is
Entry_Caller_Sleep, Timedout, Yielded);
if Timedout then
if Parameters.Runtime_Traces then
Send_Trace_Info (E_Timeout);
end if;
-- Try to cancel the call (see Try_To_Cancel_Entry_Call for
-- corresponding code in the ATC case).
@ -620,10 +603,6 @@ package body System.Tasking.Entry_Calls is
-- This last part is the same as ordinary Wait_For_Completion,
-- and is only executed if the call completed without timing out.
if Parameters.Runtime_Traces then
Send_Trace_Info (M_Call_Complete);
end if;
Self_Id.Common.State := Runnable;
Utilities.Exit_One_ATC_Level (Self_Id);
end Wait_For_Completion_With_Timeout;
@ -640,10 +619,6 @@ package body System.Tasking.Entry_Calls is
pragma Assert (Self_ID.ATC_Nesting_Level > 0);
pragma Assert (Call.Mode = Asynchronous_Call);
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Completion);
end if;
STPO.Write_Lock (Self_ID);
Self_ID.Common.State := Entry_Caller_Sleep;
@ -656,9 +631,6 @@ package body System.Tasking.Entry_Calls is
Self_ID.Common.State := Runnable;
STPO.Unlock (Self_ID);
if Parameters.Runtime_Traces then
Send_Trace_Info (M_Call_Complete);
end if;
end Wait_Until_Abortable;
end System.Tasking.Entry_Calls;

18
gcc/ada/s-taprob.adb
View File

@ -6,8 +6,8 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2014, AdaCore --
-- Copyright (C) 1991-1997, Florida State University --
-- Copyright (C) 1995-2017, AdaCore --
-- --
-- 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- --
@ -35,8 +35,6 @@ pragma Polling (Off);
-- operations. It causes infinite loops and other problems.
with System.Task_Primitives.Operations;
with System.Parameters;
with System.Traces;
with System.Soft_Links.Tasking;
with System.Secondary_Stack;
@ -48,7 +46,6 @@ pragma Unreferenced (System.Secondary_Stack);
package body System.Tasking.Protected_Objects is
use System.Task_Primitives.Operations;
use System.Traces;
----------------
-- Local Data --
@ -128,10 +125,6 @@ package body System.Tasking.Protected_Objects is
Write_Lock (Object.L'Access, Ceiling_Violation);
if Parameters.Runtime_Traces then
Send_Trace_Info (PO_Lock);
end if;
if Ceiling_Violation then
raise Program_Error;
end if;
@ -185,10 +178,6 @@ package body System.Tasking.Protected_Objects is
Read_Lock (Object.L'Access, Ceiling_Violation);
if Parameters.Runtime_Traces then
Send_Trace_Info (PO_Lock);
end if;
if Ceiling_Violation then
raise Program_Error;
end if;
@ -271,9 +260,6 @@ package body System.Tasking.Protected_Objects is
Unlock (Object.L'Access);
if Parameters.Runtime_Traces then
Send_Trace_Info (PO_Unlock);
end if;
end Unlock;
begin

79
gcc/ada/s-tasren.adb
View File

@ -38,7 +38,6 @@ with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Debug;
with System.Restrictions;
with System.Parameters;
with System.Traces.Tasking;
package body System.Tasking.Rendezvous is
@ -48,8 +47,6 @@ package body System.Tasking.Rendezvous is
use Parameters;
use Task_Primitives.Operations;
use System.Traces;
use System.Traces.Tasking;
type Select_Treatment is (
Accept_Alternative_Selected, -- alternative with non-null body
@ -200,10 +197,6 @@ package body System.Tasking.Rendezvous is
-- Wait for normal call
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
end if;
pragma Debug
(Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
Wait_For_Call (Self_Id);
@ -232,9 +225,6 @@ package body System.Tasking.Rendezvous is
Initialization.Undefer_Abort (Self_Id);
if Parameters.Runtime_Traces then
Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E));
end if;
end Accept_Call;
--------------------
@ -285,10 +275,6 @@ package body System.Tasking.Rendezvous is
Open_Accepts (1).S := E;
Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
end if;
pragma Debug
(Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));
@ -314,15 +300,6 @@ package body System.Tasking.Rendezvous is
STPO.Unlock (Caller);
end if;
if Parameters.Runtime_Traces then
Send_Trace_Info (M_Accept_Complete);
-- Fake one, since there is (???) no way to know that the rendezvous
-- is over.
Send_Trace_Info (M_RDV_Complete);
end if;
if Single_Lock then
Unlock_RTS;
end if;
@ -404,10 +381,6 @@ package body System.Tasking.Rendezvous is
Entry_Call.Mode := Mode;
Entry_Call.Cancellation_Attempted := False;
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
end if;
-- If this is a call made inside of an abort deferred region,
-- the call should be never abortable.
@ -438,10 +411,6 @@ package body System.Tasking.Rendezvous is
Unlock_RTS;
end if;
if Parameters.Runtime_Traces then
Send_Trace_Info (E_Missed, Acceptor);
end if;
Local_Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
@ -560,10 +529,6 @@ package body System.Tasking.Rendezvous is
-- The call came from normal end-of-rendezvous, so abort is not yet
-- deferred.
if Parameters.Runtime_Traces then
Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
end if;
Initialization.Defer_Abort (Self_Id);
elsif ZCX_By_Default then
@ -848,10 +813,6 @@ package body System.Tasking.Rendezvous is
-- Accept body is null, so rendezvous is over immediately
if Parameters.Runtime_Traces then
Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
end if;
STPO.Unlock (Self_Id);
Caller := Entry_Call.Self;
@ -867,11 +828,6 @@ package body System.Tasking.Rendezvous is
pragma Debug
(Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Select, Self_Id,
Integer (Open_Accepts'Length));
end if;
Wait_For_Call (Self_Id);
pragma Assert (Self_Id.Open_Accepts = null);
@ -908,10 +864,6 @@ package body System.Tasking.Rendezvous is
when Else_Selected =>
pragma Assert (Self_Id.Open_Accepts = null);
if Parameters.Runtime_Traces then
Send_Trace_Info (M_Select_Else);
end if;
STPO.Unlock (Self_Id);
when Terminate_Selected =>
@ -1320,10 +1272,6 @@ package body System.Tasking.Rendezvous is
"potentially blocking operation";
end if;
if Parameters.Runtime_Traces then
Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
end if;
if Mode = Simple_Call or else Mode = Conditional_Call then
Call_Synchronous
(Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
@ -1369,10 +1317,6 @@ package body System.Tasking.Rendezvous is
Initialization.Undefer_Abort (Self_Id);
if Parameters.Runtime_Traces then
Send_Trace_Info (E_Missed, Acceptor);
end if;
raise Tasking_Error;
end if;
@ -1514,10 +1458,6 @@ package body System.Tasking.Rendezvous is
-- Rendezvous is over
if Parameters.Runtime_Traces then
Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
end if;
STPO.Unlock (Self_Id);
Caller := Entry_Call.Self;
@ -1568,23 +1508,12 @@ package body System.Tasking.Rendezvous is
if Timedout then
Sleep (Self_Id, Acceptor_Delay_Sleep);
else
if Parameters.Runtime_Traces then
Send_Trace_Info (WT_Select,
Self_Id,
Integer (Open_Accepts'Length),
Timeout);
end if;
STPO.Timed_Sleep (Self_Id, Timeout, Mode,
Acceptor_Delay_Sleep, Timedout, Yielded);
end if;
if Timedout then
Self_Id.Open_Accepts := null;
if Parameters.Runtime_Traces then
Send_Trace_Info (E_Timeout);
end if;
end if;
end loop;
@ -1700,11 +1629,6 @@ package body System.Tasking.Rendezvous is
(Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
if Parameters.Runtime_Traces then
Send_Trace_Info (WT_Call, Acceptor,
Entry_Index (E), Timeout);
end if;
Level := Self_Id.ATC_Nesting_Level;
Entry_Call := Self_Id.Entry_Calls (Level)'Access;
Entry_Call.Next := null;
@ -1744,9 +1668,6 @@ package body System.Tasking.Rendezvous is
Initialization.Undefer_Abort (Self_Id);
if Parameters.Runtime_Traces then
Send_Trace_Info (E_Missed, Acceptor);
end if;
raise Tasking_Error;
end if;

17
gcc/ada/s-tassta.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -52,7 +52,6 @@ with System.OS_Primitives;
with System.Secondary_Stack;
with System.Restrictions;
with System.Standard_Library;
with System.Traces.Tasking;
with System.Stack_Usage;
with System.Storage_Elements;
@ -81,9 +80,6 @@ package body System.Tasking.Stages is
use Task_Primitives.Operations;
use Task_Info;
use System.Traces;
use System.Traces.Tasking;
-----------------------
-- Local Subprograms --
-----------------------
@ -426,9 +422,6 @@ package body System.Tasking.Stages is
-- ??? Why do we need to allow for nested deferral here?
if Runtime_Traces then
Send_Trace_Info (T_Activate);
end if;
end Complete_Activation;
---------------------
@ -709,10 +702,6 @@ package body System.Tasking.Stages is
Created_Task := T;
Initialization.Undefer_Abort_Nestable (Self_ID);
if Runtime_Traces then
Send_Trace_Info (T_Create, T);
end if;
pragma Debug
(Debug.Trace
(Self_ID, "Created task in " & T.Master_of_Task'Img, 'C', T));
@ -1453,10 +1442,6 @@ package body System.Tasking.Stages is
begin
Debug.Task_Termination_Hook;
if Runtime_Traces then
Send_Trace_Info (T_Terminate);
end if;
-- Since GCC cannot allocate stack chunks efficiently without reordering
-- some of the allocations, we have to handle this unexpected situation
-- here. Normally we never have to call Vulnerable_Complete_Task here.

10
gcc/ada/s-tasuti.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -42,7 +42,6 @@ with System.Task_Primitives.Operations;
with System.Tasking.Initialization;
with System.Tasking.Queuing;
with System.Parameters;
with System.Traces.Tasking;
package body System.Tasking.Utilities is
@ -53,9 +52,6 @@ package body System.Tasking.Utilities is
use Task_Primitives;
use Task_Primitives.Operations;
use System.Traces;
use System.Traces.Tasking;
--------------------
-- Abort_One_Task --
--------------------
@ -67,10 +63,6 @@ package body System.Tasking.Utilities is
procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is
begin
if Parameters.Runtime_Traces then
Send_Trace_Info (T_Abort, Self_ID, T);
end if;
Write_Lock (T);
if T.Common.State = Unactivated then

25
gcc/ada/s-tpobop.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -49,7 +49,6 @@ with System.Tasking.Rendezvous;
with System.Tasking.Utilities;
with System.Tasking.Debug;
with System.Parameters;
with System.Traces.Tasking;
with System.Restrictions;
with System.Tasking.Initialization;
@ -67,8 +66,6 @@ package body System.Tasking.Protected_Objects.Operations is
use System.Restrictions;
use System.Restrictions.Rident;
use System.Traces;
use System.Traces.Tasking;
-----------------------
-- Local Subprograms --
@ -272,13 +269,6 @@ package body System.Tasking.Protected_Objects.Operations is
-- PO_Service_Entries on return.
end if;
if Runtime_Traces then
-- ??? Entry_Call can be null
Send_Trace_Info (PO_Done, Entry_Call.Self);
end if;
end Exceptional_Complete_Entry_Body;
--------------------
@ -439,11 +429,6 @@ package body System.Tasking.Protected_Objects.Operations is
Object.Call_In_Progress := Entry_Call;
begin
if Runtime_Traces then
Send_Trace_Info (PO_Run, Self_ID,
Entry_Call.Self, Entry_Index (E));
end if;
pragma Debug
(Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
@ -562,10 +547,6 @@ package body System.Tasking.Protected_Objects.Operations is
pragma Debug
(Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));
if Runtime_Traces then
Send_Trace_Info (PO_Call, Entry_Index (E));
end if;
if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
raise Storage_Error with "not enough ATC nesting levels";
end if;
@ -981,10 +962,6 @@ package body System.Tasking.Protected_Objects.Operations is
raise Program_Error with "potentially blocking operation";
end if;
if Runtime_Traces then
Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
end if;
Initialization.Defer_Abort_Nestable (Self_Id);
Lock_Entries_With_Status (Object, Ceiling_Violation);

6
gcc/ada/sem_ch7.adb
View File

@ -575,6 +575,12 @@ package body Sem_Ch7 is
-- i.e. not just syntactic, and the gain would very likely be worth
-- neither the hassle nor the slowdown of the compiler.
-- Finally, an important thing to be aware of is that, at this point,
-- instantiations are not done yet so we cannot directly see inlined
-- bodies coming from them. That's not catastrophic because only the
-- actual parameters of the instantiations matter here, and they are
-- present in the declarations list of the instantiated packages.
Subprogram_Table.Reset;
Discard := Has_Referencer (Decls, Top_Level => True);
end Hide_Public_Entities;

5
gcc/ada/sem_prag.adb
View File

@ -15825,6 +15825,11 @@ package body Sem_Prag is
elsif Nkind (Context) = N_Subprogram_Declaration then
Id := Defining_Entity (Context);
-- Pragma Ghost applies to a generic subprogram
elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
Id := Defining_Entity (Specification (Context));
end if;
end if;