+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
s-tpoben$(objext) \
s-tpobop$(objext) \
s-tposen$(objext) \
- s-tratas$(objext) \
thread$(objext) \
$(EXTRA_GNATRTL_TASKING_OBJS)
s-ststop$(objext) \
s-tasloc$(objext) \
s-traceb$(objext) \
- s-traces$(objext) \
s-traent$(objext) \
s-unstyp$(objext) \
s-utf_32$(objext) \
-- 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- --
with System.OS_Primitives;
with System.Soft_Links;
-with System.Traces;
-with System.Parameters;
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
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;
-----------------
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;
--------------------
-- --
-- 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 --
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)
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)
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);
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);
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
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
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
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;
-- --
-- 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- --
-------------------------------
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.
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)
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;
----------------------
-- --
-- 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 --
-- 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
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
-- --
-- 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- --
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;
-----------------
-- BIP_Initialization_Call Node29
-- Subprograms_For_Type Elist29
+ -- Access_Disp_Table_Elab_Flag Node30
-- Anonymous_Object Node30
-- Corresponding_Equality Node30
-- Last_Aggregate_Assignment Node30
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,
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);
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
=>
-- 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
-- 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)
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;
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);
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);
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);
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
- Stmts_List => Assign);
+ Stmts_List => Assign,
+ Init_Tags_List => Assign);
end if;
end if;
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
- Stmts_List => L);
+ Stmts_List => L,
+ Init_Tags_List => L);
end if;
end if;
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
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);
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);
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)
-- 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,
-- Generate:
-- Set_Dynamic_Offset_To_Top
-- (This => Init,
+ -- Prim_T => Typ'Tag,
-- Interface_T => Iface'Tag,
-- Offset_Value => n,
-- Offset_Func => Fn'Address)
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))),
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,
-- Generate:
-- Register_Interface_Offset
- -- (This => Init,
+ -- (Prim_T => Typ'Tag,
-- Interface_T => Iface'Tag,
-- Is_Constant => True,
-- Offset_Value => n,
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
-- Initialize secondary tags
else
- Append_To (Stmts_List,
+ Append_To (Init_Tags_List,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
-- --
-- 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- --
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
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 --
-----------------------------
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
-- 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
(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
-- 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;
---------------------------------------
-- 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);
-- --
-- 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- --
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 --
-----------------------
-- --
-- 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- --
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 --
-----------------------
-- --
-- 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- --
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 --
-----------------------
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
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);
-- 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;
with System.Tasking.Queuing;
with System.Tasking.Utilities;
with System.Parameters;
-with System.Traces;
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
-- 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
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;
--------------------------------------
-- 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;
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).
-- 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;
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;
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;
-- --
-- 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- --
-- 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;
package body System.Tasking.Protected_Objects is
use System.Task_Primitives.Operations;
- use System.Traces;
----------------
-- Local Data --
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;
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;
Unlock (Object.L'Access);
- if Parameters.Runtime_Traces then
- Send_Trace_Info (PO_Unlock);
- end if;
end Unlock;
begin
with System.Tasking.Debug;
with System.Restrictions;
with System.Parameters;
-with System.Traces.Tasking;
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
-- 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);
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;
--------------------
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'));
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;
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.
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;
-- 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
-- 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;
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);
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 =>
"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);
Initialization.Undefer_Abort (Self_Id);
- if Parameters.Runtime_Traces then
- Send_Trace_Info (E_Missed, Acceptor);
- end if;
-
raise Tasking_Error;
end if;
-- 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;
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;
(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;
Initialization.Undefer_Abort (Self_Id);
- if Parameters.Runtime_Traces then
- Send_Trace_Info (E_Missed, Acceptor);
- end if;
raise Tasking_Error;
end if;
-- --
-- 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- --
with System.Secondary_Stack;
with System.Restrictions;
with System.Standard_Library;
-with System.Traces.Tasking;
with System.Stack_Usage;
with System.Storage_Elements;
use Task_Primitives.Operations;
use Task_Info;
- use System.Traces;
- use System.Traces.Tasking;
-
-----------------------
-- Local Subprograms --
-----------------------
-- ??? Why do we need to allow for nested deferral here?
- if Runtime_Traces then
- Send_Trace_Info (T_Activate);
- end if;
end Complete_Activation;
---------------------
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));
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.
-- --
-- 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- --
with System.Tasking.Initialization;
with System.Tasking.Queuing;
with System.Parameters;
-with System.Traces.Tasking;
package body System.Tasking.Utilities is
use Task_Primitives;
use Task_Primitives.Operations;
- use System.Traces;
- use System.Traces.Tasking;
-
--------------------
-- Abort_One_Task --
--------------------
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
-- --
-- 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- --
with System.Tasking.Utilities;
with System.Tasking.Debug;
with System.Parameters;
-with System.Traces.Tasking;
with System.Restrictions;
with System.Tasking.Initialization;
use System.Restrictions;
use System.Restrictions.Rident;
- use System.Traces;
- use System.Traces.Tasking;
-----------------------
-- Local Subprograms --
-- 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;
--------------------
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'));
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;
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);
-- 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;
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;
projects / gcc.git / commitdiff