Commit 10b93b2e by Hristian Kirtchev Committed by Arnaud Charlet

a-tags.adb (IW_Membership): Give support to "Iface_CW_Typ in T'Class".

2005-09-01  Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* a-tags.adb (IW_Membership): Give support to
	"Iface_CW_Typ in T'Class". For this purpose the functionality of this
	subprogram has been extended to look for the tag in the ancestors tag
	table.
	Update the structure of the GNAT Dispatch Table to reflect the
	additional two tables used in dispatching selects.
	Introduce appropriate array types and record components in
	Type_Specific_Data to reflect the two tables.
	(Get_Entry_Index, Set_Entry_Index): Retrieve and set the entry index in
	the TSD of a tag, indexed by position.
	(Get_Prim_Op_Kind, Set_Prim_Op_Kind): Retrieve and set the primitive
	operation kind in the TSD of a tag, indexed by position.

	* a-tags.ads: Introduce an enumeration type to capture different
	primitive operation kinds. Define a constant reflecting the number of
	predefined primitive operations.
	(Get_Entry_Index, Set_Entry_Index): Set and retrieve the entry index
	of an entry wrapper.
	(Get_Prim_Op_Kind, Set_Prim_Op_Kind): Set and retrieve the kind of
	callable entity of a primitive operation.

	* exp_ch3.adb (Freeze_Record_Type): Generate the declarations of the
	primitive operations used in dispatching selects for limited
	interfaces, limited tagged, task and protected types what implement a
	limited interface.
	(Freeze_Type): Generate the bodies of the primitive operations used in
	dispatching selects for limited tagged, task and protected types that
	implement a limited interface. Generate statements to populate the two
	auxiliary tables used for dispatching in select statements.
	(Freeze_Record_Type): Add call to initialize the dispatch table entries
	associated with predefined interface primitive operations.
	(Build_Dcheck_Function): Change Set_Subtype_Mark to
	Set_Result_Definition.
	(Build_Variant_Record_Equality): Change Subtype_Mark to
	Result_Definition.
	(Freeze_Enumeration_Type): Change Subtype_Mark to Result_Definition.
	(Predef_Spec_Or_Body): Change Subtype_Mark to Result_Definition.
	(Build_Assignment): Simplify the code that adds the run-time-check.
	(Expand_N_Object_Declaration): Code cleanup.

	* exp_ch7.adb (Make_Clean): Select the appropriate type for locking
	entries when there is a protected type that implements a limited
	interface.

	* exp_ch9.adb: Add package Select_Expansion_Utilities that contains
	common routines used in expansion of dispatching selects.
	(Add_Private_Declarations): Select the appropriate protection type when
	there is a protected type that implements a limited interface.
	(Build_Parameter_Block): Generate a wrapped parameter block.
	(Build_Protected_Subprogram_Body): Select the appropriate type for
	locking entries when there is a protected type that implements a
	limited interface.
	(Build_Wrapper_Spec): Set the flag and wrapped entity for procedures
	classified as entry wrappers.
	(Expand_N_Asynchronous_Select): Add support for expansion of dispatching
	asynchronous selects.
	(Expand_N_Conditional_Entry_Call): Add support for expansion of
	dispatching conditional selects.
	(Expand_N_Protected_Type_Declaration): Select the appropriate type for
	protection when there is a protected type that implements limited
	interfaces.
	(Expand_N_Timed_Entry_Call): Add support for expansion of dispatching
	timed selects.
	(Extract_Dispatching_Call): Extract the entity of the name of a
	dispatching call, the object parameter, actual parameters and
	corresponding formals.
	(Make_Initialize_Protection): Correct logic of protection initialization
	when there is a protected type that implements a limited interface.
	(Parameter_Block_Pack): Populate a wrapped parameter block with the
	values of actual parameters.
	(Parameter_Block_Unpack): Retrieve the values from a wrapped parameter
	block and assign them to the original actual parameters.

	* exp_ch9.ads (Subprogram_Protection_Mode): New type.
	(Build_Protected_Sub_Specification): Change the type and name of the
	last formal to account for the increased variety of protection modes.

	* einfo.ads, einfo.adb (Was_Hidden): New attribute. Present in all
	entities. Used to save the value of the Is_Hidden attribute when the
	limited-view is installed.
	(Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Retrieve and change
	the attribute of procedures classified as entry wrappers.
	(Wrapped_Entity, Set_Wrapped_Entity): Retrieve and change the wrapped
	entity of a primitive wrapper.
	(Write_Entity_Flags): Output the name and value of the
	Is_Primitive_Wrapper attribute.
	(Write_Field27_Name): Output the name and entity of the field Wrapped_
	Entity.
	(Underlying_Type): If we have an incomplete entity that comes from
	the limited view then we return the Underlying_Type of its non-limited
	view if it is already available.
	(Abstract_Interface_Alias): Flag applies to all subrogram kinds,
	including operators.
	(Write_Field26_Name): Add entry for Overridden_Operation
	(Overridden_Operation): New attribute of functions and procedures.

	* exp_disp.ads, exp_disp.adb (Default_Prim_Op_Position): Return a
	predefined position in the dispatch table for the primitive operations
	used in dispatching selects.
	(Init_Predefined_Interface_Primitives): Remove the hardcoded number of
	predefined primitive operations and replace it with
	Default_Prim_Op_Count.
	(Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec,
	Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Update
	the names of the generated primitive operations used in dispatching
	selects.
	(Init_Predefined_Interface_Primitives): No need to inherit primitives in
	case of abstract interface types. They will be inherit by the objects
	implementing the interface.
	(Make_DT): There is no need to inherit the dispatch table of the
	ancestor interface for the elaboration of abstract interface types.
	The dispatch table will be inherited by the object implementing the
	interface.
	(Copy_Secondary_DTs): Add documentation.
	(Validate_Position): Improve this static check in case of
	aliased subprograms because aliased subprograms must have
	the same position.
	(Init_Predefined_Interface_Primitives): New subprogram that initializes
	the entries associated with predefined primitives of all the secondary
	dispatch tables.
	(Build_Anonymous_Access_Type): Removed.
	(Expand_Interface_Actuals): With the previous cleanup there is no need
	to build an anonymous access type. This allows further cleanup in the
	code generated by the expander.
	(Expand_Interface_Conversion): If the actual is an access type then
	build an internal function to handle the displacement. If the actual
	is null this function returns null because no displacement is
	required; otherwise performs a type conversion that will be
	expanded in the code that returns the value of the displaced actual.
	(Expand_Interface_Actuals): Avoid the generation of unnecessary type
	conversions that have no effect in the generated code because no
	displacement is required. Code cleanup; use local variables to
	avoid repeated calls to the subprogram directly_designated_type().

	* exp_util.ads, exp_util.adb (Is_Predefined_Dispatching_Operation):
	Classify the primitive operations used in dispatching selects as
	predefined.
	(Implements_Limited_Interface): Determine whether some type either
	directly implements a limited interface or extends a type that
	implements a limited interface.
	(Build_Task_Image_Function): Change Subtype_Mark to Result_Definition.
	(Expand_Subtype_From_Expr): Do not build actual subtype if the
	expression is limited.
	(Find_Interface_Tag): Add code to handle class-wide types and
	entities from the limited-view.

	* rtsfind.ads: Add entries in RE_Id and RE_Unit_Table for
	Get_Entry_Index, Get_Prim_Op_Kind, POK_Function, POK_Procedure,
	POK_Protected_Entry, POK_Protected_Function, POK_Protected_Procedure,
	POK_Task_Entry, POK_Task_Procedure, Prim_Op_Kind, Set_Entry_Index,
	Set_Prim_Op_Kind.

	* sem_ch9.adb (Analyze_Triggering_Alternative): Check for legal type
	of procedure name or prefix that appears as a trigger in a triggering
	alternative.

	* uintp.ads: Introduce constants Uint_11 and Uint_13.

From-SVN: r103850
parent 630d30e9
...@@ -65,18 +65,35 @@ package body Ada.Tags is ...@@ -65,18 +65,35 @@ package body Ada.Tags is
-- | tags | -- | tags |
-- +-------------------+ -- +-------------------+
-- | table of | -- | table of |
-- | interface | -- : interface :
-- | tags | -- | tags |
-- +-------------------+ -- +-------------------+
-- | table of |
-- : primitive op :
-- | kinds |
-- +-------------------+
-- | table of |
-- : entry :
-- | indices |
-- +-------------------+
subtype Cstring is String (Positive); subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring; type Cstring_Ptr is access all Cstring;
-- We suppress index checks because the declared size in the record below
-- is a dummy size of one (see below).
type Tag_Table is array (Natural range <>) of Tag; type Tag_Table is array (Natural range <>) of Tag;
pragma Suppress_Initialization (Tag_Table); pragma Suppress_Initialization (Tag_Table);
pragma Suppress (Index_Check, On => Tag_Table); pragma Suppress (Index_Check, On => Tag_Table);
-- We suppress index checks because the declared size in the record below
-- is a dummy size of one (see below). type Prim_Op_Kind_Table is array (Natural range <>) of Prim_Op_Kind;
pragma Suppress_Initialization (Prim_Op_Kind_Table);
pragma Suppress (Index_Check, On => Prim_Op_Kind_Table);
type Entry_Index_Table is array (Natural range <>) of Positive;
pragma Suppress_Initialization (Entry_Index_Table);
pragma Suppress (Index_Check, On => Entry_Index_Table);
type Type_Specific_Data is record type Type_Specific_Data is record
Idepth : Natural; Idepth : Natural;
...@@ -121,6 +138,16 @@ package body Ada.Tags is ...@@ -121,6 +138,16 @@ package body Ada.Tags is
-- purpose we are using the same mechanism as for the Prims_Ptr array in -- purpose we are using the same mechanism as for the Prims_Ptr array in
-- the Dispatch_Table record. See comments below on Prims_Ptr for -- the Dispatch_Table record. See comments below on Prims_Ptr for
-- further details. -- further details.
POK_Table : Prim_Op_Kind_Table (1 .. 1);
Ent_Index_Table : Entry_Index_Table (1 .. 1);
-- Two auxiliary tables used for dispatching in asynchronous,
-- conditional and timed selects. Their size depends on the number
-- of primitive operations. Indexing in these two tables is performed
-- by subtracting the number of predefined primitive operations from
-- the given index value. POK_Table contains the callable entity kinds
-- of all non-predefined primitive operations. Ent_Index_Table contains
-- the entry index of primitive entry wrappers.
end record; end record;
type Dispatch_Table is record type Dispatch_Table is record
...@@ -242,15 +269,12 @@ package body Ada.Tags is ...@@ -242,15 +269,12 @@ package body Ada.Tags is
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
J : Integer := 1; J : Integer := 1;
begin begin
loop loop
if Str1 (J) /= Str2 (J) then if Str1 (J) /= Str2 (J) then
return False; return False;
elsif Str1 (J) = ASCII.NUL then elsif Str1 (J) = ASCII.NUL then
return True; return True;
else else
J := J + 1; J := J + 1;
end if; end if;
...@@ -331,21 +355,26 @@ package body Ada.Tags is ...@@ -331,21 +355,26 @@ package body Ada.Tags is
function IW_Membership function IW_Membership
(This : System.Address; (This : System.Address;
Iface_Tag : Tag) return Boolean T : Tag) return Boolean
is is
T : constant Tag := To_Tag_Ptr (This).all; Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Obj_Base : constant System.Address := This - Offset_To_Top (T); Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT);
T_Base : constant Tag := To_Tag_Ptr (Obj_Base).all; Obj_DT : constant Tag := To_Tag_Ptr (Obj_Base).all;
Obj_TSD : constant Type_Specific_Data_Ptr := TSD (T_Base); Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT);
Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces; Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
Id : Natural; Id : Natural;
begin begin
if Obj_TSD.Num_Interfaces > 0 then if Obj_TSD.Num_Interfaces > 0 then
Id := Obj_TSD.Idepth + 1;
-- Traverse the ancestor tags table plus the interface tags table.
-- The former part is required to give support to:
-- Iface_CW in Typ'Class
Id := 0;
loop loop
if Obj_TSD.Tags_Table (Id) = Iface_Tag then if Obj_TSD.Tags_Table (Id) = T then
return True; return True;
end if; end if;
...@@ -413,6 +442,17 @@ package body Ada.Tags is ...@@ -413,6 +442,17 @@ package body Ada.Tags is
return TSD (T).Access_Level; return TSD (T).Access_Level;
end Get_Access_Level; end Get_Access_Level;
---------------------
-- Get_Entry_Index --
---------------------
function Get_Entry_Index
(T : Tag;
Position : Positive) return Positive is
begin
return TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count);
end Get_Entry_Index;
---------------------- ----------------------
-- Get_External_Tag -- -- Get_External_Tag --
---------------------- ----------------------
...@@ -433,6 +473,17 @@ package body Ada.Tags is ...@@ -433,6 +473,17 @@ package body Ada.Tags is
return T.Prims_Ptr (Position); return T.Prims_Ptr (Position);
end Get_Prim_Op_Address; end Get_Prim_Op_Address;
----------------------
-- Get_Prim_Op_Kind --
----------------------
function Get_Prim_Op_Kind
(T : Tag;
Position : Positive) return Prim_Op_Kind is
begin
return TSD (T).POK_Table (Position - Default_Prim_Op_Count);
end Get_Prim_Op_Kind;
------------------- -------------------
-- Get_RC_Offset -- -- Get_RC_Offset --
------------------- -------------------
...@@ -485,8 +536,8 @@ package body Ada.Tags is ...@@ -485,8 +536,8 @@ package body Ada.Tags is
-- of the parent -- of the parent
New_TSD_Ptr.Tags_Table New_TSD_Ptr.Tags_Table
(1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
:= Old_TSD_Ptr.Tags_Table Old_TSD_Ptr.Tags_Table
(0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces); (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
else else
New_TSD_Ptr.Idepth := 0; New_TSD_Ptr.Idepth := 0;
...@@ -588,8 +639,8 @@ package body Ada.Tags is ...@@ -588,8 +639,8 @@ package body Ada.Tags is
-- The tag of the parent type through the dispatch table -- The tag of the parent type through the dispatch table
F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1)); F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
-- Access to the _size primitive of the parent. We assume that -- Access to the _size primitive of the parent. We assume that it is
-- it is always in the first slot of the dispatch table -- always in the first slot of the dispatch table
begin begin
-- Here we compute the size of the _parent field of the object -- Here we compute the size of the _parent field of the object
...@@ -672,6 +723,18 @@ package body Ada.Tags is ...@@ -672,6 +723,18 @@ package body Ada.Tags is
TSD (T).Access_Level := Value; TSD (T).Access_Level := Value;
end Set_Access_Level; end Set_Access_Level;
---------------------
-- Set_Entry_Index --
---------------------
procedure Set_Entry_Index
(T : Tag;
Position : Positive;
Value : Positive) is
begin
TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count) := Value;
end Set_Entry_Index;
----------------------- -----------------------
-- Set_Expanded_Name -- -- Set_Expanded_Name --
----------------------- -----------------------
...@@ -718,6 +781,18 @@ package body Ada.Tags is ...@@ -718,6 +781,18 @@ package body Ada.Tags is
T.Prims_Ptr (Position) := Value; T.Prims_Ptr (Position) := Value;
end Set_Prim_Op_Address; end Set_Prim_Op_Address;
----------------------
-- Set_Prim_Op_Kind --
----------------------
procedure Set_Prim_Op_Kind
(T : Tag;
Position : Positive;
Value : Prim_Op_Kind) is
begin
TSD (T).POK_Table (Position - Default_Prim_Op_Count) := Value;
end Set_Prim_Op_Kind;
------------------- -------------------
-- Set_RC_Offset -- -- Set_RC_Offset --
------------------- -------------------
......
...@@ -40,11 +40,8 @@ with System.Storage_Elements; ...@@ -40,11 +40,8 @@ with System.Storage_Elements;
with Unchecked_Conversion; with Unchecked_Conversion;
package Ada.Tags is package Ada.Tags is
pragma Preelaborate_05 (Tags); pragma Preelaborate_05;
-- In accordance with Ada 2005 AI-362 -- In accordance with Ada 2005 AI-362
pragma Elaborate_Body;
-- We need a dummy body to solve bootstrap path issues (why ???)
type Tag is private; type Tag is private;
...@@ -101,6 +98,29 @@ private ...@@ -101,6 +98,29 @@ private
type Type_Specific_Data; type Type_Specific_Data;
type Type_Specific_Data_Ptr is access all Type_Specific_Data; type Type_Specific_Data_Ptr is access all Type_Specific_Data;
-- Primitive operation kinds. These values differentiate the kinds of
-- callable entities stored in the dispatch table. Certain kinds may
-- not be used, but are added for completeness.
type Prim_Op_Kind is
(POK_Function,
POK_Procedure,
POK_Protected_Entry,
POK_Protected_Function,
POK_Protected_Procedure,
POK_Task_Entry,
POK_Task_Procedure);
-- Number of predefined primitive operations added by the Expander
-- for a tagged type. It is utilized for indexing in the two auxiliary
-- tables used for dispatching asynchronous, conditional and timed
-- selects. In order to be space efficien, indexing is performed by
-- subtracting this constant value from the provided position in the
-- auxiliary tables.
-- This value is mirrored from Exp_Disp.ads.
Default_Prim_Op_Count : constant Positive := 14;
package SSE renames System.Storage_Elements; package SSE renames System.Storage_Elements;
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
...@@ -109,14 +129,30 @@ private ...@@ -109,14 +129,30 @@ private
function IW_Membership function IW_Membership
(This : System.Address; (This : System.Address;
Iface_Tag : Tag) return Boolean; T : Tag) return Boolean;
-- Ada 2005 (AI-251): Given the tag of an object and the tag associated -- Ada 2005 (AI-251): General routine that checks if a given object
-- with an interface, return true if Obj is in Iface'Class. -- implements a tagged type. Its common usage is to check if Obj is in
-- Iface'Class, but it is also used to check if a class-wide interface
-- implements a given type (Iface_CW_Typ in T'Class). For example:
--
-- type I is interface;
-- type T is tagged ...
--
-- function Test (O : in I'Class) is
-- begin
-- return O in T'Class.
-- end Test;
function Get_Access_Level (T : Tag) return Natural; function Get_Access_Level (T : Tag) return Natural;
-- Given the tag associated with a type, returns the accessibility level -- Given the tag associated with a type, returns the accessibility level
-- of the type. -- of the type.
function Get_Entry_Index
(T : Tag;
Position : Positive) return Positive;
-- Return a primitive operation's entry index (if entry) given a dispatch
-- table T and a position of a primitive operation in T.
function Get_External_Tag (T : Tag) return System.Address; function Get_External_Tag (T : Tag) return System.Address;
-- Retrieve the address of a null terminated string containing -- Retrieve the address of a null terminated string containing
-- the external name -- the external name
...@@ -124,10 +160,16 @@ private ...@@ -124,10 +160,16 @@ private
function Get_Prim_Op_Address function Get_Prim_Op_Address
(T : Tag; (T : Tag;
Position : Positive) return System.Address; Position : Positive) return System.Address;
-- Given a pointer to a dispatch Table (T) and a position in the DT -- Given a pointer to a dispatch table (T) and a position in the DT
-- this function returns the address of the virtual function stored -- this function returns the address of the virtual function stored
-- in it (used for dispatching calls) -- in it (used for dispatching calls)
function Get_Prim_Op_Kind
(T : Tag;
Position : Positive) return Prim_Op_Kind;
-- Return a primitive operation's kind given a dispatch table T and a
-- position of a primitive operation in T.
function Get_RC_Offset (T : Tag) return SSE.Storage_Offset; function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
-- Return the Offset of the implicit record controller when the object -- Return the Offset of the implicit record controller when the object
-- has controlled components. O otherwise. -- has controlled components. O otherwise.
...@@ -173,6 +215,13 @@ private ...@@ -173,6 +215,13 @@ private
-- Insert the Tag and its associated external_tag in a table for the -- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag -- sake of Internal_Tag
procedure Set_Entry_Index
(T : Tag;
Position : Positive;
Value : Positive);
-- Set the entry index of a primitive operation in T's TSD table indexed
-- by Position.
procedure Set_Offset_To_Top procedure Set_Offset_To_Top
(T : Tag; (T : Tag;
Value : System.Storage_Elements.Storage_Offset); Value : System.Storage_Elements.Storage_Offset);
...@@ -185,13 +234,20 @@ private ...@@ -185,13 +234,20 @@ private
(T : Tag; (T : Tag;
Position : Positive; Position : Positive;
Value : System.Address); Value : System.Address);
-- Given a pointer to a dispatch Table (T) and a position in the -- Given a pointer to a dispatch Table (T) and a position in the dispatch
-- dispatch Table put the address of the virtual function in it -- Table put the address of the virtual function in it (used for
-- (used for overriding) -- overriding).
procedure Set_Prim_Op_Kind
(T : Tag;
Position : Positive;
Value : Prim_Op_Kind);
-- Set the kind of a primitive operation in T's TSD table indexed by
-- Position.
procedure Set_TSD (T : Tag; Value : System.Address); procedure Set_TSD (T : Tag; Value : System.Address);
-- Given a pointer T to a dispatch Table, stores the address of the record -- Given a pointer T to a dispatch Table, stores the address of the record
-- containing the Type Specific Data generated by GNAT -- containing the Type Specific Data generated by GNAT.
procedure Set_Access_Level (T : Tag; Value : Natural); procedure Set_Access_Level (T : Tag; Value : Natural);
-- Sets the accessibility level of the tagged type associated with T -- Sets the accessibility level of the tagged type associated with T
...@@ -199,11 +255,11 @@ private ...@@ -199,11 +255,11 @@ private
procedure Set_Expanded_Name (T : Tag; Value : System.Address); procedure Set_Expanded_Name (T : Tag; Value : System.Address);
-- Set the address of the string containing the expanded name -- Set the address of the string containing the expanded name
-- in the Dispatch table -- in the Dispatch table.
procedure Set_External_Tag (T : Tag; Value : System.Address); procedure Set_External_Tag (T : Tag; Value : System.Address);
-- Set the address of the string containing the external tag -- Set the address of the string containing the external tag
-- in the Dispatch table -- in the Dispatch table.
procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset); procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
-- Sets the Offset of the implicit record controller when the object -- Sets the Offset of the implicit record controller when the object
......
...@@ -215,9 +215,9 @@ package body Einfo is ...@@ -215,9 +215,9 @@ package body Einfo is
-- Abstract_Interface_Alias Node25 -- Abstract_Interface_Alias Node25
-- (unused) Node26 -- Overridden_Operation Node26
-- (unused) Node27 -- Wrapped_Entity Node27
--------------------------------------------- ---------------------------------------------
-- Usage of Flags in Defining Entity Nodes -- -- Usage of Flags in Defining Entity Nodes --
...@@ -442,9 +442,9 @@ package body Einfo is ...@@ -442,9 +442,9 @@ package body Einfo is
-- Has_Specified_Stream_Read Flag192 -- Has_Specified_Stream_Read Flag192
-- Has_Specified_Stream_Write Flag193 -- Has_Specified_Stream_Write Flag193
-- Is_Local_Anonymous_Access Flag194 -- Is_Local_Anonymous_Access Flag194
-- Is_Primitive_Wrapper Flag195
-- Was_Hidden Flag196
-- (unused) Flag195
-- (unused) Flag196
-- (unused) Flag197 -- (unused) Flag197
-- (unused) Flag198 -- (unused) Flag198
-- (unused) Flag199 -- (unused) Flag199
...@@ -512,8 +512,7 @@ package body Einfo is ...@@ -512,8 +512,7 @@ package body Einfo is
function Abstract_Interface_Alias (Id : E) return E is function Abstract_Interface_Alias (Id : E) return E is
begin begin
pragma Assert pragma Assert (Is_Subprogram (Id));
(Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
return Node25 (Id); return Node25 (Id);
end Abstract_Interface_Alias; end Abstract_Interface_Alias;
...@@ -1734,6 +1733,12 @@ package body Einfo is ...@@ -1734,6 +1733,12 @@ package body Einfo is
return Flag59 (Id); return Flag59 (Id);
end Is_Preelaborated; end Is_Preelaborated;
function Is_Primitive_Wrapper (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Procedure);
return Flag195 (Id);
end Is_Primitive_Wrapper;
function Is_Private_Composite (Id : E) return B is function Is_Private_Composite (Id : E) return B is
begin begin
pragma Assert (Is_Type (Id)); pragma Assert (Is_Type (Id));
...@@ -2038,6 +2043,11 @@ package body Einfo is ...@@ -2038,6 +2043,11 @@ package body Einfo is
return Node22 (Id); return Node22 (Id);
end Original_Record_Component; end Original_Record_Component;
function Overridden_Operation (Id : E) return E is
begin
return Node26 (Id);
end Overridden_Operation;
function Packed_Array_Type (Id : E) return E is function Packed_Array_Type (Id : E) return E is
begin begin
pragma Assert (Is_Array_Type (Id)); pragma Assert (Is_Array_Type (Id));
...@@ -2325,6 +2335,18 @@ package body Einfo is ...@@ -2325,6 +2335,18 @@ package body Einfo is
return Flag96 (Id); return Flag96 (Id);
end Warnings_Off; end Warnings_Off;
function Wrapped_Entity (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Procedure
and then Is_Primitive_Wrapper (Id));
return Node27 (Id);
end Wrapped_Entity;
function Was_Hidden (Id : E) return B is
begin
return Flag196 (Id);
end Was_Hidden;
------------------------------ ------------------------------
-- Classification Functions -- -- Classification Functions --
------------------------------ ------------------------------
...@@ -3799,6 +3821,12 @@ package body Einfo is ...@@ -3799,6 +3821,12 @@ package body Einfo is
Set_Flag59 (Id, V); Set_Flag59 (Id, V);
end Set_Is_Preelaborated; end Set_Is_Preelaborated;
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
Set_Flag195 (Id, V);
end Set_Is_Primitive_Wrapper;
procedure Set_Is_Private_Composite (Id : E; V : B := True) is procedure Set_Is_Private_Composite (Id : E; V : B := True) is
begin begin
pragma Assert (Is_Type (Id)); pragma Assert (Is_Type (Id));
...@@ -4107,6 +4135,11 @@ package body Einfo is ...@@ -4107,6 +4135,11 @@ package body Einfo is
Set_Node22 (Id, V); Set_Node22 (Id, V);
end Set_Original_Record_Component; end Set_Original_Record_Component;
procedure Set_Overridden_Operation (Id : E; V : E) is
begin
Set_Node26 (Id, V);
end Set_Overridden_Operation;
procedure Set_Packed_Array_Type (Id : E; V : E) is procedure Set_Packed_Array_Type (Id : E; V : E) is
begin begin
pragma Assert (Is_Array_Type (Id)); pragma Assert (Is_Array_Type (Id));
...@@ -4400,6 +4433,18 @@ package body Einfo is ...@@ -4400,6 +4433,18 @@ package body Einfo is
Set_Flag96 (Id, V); Set_Flag96 (Id, V);
end Set_Warnings_Off; end Set_Warnings_Off;
procedure Set_Was_Hidden (Id : E; V : B := True) is
begin
Set_Flag196 (Id, V);
end Set_Was_Hidden;
procedure Set_Wrapped_Entity (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Procedure
and then Is_Primitive_Wrapper (Id));
Set_Node27 (Id, V);
end Set_Wrapped_Entity;
----------------------------------- -----------------------------------
-- Field Initialization Routines -- -- Field Initialization Routines --
----------------------------------- -----------------------------------
...@@ -6328,6 +6373,15 @@ package body Einfo is ...@@ -6328,6 +6373,15 @@ package body Einfo is
return Underlying_Type (Full_View (Id)); return Underlying_Type (Full_View (Id));
end if; end if;
-- If we have an incomplete entity that comes from the limited
-- view then we return the Underlying_Type of its non-limited
-- view.
elsif From_With_Type (Id)
and then Present (Non_Limited_View (Id))
then
return Underlying_Type (Non_Limited_View (Id));
-- Otherwise check for the case where we have a derived type or -- Otherwise check for the case where we have a derived type or
-- subtype, and if so get the Underlying_Type of the parent type. -- subtype, and if so get the Underlying_Type of the parent type.
...@@ -6538,6 +6592,7 @@ package body Einfo is ...@@ -6538,6 +6592,7 @@ package body Einfo is
W ("Is_Packed_Array_Type", Flag138 (Id)); W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id)); W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id)); W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive_Wrapper", Flag195 (Id));
W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Public", Flag10 (Id)); W ("Is_Public", Flag10 (Id));
...@@ -6589,6 +6644,7 @@ package body Einfo is ...@@ -6589,6 +6644,7 @@ package body Einfo is
W ("Uses_Sec_Stack", Flag95 (Id)); W ("Uses_Sec_Stack", Flag95 (Id));
W ("Vax_Float", Flag151 (Id)); W ("Vax_Float", Flag151 (Id));
W ("Warnings_Off", Flag96 (Id)); W ("Warnings_Off", Flag96 (Id));
W ("Was_Hidden", Flag196 (Id));
end Write_Entity_Flags; end Write_Entity_Flags;
----------------------- -----------------------
...@@ -7504,6 +7560,10 @@ package body Einfo is ...@@ -7504,6 +7560,10 @@ package body Einfo is
procedure Write_Field26_Name (Id : Entity_Id) is procedure Write_Field26_Name (Id : Entity_Id) is
begin begin
case Ekind (Id) is case Ekind (Id) is
when E_Procedure |
E_Function =>
Write_Str ("Overridden_Operation");
when others => when others =>
Write_Str ("Field26??"); Write_Str ("Field26??");
end case; end case;
...@@ -7516,6 +7576,9 @@ package body Einfo is ...@@ -7516,6 +7576,9 @@ package body Einfo is
procedure Write_Field27_Name (Id : Entity_Id) is procedure Write_Field27_Name (Id : Entity_Id) is
begin begin
case Ekind (Id) is case Ekind (Id) is
when E_Procedure =>
Write_Str ("Wrapped_Entity");
when others => when others =>
Write_Str ("Field27??"); Write_Str ("Field27??");
end case; end case;
......
...@@ -183,7 +183,7 @@ package Einfo is ...@@ -183,7 +183,7 @@ package Einfo is
-- dynamic bounds, it is assumed that the value can range down or up -- dynamic bounds, it is assumed that the value can range down or up
-- to the corresponding bound of the ancestor -- to the corresponding bound of the ancestor
-- The RM defined attribute Size corresponds to the Value_Size attribute. -- The RM defined attribute Size corresponds to the Value_Size attribute
-- The Size attribute may be defined for a first-named subtype. This sets -- The Size attribute may be defined for a first-named subtype. This sets
-- the Value_Size of the first-named subtype to the given value, and the -- the Value_Size of the first-named subtype to the given value, and the
...@@ -2243,6 +2243,11 @@ package Einfo is ...@@ -2243,6 +2243,11 @@ package Einfo is
-- flag is set does not necesarily mean that no elaboration code is -- flag is set does not necesarily mean that no elaboration code is
-- generated for the package. -- generated for the package.
-- Is_Primitive_Wrapper (Flag195)
-- Present in E_Procedures. Primitive wrappers are Expander-generated
-- procedures that wrap entries of protected or task types implementing
-- a limited interface.
-- Is_Private_Composite (Flag107) -- Is_Private_Composite (Flag107)
-- Present in composite types that have a private component. Used to -- Present in composite types that have a private component. Used to
-- enforce the rule that operations on the composite type that depend -- enforce the rule that operations on the composite type that depend
...@@ -2769,6 +2774,10 @@ package Einfo is ...@@ -2769,6 +2774,10 @@ package Einfo is
-- In subtypes (tagged and untagged): -- In subtypes (tagged and untagged):
-- Points to the component in the base type. -- Points to the component in the base type.
-- Overridden_Operation (Node26)
-- Present in subprograms. For overriding operations, points to the
-- user-defined parent subprogram that is being overridden.
-- Packed_Array_Type (Node23) -- Packed_Array_Type (Node23)
-- Present in array types and subtypes, including the string literal -- Present in array types and subtypes, including the string literal
-- subtype case, if the corresponding type is packed (either bit packed -- subtype case, if the corresponding type is packed (either bit packed
...@@ -3220,6 +3229,14 @@ package Einfo is ...@@ -3220,6 +3229,14 @@ package Einfo is
-- is used to suppress warnings for a given entity. It is also used by -- is used to suppress warnings for a given entity. It is also used by
-- the compiler in some situations to kill spurious warnings. -- the compiler in some situations to kill spurious warnings.
-- Was_Hidden (Flag196)
-- Present in all entities. Used to save the value of the Is_Hidden
-- attribute when the limited-view is installed (Ada 2005: AI-217).
-- Wrapped_Entity (Node27)
-- Present in an E_Procedure classified as a Is_Primitive_Wrapper. Set
-- to the entity that is being wrapped.
------------------ ------------------
-- Access Kinds -- -- Access Kinds --
------------------ ------------------
...@@ -3488,7 +3505,7 @@ package Einfo is ...@@ -3488,7 +3505,7 @@ package Einfo is
-- A record type, created by a record type declaration -- A record type, created by a record type declaration
E_Record_Subtype, E_Record_Subtype,
-- A record subtype, created by a record subtype declaration. -- A record subtype, created by a record subtype declaration
E_Record_Type_With_Private, E_Record_Type_With_Private,
-- Used for types defined by a private extension declaration, and -- Used for types defined by a private extension declaration, and
...@@ -3499,7 +3516,7 @@ package Einfo is ...@@ -3499,7 +3516,7 @@ package Einfo is
-- a private type. -- a private type.
E_Record_Subtype_With_Private, E_Record_Subtype_With_Private,
-- A subtype of a type defined by a private extension declaration. -- A subtype of a type defined by a private extension declaration
E_Private_Type, E_Private_Type,
-- A private type, created by a private type declaration -- A private type, created by a private type declaration
...@@ -4033,6 +4050,7 @@ package Einfo is ...@@ -4033,6 +4050,7 @@ package Einfo is
-- Is_Packed_Array_Type (Flag138) -- Is_Packed_Array_Type (Flag138)
-- Is_Potentially_Use_Visible (Flag9) -- Is_Potentially_Use_Visible (Flag9)
-- Is_Preelaborated (Flag59) -- Is_Preelaborated (Flag59)
-- Is_Primitive_Wrapper (Flag195)
-- Is_Public (Flag10) -- Is_Public (Flag10)
-- Is_Pure (Flag44) -- Is_Pure (Flag44)
-- Is_Remote_Call_Interface (Flag62) -- Is_Remote_Call_Interface (Flag62)
...@@ -4050,6 +4068,7 @@ package Einfo is ...@@ -4050,6 +4068,7 @@ package Einfo is
-- Referenced_As_LHS (Flag36) -- Referenced_As_LHS (Flag36)
-- Suppress_Elaboration_Warnings (Flag148) -- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165) -- Suppress_Style_Checks (Flag165)
-- Was_Hidden (Flag196)
-- Declaration_Node (synth) -- Declaration_Node (synth)
-- Enclosing_Dynamic_Scope (synth) -- Enclosing_Dynamic_Scope (synth)
...@@ -4401,6 +4420,7 @@ package Einfo is ...@@ -4401,6 +4420,7 @@ package Einfo is
-- Privals_Chain (Elist23) (for a protected function) -- Privals_Chain (Elist23) (for a protected function)
-- Obsolescent_Warning (Node24) -- Obsolescent_Warning (Node24)
-- Abstract_Interface_Alias (Node25) -- Abstract_Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Body_Needed_For_SAL (Flag40) -- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174) -- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169) -- Function_Returns_With_DSP (Flag169)
...@@ -4648,6 +4668,9 @@ package Einfo is ...@@ -4648,6 +4668,9 @@ package Einfo is
-- Privals_Chain (Elist23) (for a protected procedure) -- Privals_Chain (Elist23) (for a protected procedure)
-- Obsolescent_Warning (Node24) -- Obsolescent_Warning (Node24)
-- Abstract_Interface_Alias (Node25) -- Abstract_Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Body_Needed_For_SAL (Flag40) -- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174) -- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169) (always False for procedure) -- Function_Returns_With_DSP (Flag169) (always False for procedure)
...@@ -4673,6 +4696,8 @@ package Einfo is ...@@ -4673,6 +4696,8 @@ package Einfo is
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178) -- Is_Null_Init_Proc (Flag178)
-- Is_Overriding_Operation (Flag39) (non-generic case only) -- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53) -- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44) -- Is_Pure (Flag44)
-- Is_Thread_Body (Flag77) (non-generic case only) -- Is_Thread_Body (Flag77) (non-generic case only)
...@@ -5299,6 +5324,8 @@ package Einfo is ...@@ -5299,6 +5324,8 @@ package Einfo is
function Is_Packed_Array_Type (Id : E) return B; function Is_Packed_Array_Type (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B; function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Preelaborated (Id : E) return B; function Is_Preelaborated (Id : E) return B;
function Is_Primitive_Wrapper (Id : E) return B;
function Is_Private_Composite (Id : E) return B; function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B; function Is_Private_Descendant (Id : E) return B;
function Is_Public (Id : E) return B; function Is_Public (Id : E) return B;
...@@ -5351,6 +5378,7 @@ package Einfo is ...@@ -5351,6 +5378,7 @@ package Einfo is
function Original_Access_Type (Id : E) return E; function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E; function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E; function Original_Record_Component (Id : E) return E;
function Overridden_Operation (Id : E) return E;
function Packed_Array_Type (Id : E) return E; function Packed_Array_Type (Id : E) return E;
function Parent_Subtype (Id : E) return E; function Parent_Subtype (Id : E) return E;
function Primitive_Operations (Id : E) return L; function Primitive_Operations (Id : E) return L;
...@@ -5402,6 +5430,8 @@ package Einfo is ...@@ -5402,6 +5430,8 @@ package Einfo is
function Uses_Sec_Stack (Id : E) return B; function Uses_Sec_Stack (Id : E) return B;
function Vax_Float (Id : E) return B; function Vax_Float (Id : E) return B;
function Warnings_Off (Id : E) return B; function Warnings_Off (Id : E) return B;
function Was_Hidden (Id : E) return B;
function Wrapped_Entity (Id : E) return E;
------------------------------- -------------------------------
-- Classification Attributes -- -- Classification Attributes --
...@@ -5792,6 +5822,8 @@ package Einfo is ...@@ -5792,6 +5822,8 @@ package Einfo is
procedure Set_Is_Packed_Array_Type (Id : E; V : B := True); procedure Set_Is_Packed_Array_Type (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True); procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True);
...@@ -5843,6 +5875,7 @@ package Einfo is ...@@ -5843,6 +5875,7 @@ package Einfo is
procedure Set_Original_Access_Type (Id : E; V : E); procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E); procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E); procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Overridden_Operation (Id : E; V : E);
procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Packed_Array_Type (Id : E; V : E);
procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E);
procedure Set_Primitive_Operations (Id : E; V : L); procedure Set_Primitive_Operations (Id : E; V : L);
...@@ -5894,6 +5927,8 @@ package Einfo is ...@@ -5894,6 +5927,8 @@ package Einfo is
procedure Set_Uses_Sec_Stack (Id : E; V : B := True); procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
procedure Set_Vax_Float (Id : E; V : B := True); procedure Set_Vax_Float (Id : E; V : B := True);
procedure Set_Warnings_Off (Id : E; V : B := True); procedure Set_Warnings_Off (Id : E; V : B := True);
procedure Set_Was_Hidden (Id : E; V : B := True);
procedure Set_Wrapped_Entity (Id : E; V : E);
----------------------------------- -----------------------------------
-- Field Initialization Routines -- -- Field Initialization Routines --
...@@ -6360,6 +6395,8 @@ package Einfo is ...@@ -6360,6 +6395,8 @@ package Einfo is
pragma Inline (Is_Packed_Array_Type); pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Potentially_Use_Visible); pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Preelaborated); pragma Inline (Is_Preelaborated);
pragma Inline (Is_Primitive_Wrapper);
pragma Inline (Is_Private_Composite); pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Type); pragma Inline (Is_Private_Type);
...@@ -6421,6 +6458,7 @@ package Einfo is ...@@ -6421,6 +6458,7 @@ package Einfo is
pragma Inline (Original_Access_Type); pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type); pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component); pragma Inline (Original_Record_Component);
pragma Inline (Overridden_Operation);
pragma Inline (Packed_Array_Type); pragma Inline (Packed_Array_Type);
pragma Inline (Parameter_Mode); pragma Inline (Parameter_Mode);
pragma Inline (Parent_Subtype); pragma Inline (Parent_Subtype);
...@@ -6473,6 +6511,8 @@ package Einfo is ...@@ -6473,6 +6511,8 @@ package Einfo is
pragma Inline (Uses_Sec_Stack); pragma Inline (Uses_Sec_Stack);
pragma Inline (Vax_Float); pragma Inline (Vax_Float);
pragma Inline (Warnings_Off); pragma Inline (Warnings_Off);
pragma Inline (Was_Hidden);
pragma Inline (Wrapped_Entity);
pragma Inline (Init_Alignment); pragma Inline (Init_Alignment);
pragma Inline (Init_Component_Bit_Offset); pragma Inline (Init_Component_Bit_Offset);
...@@ -6692,6 +6732,8 @@ package Einfo is ...@@ -6692,6 +6732,8 @@ package Einfo is
pragma Inline (Set_Is_Packed_Array_Type); pragma Inline (Set_Is_Packed_Array_Type);
pragma Inline (Set_Is_Potentially_Use_Visible); pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Preelaborated); pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Primitive_Wrapper);
pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Public);
...@@ -6743,6 +6785,7 @@ package Einfo is ...@@ -6743,6 +6785,7 @@ package Einfo is
pragma Inline (Set_Original_Access_Type); pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component); pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overridden_Operation);
pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Packed_Array_Type);
pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Parent_Subtype);
pragma Inline (Set_Primitive_Operations); pragma Inline (Set_Primitive_Operations);
...@@ -6794,6 +6837,8 @@ package Einfo is ...@@ -6794,6 +6837,8 @@ package Einfo is
pragma Inline (Set_Uses_Sec_Stack); pragma Inline (Set_Uses_Sec_Stack);
pragma Inline (Set_Vax_Float); pragma Inline (Set_Vax_Float);
pragma Inline (Set_Warnings_Off); pragma Inline (Set_Warnings_Off);
pragma Inline (Set_Was_Hidden);
pragma Inline (Set_Wrapped_Entity);
-- END XEINFO INLINES -- END XEINFO INLINES
......
...@@ -27,7 +27,6 @@ ...@@ -27,7 +27,6 @@
with Atree; use Atree; with Atree; use Atree;
with Checks; use Checks; with Checks; use Checks;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr; with Exp_Aggr; use Exp_Aggr;
with Exp_Ch4; use Exp_Ch4; with Exp_Ch4; use Exp_Ch4;
...@@ -867,7 +866,7 @@ package body Exp_Ch3 is ...@@ -867,7 +866,7 @@ package body Exp_Ch3 is
Parameter_List := Build_Discriminant_Formals (Rec_Id, False); Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
Set_Parameter_Specifications (Spec_Node, Parameter_List); Set_Parameter_Specifications (Spec_Node, Parameter_List);
Set_Subtype_Mark (Spec_Node, Set_Result_Definition (Spec_Node,
New_Reference_To (Standard_Boolean, Loc)); New_Reference_To (Standard_Boolean, Loc));
Set_Specification (Body_Node, Spec_Node); Set_Specification (Body_Node, Spec_Node);
Set_Declarations (Body_Node, New_List); Set_Declarations (Body_Node, New_List);
...@@ -1482,16 +1481,21 @@ package body Exp_Ch3 is ...@@ -1482,16 +1481,21 @@ package body Exp_Ch3 is
Attribute_Name => Name_Unrestricted_Access); Attribute_Name => Name_Unrestricted_Access);
end if; end if;
-- Ada 2005 (AI-231): Generate conversion to the null-excluding -- Ada 2005 (AI-231): Add the run-time check if required
-- type to force the corresponding run-time check.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Can_Never_Be_Null (Etype (Id)) -- Lhs and then Can_Never_Be_Null (Etype (Id)) -- Lhs
and then Present (Etype (Exp)) then
if Nkind (Exp) = N_Null then
return New_List (
Make_Raise_Constraint_Error (Sloc (Exp),
Reason => CE_Null_Not_Allowed));
elsif Present (Etype (Exp))
and then not Can_Never_Be_Null (Etype (Exp)) and then not Can_Never_Be_Null (Etype (Exp))
then then
Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp))); Install_Null_Excluding_Check (Exp);
Analyze_And_Resolve (Exp, Etype (Id)); end if;
end if; end if;
-- Take a copy of Exp to ensure that later copies of this -- Take a copy of Exp to ensure that later copies of this
...@@ -3017,7 +3021,7 @@ package body Exp_Ch3 is ...@@ -3017,7 +3021,7 @@ package body Exp_Ch3 is
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => F, Defining_Unit_Name => F,
Parameter_Specifications => Pspecs, Parameter_Specifications => Pspecs,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List, Declarations => New_List,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
...@@ -3698,19 +3702,6 @@ package body Exp_Ch3 is ...@@ -3698,19 +3702,6 @@ package body Exp_Ch3 is
elsif Is_Access_Type (Typ) then elsif Is_Access_Type (Typ) then
-- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check
if Ada_Version >= Ada_05
and then (Can_Never_Be_Null (Def_Id)
or else Can_Never_Be_Null (Typ))
then
Rewrite
(Expr_Q,
Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q)));
Analyze_And_Resolve (Expr_Q, Etype (Def_Id));
end if;
-- For access types set the Is_Known_Non_Null flag if the -- For access types set the Is_Known_Non_Null flag if the
-- initializing value is known to be non-null. We can also set -- initializing value is known to be non-null. We can also set
-- Can_Never_Be_Null if this is a constant. -- Can_Never_Be_Null if this is a constant.
...@@ -4362,7 +4353,7 @@ package body Exp_Ch3 is ...@@ -4362,7 +4353,7 @@ package body Exp_Ch3 is
Make_Defining_Identifier (Loc, Name_uF), Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), Parameter_Type => New_Reference_To (Standard_Boolean, Loc))),
Subtype_Mark => New_Reference_To (Standard_Integer, Loc)), Result_Definition => New_Reference_To (Standard_Integer, Loc)),
Declarations => Empty_List, Declarations => Empty_List,
...@@ -4392,10 +4383,10 @@ package body Exp_Ch3 is ...@@ -4392,10 +4383,10 @@ package body Exp_Ch3 is
------------------------ ------------------------
procedure Freeze_Record_Type (N : Node_Id) is procedure Freeze_Record_Type (N : Node_Id) is
Def_Id : constant Node_Id := Entity (N);
Comp : Entity_Id; Comp : Entity_Id;
Type_Decl : constant Node_Id := Parent (Def_Id); Def_Id : constant Node_Id := Entity (N);
Predef_List : List_Id; Predef_List : List_Id;
Type_Decl : constant Node_Id := Parent (Def_Id);
Renamed_Eq : Node_Id := Empty; Renamed_Eq : Node_Id := Empty;
-- Could use some comments ??? -- Could use some comments ???
...@@ -4534,6 +4525,7 @@ package body Exp_Ch3 is ...@@ -4534,6 +4525,7 @@ package body Exp_Ch3 is
Make_Predefined_Primitive_Specs Make_Predefined_Primitive_Specs
(Def_Id, Predef_List, Renamed_Eq); (Def_Id, Predef_List, Renamed_Eq);
Insert_List_Before_And_Analyze (N, Predef_List); Insert_List_Before_And_Analyze (N, Predef_List);
Set_Is_Frozen (Def_Id, True); Set_Is_Frozen (Def_Id, True);
Set_All_DT_Position (Def_Id); Set_All_DT_Position (Def_Id);
...@@ -4623,6 +4615,8 @@ package body Exp_Ch3 is ...@@ -4623,6 +4615,8 @@ package body Exp_Ch3 is
Append_Freeze_Actions Append_Freeze_Actions
(Def_Id, Predefined_Primitive_Freeze (Def_Id)); (Def_Id, Predefined_Primitive_Freeze (Def_Id));
Append_Freeze_Actions
(Def_Id, Init_Predefined_Interface_Primitives (Def_Id));
end if; end if;
-- In the non-tagged case, an equality function is provided only for -- In the non-tagged case, an equality function is provided only for
...@@ -4696,8 +4690,20 @@ package body Exp_Ch3 is ...@@ -4696,8 +4690,20 @@ package body Exp_Ch3 is
if Is_Tagged_Type (Def_Id) then if Is_Tagged_Type (Def_Id) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
Append_Freeze_Actions (Def_Id, Predef_List); Append_Freeze_Actions (Def_Id, Predef_List);
end if;
-- Populate the two auxiliary tables used for dispatching
-- asynchronous, conditional and timed selects for tagged
-- types that implement a limited interface.
if Ada_Version >= Ada_05
and then not Is_Interface (Def_Id)
and then not Is_Abstract (Def_Id)
and then not Is_Controlled (Def_Id)
and then Implements_Limited_Interface (Def_Id)
then
Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id));
end if;
end if;
end Freeze_Record_Type; end Freeze_Record_Type;
------------------------------ ------------------------------
...@@ -5887,6 +5893,67 @@ package body Exp_Ch3 is ...@@ -5887,6 +5893,67 @@ package body Exp_Ch3 is
Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); Parameter_Type => New_Reference_To (Tag_Typ, Loc)))));
end if; end if;
-- Generate the declarations for the following primitive operations:
-- disp_asynchronous_select
-- disp_conditional_select
-- disp_get_prim_op_kind
-- disp_timed_select
-- for limited interfaces and tagged types that implement a limited
-- interface.
if Ada_Version >= Ada_05
and then
((Is_Interface (Tag_Typ)
and then Is_Limited_Record (Tag_Typ))
or else
(not Is_Abstract (Tag_Typ)
and then not Is_Controlled (Tag_Typ)
and then Implements_Limited_Interface (Tag_Typ)))
then
if Is_Interface (Tag_Typ) then
Append_To (Res,
Make_Abstract_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Abstract_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Conditional_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Abstract_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
Append_To (Res,
Make_Abstract_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Timed_Select_Spec (Tag_Typ)));
else
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Conditional_Select_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
Append_To (Res,
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Disp_Timed_Select_Spec (Tag_Typ)));
end if;
end if;
-- Specs for finalization actions that may be required in case a -- Specs for finalization actions that may be required in case a
-- future extension contain a controlled element. We generate those -- future extension contain a controlled element. We generate those
-- only for root tagged types where they will get dummy bodies or -- only for root tagged types where they will get dummy bodies or
...@@ -6059,7 +6126,7 @@ package body Exp_Ch3 is ...@@ -6059,7 +6126,7 @@ package body Exp_Ch3 is
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => Id, Defining_Unit_Name => Id,
Parameter_Specifications => Profile, Parameter_Specifications => Profile,
Subtype_Mark => Result_Definition =>
New_Reference_To (Ret_Type, Loc)); New_Reference_To (Ret_Type, Loc));
end if; end if;
...@@ -6242,6 +6309,29 @@ package body Exp_Ch3 is ...@@ -6242,6 +6309,29 @@ package body Exp_Ch3 is
end if; end if;
end if; end if;
-- Generate the bodies for the following primitive operations:
-- disp_asynchronous_select
-- disp_conditional_select
-- disp_get_prim_op_kind
-- disp_timed_select
-- for tagged types that implement a limited interface.
if Ada_Version >= Ada_05
and then not Is_Interface (Tag_Typ)
and then not Is_Abstract (Tag_Typ)
and then not Is_Controlled (Tag_Typ)
and then Implements_Limited_Interface (Tag_Typ)
then
Append_To (Res,
Make_Disp_Asynchronous_Select_Body (Tag_Typ));
Append_To (Res,
Make_Disp_Conditional_Select_Body (Tag_Typ));
Append_To (Res,
Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ));
Append_To (Res,
Make_Disp_Timed_Select_Body (Tag_Typ));
end if;
if not Is_Limited_Type (Tag_Typ) then if not Is_Limited_Type (Tag_Typ) then
-- Body for equality -- Body for equality
......
...@@ -1560,19 +1560,6 @@ package body Exp_Ch7 is ...@@ -1560,19 +1560,6 @@ package body Exp_Ch7 is
end if; end if;
Set_Elaboration_Flag (N, Corresponding_Spec (N)); Set_Elaboration_Flag (N, Corresponding_Spec (N));
-- Generate a subprogram descriptor for the elaboration routine of
-- a package body if the package body has no pending instantiations
-- and it has generated at least one exception handler
if Present (Handler_Records (Body_Entity (Ent)))
and then Is_Compilation_Unit (Ent)
and then not Delay_Subprogram_Descriptors (Body_Entity (Ent))
then
Generate_Subprogram_Descriptor_For_Package
(N, Body_Entity (Ent));
end if;
Set_In_Package_Body (Ent, False); Set_In_Package_Body (Ent, False);
-- Set to encode entity names in package body before gigi is called -- Set to encode entity names in package body before gigi is called
...@@ -2220,6 +2207,8 @@ package body Exp_Ch7 is ...@@ -2220,6 +2207,8 @@ package body Exp_Ch7 is
or else Has_Interrupt_Handler (Pid) or else Has_Interrupt_Handler (Pid)
or else (Has_Attach_Handler (Pid) or else (Has_Attach_Handler (Pid)
and then not Restricted_Profile) and then not Restricted_Profile)
or else (Ada_Version >= Ada_05
and then Present (Interface_List (Parent (Pid))))
then then
if Abort_Allowed if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False or else Restriction_Active (No_Entry_Queue) = False
......
...@@ -57,11 +57,261 @@ with Snames; use Snames; ...@@ -57,11 +57,261 @@ with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Targparm; use Targparm; with Targparm; use Targparm;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Types; use Types;
with Uintp; use Uintp; with Uintp; use Uintp;
package body Exp_Ch9 is package body Exp_Ch9 is
--------------------------------
-- Select_Expansion_Utilities --
--------------------------------
-- The following package contains helper routines used in the expansion of
-- dispatching asynchronous, conditional and timed selects.
package Select_Expansion_Utilities is
function Build_Abort_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Blk : Node_Id) return Node_Id;
-- Generate:
-- begin
-- Blk
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- Blk_Ent is the name of the encapsulated block, Blk is the actual
-- block node.
function Build_B
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id;
-- Generate:
-- B : Boolean := False;
-- Append the object declaration to the list and return the name of
-- the object.
function Build_C
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id;
-- Generate:
-- C : Ada.Tags.Prim_Op_Kind;
-- Append the object declaration to the list and return the name of
-- the object.
function Build_Cleanup_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Stmts : List_Id;
Clean_Ent : Entity_Id) return Node_Id;
-- Generate:
-- declare
-- procedure _clean is
-- begin
-- ...
-- end _clean;
-- begin
-- Stmts
-- at end
-- _clean;
-- end;
-- Blk_Ent is the name of the generated block, Stmts is the list
-- of encapsulated statements and Clean_Ent is the parameter to
-- the _clean procedure.
function Build_S
(Loc : Source_Ptr;
Decls : List_Id;
Call_Ent : Entity_Id) return Entity_Id;
-- Generate:
-- S : constant Integer := DT_Position (Call_Ent);
-- where Call_Ent is the entity of the dispatching call name. Append
-- the object declaration to the list and return the name of the
-- object.
function Build_Wrapping_Procedure
(Loc : Source_Ptr;
Nam : Character;
Decls : List_Id;
Stmts : List_Id) return Entity_Id;
-- Generate:
-- procedure <temp>Nam is
-- begin
-- Stmts
-- end <temp>Nam;
-- where Nam is the generated procedure name and Stmts are the
-- encapsulated statements. Append the procedure body to Decls.
-- Return the internally generated procedure name.
end Select_Expansion_Utilities;
package body Select_Expansion_Utilities is
-----------------------
-- Build_Abort_Block --
-----------------------
function Build_Abort_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Blk : Node_Id) return Node_Id
is
begin
return
Make_Block_Statement (Loc,
Declarations =>
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
New_List (
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier =>
Blk_Ent,
Label_Construct =>
Blk),
Blk),
Exception_Handlers =>
New_List (
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (
New_Reference_To (Stand.Abort_Signal, Loc)),
Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (
RE_Abort_Undefer), Loc),
Parameter_Associations => No_List))))));
end Build_Abort_Block;
-------------
-- Build_B --
-------------
function Build_B
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
B,
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc),
Expression =>
New_Reference_To (Standard_False, Loc)));
return B;
end Build_B;
-------------
-- Build_C --
-------------
function Build_C
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id
is
C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
C,
Object_Definition =>
New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
return C;
end Build_C;
-------------------------
-- Build_Cleanup_Block --
-------------------------
function Build_Cleanup_Block
(Loc : Source_Ptr;
Blk_Ent : Entity_Id;
Stmts : List_Id;
Clean_Ent : Entity_Id) return Node_Id
is
Cleanup_Block : constant Node_Id :=
Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blk_Ent, Loc),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts),
Is_Asynchronous_Call_Block => True);
begin
Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
return Cleanup_Block;
end Build_Cleanup_Block;
-------------
-- Build_S --
-------------
function Build_S
(Loc : Source_Ptr;
Decls : List_Id;
Call_Ent : Entity_Id) return Entity_Id
is
S : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uS);
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => S,
Constant_Present => True,
Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
Expression =>
Make_Integer_Literal (Loc,
Intval => DT_Position (Call_Ent))));
return S;
end Build_S;
------------------------------
-- Build_Wrapping_Procedure --
------------------------------
function Build_Wrapping_Procedure
(Loc : Source_Ptr;
Nam : Character;
Decls : List_Id;
Stmts : List_Id) return Entity_Id
is
Proc_Nam : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name (Nam));
begin
Append_To (Decls,
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Proc_Nam),
Declarations =>
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
New_Copy_List (Stmts))));
return Proc_Nam;
end Build_Wrapping_Procedure;
end Select_Expansion_Utilities;
package SEU renames Select_Expansion_Utilities;
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
...@@ -76,17 +326,6 @@ package body Exp_Ch9 is ...@@ -76,17 +326,6 @@ package body Exp_Ch9 is
-- the expression computed by this function uses the discriminants -- the expression computed by this function uses the discriminants
-- of the target task. -- of the target task.
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
Prot : Entity_Id) return List_Id;
-- For an entry family and its barrier function, we define a local entity
-- that maps the index in the call into the entry index into the object:
--
-- I : constant Index_Type := Index_Type'Val (
-- E - <<index of first family member>> +
-- Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
procedure Add_Object_Pointer procedure Add_Object_Pointer
(Decls : List_Id; (Decls : List_Id;
Pid : Entity_Id; Pid : Entity_Id;
...@@ -131,6 +370,23 @@ package body Exp_Ch9 is ...@@ -131,6 +370,23 @@ package body Exp_Ch9 is
-- of the range of each entry family. A single array with that size is -- of the range of each entry family. A single array with that size is
-- allocated for each concurrent object of the type. -- allocated for each concurrent object of the type.
function Build_Parameter_Block
(Loc : Source_Ptr;
Actuals : List_Id;
Formals : List_Id;
Decls : List_Id) return Entity_Id;
-- Generate an access type for each actual parameter in the list Actuals.
-- Cleate an encapsulating record that contains all the actuals and return
-- its type. Generate:
-- type Ann1 is access all <actual1-type>
-- ...
-- type AnnN is access all <actualN-type>
-- type Pnn is record
-- <formal1> : Ann1;
-- ...
-- <formalN> : AnnN;
-- end record;
function Build_Wrapper_Body function Build_Wrapper_Body
(Loc : Source_Ptr; (Loc : Source_Ptr;
Proc_Nam : Entity_Id; Proc_Nam : Entity_Id;
...@@ -272,6 +528,16 @@ package body Exp_Ch9 is ...@@ -272,6 +528,16 @@ package body Exp_Ch9 is
-- to the use of 'Length on the index type, but must use Family_Offset -- to the use of 'Length on the index type, but must use Family_Offset
-- to handle properly the case of bounds that depend on discriminants. -- to handle properly the case of bounds that depend on discriminants.
procedure Extract_Dispatching_Call
(N : Node_Id;
Call_Ent : out Entity_Id;
Object : out Entity_Id;
Actuals : out List_Id;
Formals : out List_Id);
-- Given a dispatching call, extract the entity of the name of the call,
-- its object parameter, its actual parameters and the formal parameters
-- of the overriden interface-level version.
procedure Extract_Entry procedure Extract_Entry
(N : Node_Id; (N : Node_Id;
Concval : out Node_Id; Concval : out Node_Id;
...@@ -289,6 +555,47 @@ package body Exp_Ch9 is ...@@ -289,6 +555,47 @@ package body Exp_Ch9 is
-- when P is Name_uPriority, the call will also find Interrupt_Priority. -- when P is Name_uPriority, the call will also find Interrupt_Priority.
-- ??? Should be implemented with the rep item chain mechanism. -- ??? Should be implemented with the rep item chain mechanism.
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
Prot : Entity_Id) return List_Id;
-- For an entry family and its barrier function, we define a local entity
-- that maps the index in the call into the entry index into the object:
--
-- I : constant Index_Type := Index_Type'Val (
-- E - <<index of first family member>> +
-- Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
function Parameter_Block_Pack
(Loc : Source_Ptr;
Blk_Typ : Entity_Id;
Actuals : List_Id;
Formals : List_Id;
Decls : List_Id;
Stmts : List_Id) return Node_Id;
-- Set the components of the generated parameter block with the values of
-- the actual parameters. Generate aliased temporaries to capture the
-- values for types that are passed by copy. Otherwise generate a reference
-- to the actual's value. Return the address of the aggregate block.
-- Generate:
-- Jnn1 : alias <formal-type1>;
-- Jnn1 := <actual1>;
-- ...
-- P : Blk_Typ := (
-- Jnn1'unchecked_access;
-- <actual2>'reference;
-- ...);
function Parameter_Block_Unpack
(Loc : Source_Ptr;
Actuals : List_Id;
Formals : List_Id) return List_Id;
-- Retrieve the values of the components from the parameter block and
-- assign then to the original actual parameters. Generate:
-- <actual1> := P.<formal1>;
-- ...
-- <actualN> := P.<formalN>;
procedure Update_Prival_Subtypes (N : Node_Id); procedure Update_Prival_Subtypes (N : Node_Id);
-- The actual subtypes of the privals will differ from the type of the -- The actual subtypes of the privals will differ from the type of the
-- private declaration in the original protected type, if the protected -- private declaration in the original protected type, if the protected
...@@ -579,7 +886,13 @@ package body Exp_Ch9 is ...@@ -579,7 +886,13 @@ package body Exp_Ch9 is
elsif Has_Interrupt_Handler (Typ) then elsif Has_Interrupt_Handler (Typ) then
Protection_Type := RE_Dynamic_Interrupt_Protection; Protection_Type := RE_Dynamic_Interrupt_Protection;
elsif Has_Entries (Typ) then -- The type has explicit entries or generated primitive entry
-- wrappers.
elsif Has_Entries (Typ)
or else (Ada_Version >= Ada_05
and then Present (Interface_List (Parent (Typ))))
then
if Abort_Allowed if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Typ) > 1 or else Number_Entries (Typ) > 1
...@@ -836,7 +1149,7 @@ package body Exp_Ch9 is ...@@ -836,7 +1149,7 @@ package body Exp_Ch9 is
Parameter_Type => Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)); Result_Definition => New_Reference_To (Standard_Boolean, Loc));
end Build_Barrier_Function_Specification; end Build_Barrier_Function_Specification;
-------------------------- --------------------------
...@@ -998,9 +1311,92 @@ package body Exp_Ch9 is ...@@ -998,9 +1311,92 @@ package body Exp_Ch9 is
return Ecount; return Ecount;
end Build_Entry_Count_Expression; end Build_Entry_Count_Expression;
------------------------------ ---------------------------
-- Build_Parameter_Block --
---------------------------
function Build_Parameter_Block
(Loc : Source_Ptr;
Actuals : List_Id;
Formals : List_Id;
Decls : List_Id) return Entity_Id
is
Actual : Entity_Id;
Comp_Nam : Node_Id;
Comp_Rec : Node_Id;
Comps : List_Id;
Formal : Entity_Id;
begin
Actual := First (Actuals);
Comps := New_List;
Formal := Defining_Identifier (First (Formals));
while Present (Actual) loop
-- Generate:
-- type Ann is access all <actual-type>
Comp_Nam :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Append_To (Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier =>
Comp_Nam,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present =>
True,
Constant_Present =>
Ekind (Formal) = E_In_Parameter,
Subtype_Indication =>
New_Reference_To (Etype (Actual), Loc))));
-- Generate:
-- Param : Ann;
Append_To (Comps,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Formal)),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present =>
False,
Subtype_Indication =>
New_Reference_To (Comp_Nam, Loc))));
Next_Actual (Actual);
Next_Formal_With_Extras (Formal);
end loop;
-- Generate:
-- type Pnn is record
-- Param1 : Ann1;
-- ...
-- ParamN : AnnN;
-- where Pnn is a parameter wrapping record, Param1 .. ParamN are the
-- original parameter names and Ann1 .. AnnN are the access to actual
-- types.
Comp_Rec :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Append_To (Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier =>
Comp_Rec,
Type_Definition =>
Make_Record_Definition (Loc,
Component_List =>
Make_Component_List (Loc, Comps))));
return Comp_Rec;
end Build_Parameter_Block;
------------------------
-- Build_Wrapper_Body -- -- Build_Wrapper_Body --
------------------------------ ------------------------
function Build_Wrapper_Body function Build_Wrapper_Body
(Loc : Source_Ptr; (Loc : Source_Ptr;
...@@ -1371,6 +1767,9 @@ package body Exp_Ch9 is ...@@ -1371,6 +1767,9 @@ package body Exp_Ch9 is
or else Ekind (Proc_Nam) = E_Entry or else Ekind (Proc_Nam) = E_Entry
then then
Set_Ekind (New_Name_Id, E_Procedure); Set_Ekind (New_Name_Id, E_Procedure);
Set_Is_Primitive_Wrapper (New_Name_Id);
Set_Wrapped_Entity (New_Name_Id, Proc_Nam);
return return
Make_Procedure_Specification (Loc, Make_Procedure_Specification (Loc,
Defining_Unit_Name => New_Name_Id, Defining_Unit_Name => New_Name_Id,
...@@ -1378,11 +1777,13 @@ package body Exp_Ch9 is ...@@ -1378,11 +1777,13 @@ package body Exp_Ch9 is
else pragma Assert (Ekind (Proc_Nam) = E_Function); else pragma Assert (Ekind (Proc_Nam) = E_Function);
Set_Ekind (New_Name_Id, E_Function); Set_Ekind (New_Name_Id, E_Function);
return return
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => New_Name_Id, Defining_Unit_Name => New_Name_Id,
Parameter_Specifications => New_Formals, Parameter_Specifications => New_Formals,
Subtype_Mark => New_Copy (Subtype_Mark (Parent (Proc_Nam)))); Result_Definition =>
New_Copy (Result_Definition (Parent (Proc_Nam))));
end if; end if;
end Build_Wrapper_Spec; end Build_Wrapper_Spec;
...@@ -1602,7 +2003,7 @@ package body Exp_Ch9 is ...@@ -1602,7 +2003,7 @@ package body Exp_Ch9 is
Defining_Identifier => Parm2, Defining_Identifier => Parm2,
Parameter_Type => Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Subtype_Mark => New_Occurrence_Of ( Result_Definition => New_Occurrence_Of (
RTE (RE_Protected_Entry_Index), Loc)); RTE (RE_Protected_Entry_Index), Loc));
end Build_Find_Body_Index_Spec; end Build_Find_Body_Index_Spec;
...@@ -1897,7 +2298,7 @@ package body Exp_Ch9 is ...@@ -1897,7 +2298,7 @@ package body Exp_Ch9 is
function Build_Protected_Sub_Specification function Build_Protected_Sub_Specification
(N : Node_Id; (N : Node_Id;
Prottyp : Entity_Id; Prottyp : Entity_Id;
Unprotected : Boolean := False) return Node_Id Mode : Subprogram_Protection_Mode) return Node_Id
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id; Decl : Node_Id;
...@@ -1906,9 +2307,13 @@ package body Exp_Ch9 is ...@@ -1906,9 +2307,13 @@ package body Exp_Ch9 is
Nam : Name_Id; Nam : Name_Id;
New_Id : Entity_Id; New_Id : Entity_Id;
New_Plist : List_Id; New_Plist : List_Id;
Append_Char : Character;
New_Spec : Node_Id; New_Spec : Node_Id;
Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
(Dispatching_Mode => ' ',
Protected_Mode => 'P',
Unprotected_Mode => 'N');
begin begin
if Ekind if Ekind
(Defining_Unit_Name (Specification (N))) = E_Subprogram_Body (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
...@@ -1921,26 +2326,14 @@ package body Exp_Ch9 is ...@@ -1921,26 +2326,14 @@ package body Exp_Ch9 is
Ident := Defining_Unit_Name (Specification (Decl)); Ident := Defining_Unit_Name (Specification (Decl));
Nam := Chars (Ident); Nam := Chars (Ident);
New_Plist := Build_Protected_Spec New_Plist :=
(Decl, Corresponding_Record_Type (Prottyp), Build_Protected_Spec (Decl,
Unprotected, Ident); Corresponding_Record_Type (Prottyp),
Mode = Unprotected_Mode, Ident);
if Unprotected then
Append_Char := 'N';
else
-- Ada 2005 (AI-345): The protected version no longer uses 'P'
-- as suffix in order to make it a primitive operation
if Ada_Version >= Ada_05 then
Append_Char := ' ';
else
Append_Char := 'P';
end if;
end if;
New_Id := New_Id :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Protnm, Nam, Append_Char)); Chars => Build_Selected_Name (Protnm, Nam, Append_Chr (Mode)));
-- The unprotected operation carries the user code, and debugging -- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does -- information must be generated for it, even though this spec does
...@@ -1961,7 +2354,8 @@ package body Exp_Ch9 is ...@@ -1961,7 +2354,8 @@ package body Exp_Ch9 is
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => New_Id, Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist, Parameter_Specifications => New_Plist,
Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl)))); Result_Definition =>
New_Copy (Result_Definition (Specification (Decl))));
Set_Return_Present (Defining_Unit_Name (New_Spec)); Set_Return_Present (Defining_Unit_Name (New_Spec));
return New_Spec; return New_Spec;
end if; end if;
...@@ -2089,8 +2483,7 @@ package body Exp_Ch9 is ...@@ -2089,8 +2483,7 @@ package body Exp_Ch9 is
Exc_Safe := Is_Exception_Safe (N); Exc_Safe := Is_Exception_Safe (N);
P_Op_Spec := P_Op_Spec :=
Build_Protected_Sub_Specification (N, Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
Pid, Unprotected => False);
-- Build a list of the formal parameters of the protected -- Build a list of the formal parameters of the protected
-- version of the subprogram to use as the actual parameters -- version of the subprogram to use as the actual parameters
...@@ -2116,7 +2509,7 @@ package body Exp_Ch9 is ...@@ -2116,7 +2509,7 @@ package body Exp_Ch9 is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => R, Defining_Identifier => R,
Constant_Present => True, Constant_Present => True,
Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)), Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
Expression => Expression =>
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Make_Identifier (Loc, Name => Make_Identifier (Loc,
...@@ -2162,7 +2555,10 @@ package body Exp_Ch9 is ...@@ -2162,7 +2555,10 @@ package body Exp_Ch9 is
if Has_Entries (Pid) if Has_Entries (Pid)
or else Has_Interrupt_Handler (Pid) or else Has_Interrupt_Handler (Pid)
or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) or else (Has_Attach_Handler (Pid)
and then not Restricted_Profile)
or else (Ada_Version >= Ada_05
and then Present (Interface_List (Parent (Pid))))
then then
if Abort_Allowed if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False or else Restriction_Active (No_Entry_Queue) = False
...@@ -3004,8 +3400,7 @@ package body Exp_Ch9 is ...@@ -3004,8 +3400,7 @@ package body Exp_Ch9 is
Op_Decls := Declarations (N); Op_Decls := Declarations (N);
N_Op_Spec := N_Op_Spec :=
Build_Protected_Sub_Specification Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode);
(N, Pid, Unprotected => True);
return return
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
...@@ -3687,7 +4082,8 @@ package body Exp_Ch9 is ...@@ -3687,7 +4082,8 @@ package body Exp_Ch9 is
Def1 := Def1 :=
Make_Access_Function_Definition (Loc, Make_Access_Function_Definition (Loc,
Parameter_Specifications => P_List, Parameter_Specifications => P_List,
Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N)))); Result_Definition =>
New_Copy (Result_Definition (Type_Definition (N))));
else else
Def1 := Def1 :=
...@@ -4158,9 +4554,10 @@ package body Exp_Ch9 is ...@@ -4158,9 +4554,10 @@ package body Exp_Ch9 is
-- Expand_N_Asynchronous_Select -- -- Expand_N_Asynchronous_Select --
---------------------------------- ----------------------------------
-- This procedure assumes that the trigger statement is an entry call. A -- This procedure assumes that the trigger statement is an entry call or
-- delay alternative should already have been expanded into an entry call -- a dispatching procedure call. A delay alternative should already have
-- to the appropriate delay object Wait entry. -- been expanded into an entry call to the appropriate delay object Wait
-- entry.
-- If the trigger is a task entry call, the select is implemented with -- If the trigger is a task entry call, the select is implemented with
-- a Task_Entry_Call: -- a Task_Entry_Call:
...@@ -4191,19 +4588,19 @@ package body Exp_Ch9 is ...@@ -4191,19 +4588,19 @@ package body Exp_Ch9 is
-- begin -- begin
-- begin -- begin
-- Abort_Undefer; -- Abort_Undefer;
-- abortable-part -- <abortable-part>
-- at end -- at end
-- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions. -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions.
-- end; -- end;
-- exception -- exception
-- when Abort_Signal => Abort_Undefer; -- when Abort_Signal => Abort_Undefer;
-- end; -- end;
-- parm := P.param; -- parm := P.param;
-- parm := P.param; -- parm := P.param;
-- ... -- ...
-- if not C then -- if not C then
-- triggered-statements -- <triggered-statements>
-- end if; -- end if;
-- end; -- end;
...@@ -4250,20 +4647,17 @@ package body Exp_Ch9 is ...@@ -4250,20 +4647,17 @@ package body Exp_Ch9 is
-- Mode => Asynchronous_Call; -- Mode => Asynchronous_Call;
-- Block => Bnn); -- Block => Bnn);
-- if Enqueued (Bnn) then -- if Enqueued (Bnn) then
-- <abortable part> -- <abortable-part>
-- end if; -- end if;
-- at end -- at end
-- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions. -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions.
-- end; -- end;
-- exception -- exception
-- when Abort_Signal => -- when Abort_Signal => Abort_Undefer;
-- Abort_Undefer;
-- null;
-- end; -- end;
-- if not Cancelled (Bnn) then -- if not Cancelled (Bnn) then
-- triggered statements -- <triggered-statements>
-- end if; -- end if;
-- end; -- end;
...@@ -4286,52 +4680,164 @@ package body Exp_Ch9 is ...@@ -4286,52 +4680,164 @@ package body Exp_Ch9 is
-- ... -- ...
-- end; -- end;
-- The job is to convert this to the asynchronous form -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
-- expanded into:
-- If the trigger is a delay statement, it will have been expanded into a -- declare
-- call to one of the GNARL delay procedures. This routine will convert -- B : Boolean := False;
-- this into a protected entry call on a delay object and then continue -- Bnn : Communication_Block;
-- processing as for a protected entry call trigger. This requires -- C : Ada.Tags.Prim_Op_Kind;
-- declaring a Delay_Block object and adding a pointer to this object to -- P : Parameters := (Param1 .. ParamN)
-- the parameter list of the delay procedure to form the parameter list of -- S : constant Integer := DT_Position (<dispatching-call>);
-- the entry call. This object is used by the runtime to queue the delay -- U : Boolean;
-- request.
-- procedure <temp>A is
-- begin
-- <abortable-statements>
-- end <temp>A;
-- For a description of the use of P and the assignments after the -- procedure <temp>T is
-- call, see Expand_N_Entry_Call_Statement. -- begin
-- <triggered-statements>
-- end <temp>T;
-- begin
-- disp_get_prim_op_kind (<object>, S, C);
-- if C = POK_Protected_Entry then
-- declare
-- procedure _clean is
-- begin
-- if Enqueued (Bnn) then
-- Cancel_Protected_Entry_Call (Bnn);
-- end if;
-- end _clean;
-- begin
-- begin
-- disp_asynchronous_select
-- (Obj, S, P'address, Bnn, B);
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- if Enqueued (Bnn) then
-- <temp>A;
-- end if;
-- at end
-- _clean;
-- end;
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- if not Cancelled (Bnn) then
-- <temp>T;
-- end if;
-- elsif C = POK_Task_Entry then
-- declare
-- procedure _clean is
-- begin
-- Cancel_Task_Entry_Call (U);
-- end _clean;
-- begin
-- Abort_Defer;
-- disp_asynchronous_select
-- (<object>, S, P'address, Bnn, B);
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- begin
-- begin
-- Abort_Undefer;
-- <temp>A;
-- at end
-- _clean;
-- end;
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
-- if not U then
-- <temp>T;
-- end if;
-- end;
-- else
-- <dispatching-call>;
-- <temp>T;
-- end if;
-- The job is to convert this to the asynchronous form
-- If the trigger is a delay statement, it will have been expanded into a
-- call to one of the GNARL delay procedures. This routine will convert
-- this into a protected entry call on a delay object and then continue
-- processing as for a protected entry call trigger. This requires
-- declaring a Delay_Block object and adding a pointer to this object to
-- the parameter list of the delay procedure to form the parameter list of
-- the entry call. This object is used by the runtime to queue the delay
-- request.
-- For a description of the use of P and the assignments after the
-- call, see Expand_N_Entry_Call_Statement.
procedure Expand_N_Asynchronous_Select (N : Node_Id) is procedure Expand_N_Asynchronous_Select (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Trig : constant Node_Id := Triggering_Alternative (N);
Abrt : constant Node_Id := Abortable_Part (N); Abrt : constant Node_Id := Abortable_Part (N);
Tstats : constant List_Id := Statements (Trig);
Astats : constant List_Id := Statements (Abrt); Astats : constant List_Id := Statements (Abrt);
Trig : constant Node_Id := Triggering_Alternative (N);
Tstats : constant List_Id := Statements (Trig);
Ecall : Node_Id; Abortable_Block : Node_Id;
Actuals : List_Id;
Aproc : Entity_Id;
Blk_Ent : Entity_Id;
Blk_Typ : Entity_Id;
Call : Node_Id;
Call_Ent : Entity_Id;
Cancel_Param : Entity_Id;
Cleanup_Block : Node_Id;
Cleanup_Stmts : List_Id;
Concval : Node_Id; Concval : Node_Id;
Ename : Node_Id; Dblock_Ent : Entity_Id;
Index : Node_Id;
Hdle : List_Id;
Decls : List_Id;
Decl : Node_Id; Decl : Node_Id;
Parms : List_Id; Decls : List_Id;
Parm : Node_Id; Ecall : Node_Id;
Call : Node_Id; Ename : Node_Id;
Stmts : List_Id;
Enqueue_Call : Node_Id; Enqueue_Call : Node_Id;
Stmt : Node_Id; Formals : List_Id;
B : Entity_Id; Hdle : List_Id;
Pdef : Entity_Id; Index : Node_Id;
Dblock_Ent : Entity_Id;
N_Orig : Node_Id; N_Orig : Node_Id;
Abortable_Block : Node_Id; Obj : Entity_Id;
Cancel_Param : Entity_Id; Param : Node_Id;
Blkent : Entity_Id; Params : List_Id;
Pdef : Entity_Id;
ProtE_Stmts : List_Id;
ProtP_Stmts : List_Id;
Stmt : Node_Id;
Stmts : List_Id;
Target_Undefer : RE_Id; Target_Undefer : RE_Id;
TaskE_Stmts : List_Id;
Tproc : Entity_Id;
Undefer_Args : List_Id := No_List; Undefer_Args : List_Id := No_List;
B : Entity_Id; -- Call status flag
Bnn : Entity_Id; -- Communication block
C : Entity_Id; -- Call kind
P : Node_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
U : Entity_Id; -- Additional status flag
begin begin
Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Ecall := Triggering_Statement (Trig); Ecall := Triggering_Statement (Trig);
-- The arguments in the call may require dynamic allocation, and the -- The arguments in the call may require dynamic allocation, and the
...@@ -4341,7 +4847,6 @@ package body Exp_Ch9 is ...@@ -4341,7 +4847,6 @@ package body Exp_Ch9 is
if Nkind (Ecall) = N_Block_Statement then if Nkind (Ecall) = N_Block_Statement then
Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
while Nkind (Ecall) /= N_Procedure_Call_Statement while Nkind (Ecall) /= N_Procedure_Call_Statement
and then Nkind (Ecall) /= N_Entry_Call_Statement and then Nkind (Ecall) /= N_Entry_Call_Statement
loop loop
...@@ -4349,27 +4854,398 @@ package body Exp_Ch9 is ...@@ -4349,27 +4854,398 @@ package body Exp_Ch9 is
end loop; end loop;
end if; end if;
-- If a delay was used as a trigger, it will have been expanded -- This is either a dispatching call or a delay statement used as a
-- into a procedure call. Convert it to the appropriate sequence of -- trigger which was expanded into a procedure call.
-- statements, similar to what is done for a task entry call.
-- Note that this currently supports only Duration, Real_Time.Time, if Nkind (Ecall) = N_Procedure_Call_Statement then
-- and Calendar.Time. if Ada_Version >= Ada_05
and then
(not Present (Original_Node (Ecall))
or else
Nkind (Original_Node (Ecall)) /= N_Delay_Relative_Statement)
then
Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
Decls := New_List;
Stmts := New_List;
-- Call status flag processing, generate:
-- B : Boolean := False;
B := SEU.Build_B (Loc, Decls);
-- Communication block processing, generate:
-- Bnn : Communication_Block;
Bnn := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Bnn,
Object_Definition =>
New_Reference_To (RTE (RE_Communication_Block), Loc)));
-- Call kind processing, generate:
-- C : Ada.Tags.Prim_Op_Kind;
C := SEU.Build_C (Loc, Decls);
-- Parameter block processing
Blk_Typ := Build_Parameter_Block
(Loc, Actuals, Formals, Decls);
P := Parameter_Block_Pack
(Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
-- Dispatch table slot processing, generate:
-- S : constant Integer :=
-- DT_Position (<dispatching-procedure>);
S := SEU.Build_S (Loc, Decls, Call_Ent);
-- Additional status flag processing, generate:
U := Make_Defining_Identifier (Loc, Name_uU);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
U,
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc)));
-- Generate:
-- procedure <temp>A is
-- begin
-- Astmts
-- end <temp>A;
Aproc := SEU.Build_Wrapping_Procedure (Loc, 'A', Decls, Astats);
-- Generate:
-- procedure <temp>T is
-- begin
-- Tstmts
-- end <temp>T;
Tproc := SEU.Build_Wrapping_Procedure (Loc, 'T', Decls, Tstats);
-- Generate:
-- _dispatching_get_prim_op_kind (<object>, S, C);
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
New_Reference_To (S, Loc),
New_Reference_To (C, Loc))));
-- Protected entry handling
-- Generate:
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
Cleanup_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals);
-- Generate:
-- _dispatching_asynchronous_select
-- (<object>, S, P'address, Bnn, B);
Prepend_To (Cleanup_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uDisp_Asynchronous_Select),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
New_Reference_To (S, Loc),
P,
New_Reference_To (Bnn, Loc),
New_Reference_To (B, Loc))));
-- Generate:
-- if Enqueued (Bnn) then
-- <temp>A
-- end if;
-- where <temp>A is the abort statements wrapping procedure
Append_To (Cleanup_Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Enqueued), Loc),
Parameter_Associations =>
New_List (
New_Reference_To (Bnn, Loc))),
Then_Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Aproc, Loc),
Parameter_Associations =>
No_List))));
-- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
-- will then generate a _clean for the communication block Bnn.
-- Generate:
-- declare
-- procedure _clean is
-- begin
-- if Enqueued (Bnn) then
-- Cancel_Protected_Entry_Call (Bnn);
-- end if;
-- end _clean;
-- begin
-- Cleanup_Stmts
-- at end
-- _clean;
-- end;
Cleanup_Block :=
SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, Bnn);
-- Wrap the cleanup block in an exception handling block.
-- Generate:
-- begin
-- Cleanup_Block
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
ProtE_Stmts :=
New_List (
SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block));
-- Generate:
-- if not Cancelled (Bnn) then
-- <temp>T
-- end if;
-- there <temp>T is the triggering statements wrapping procedure
Append_To (ProtE_Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Cancelled), Loc),
Parameter_Associations =>
New_List (
New_Reference_To (Bnn, Loc)))),
Then_Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Tproc, Loc),
Parameter_Associations =>
No_List))));
-------------------------------------------------------------------
-- Task entry handling
-- Generate:
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
TaskE_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals);
-- Generate:
-- _dispatching_asynchronous_select
-- (<object>, S, P'address, Bnn, B);
Prepend_To (TaskE_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uDisp_Asynchronous_Select),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
New_Reference_To (S, Loc),
New_Copy_Tree (P),
New_Reference_To (Bnn, Loc),
New_Reference_To (B, Loc))));
-- Generate:
-- Abort_Defer;
Prepend_To (TaskE_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Abort_Defer), Loc),
Parameter_Associations =>
No_List));
-- Generate:
-- Abort_Undefer;
-- <temp>A
-- where <temp>A is the abortable statements wrapping procedure
Cleanup_Stmts :=
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Abort_Undefer), Loc),
Parameter_Associations =>
No_List),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Aproc, Loc),
Parameter_Associations =>
No_List));
-- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
-- will generate a _clean for the additional status flag.
-- Generate:
-- declare
-- procedure _clean is
-- begin
-- Cancel_Task_Entry_Call (U);
-- end _clean;
-- begin
-- Cleanup_Stmts
-- at end
-- _clean;
-- end;
Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Cleanup_Block :=
SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, U);
-- Wrap the cleanup block in an exception handling block
-- Generate:
-- begin
-- Cleanup_Block
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
Append_To (TaskE_Stmts,
SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block));
-- Generate:
-- if not U then
-- <temp>T
-- end if;
-- where <temp>T is the triggering statements wrapping procedure
Append_To (TaskE_Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
New_Reference_To (U, Loc)),
Then_Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Tproc, Loc),
Parameter_Associations =>
No_List))));
-------------------------------------------------------------------
-- Protected procedure handling
-- Generate:
-- <dispatching-call>;
-- <temp>T;
-- where <temp>T is the triggering statements wrapping procedure
ProtP_Stmts :=
New_List (
New_Copy_Tree (Ecall),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Tproc, Loc),
Parameter_Associations =>
No_List));
-- Generate:
-- if C = POK_Procedure_Entry then
-- ProtE_Stmts
-- elsif C = POK_Task_Entry then
-- TaskE_Stmts
-- else
-- ProtP_Stmts
-- end if;
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
Then_Statements =>
ProtE_Stmts,
Elsif_Parts =>
New_List (
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc)),
Then_Statements =>
TaskE_Stmts)),
Else_Statements =>
ProtP_Stmts));
Rewrite (N,
Make_Block_Statement (Loc,
Declarations =>
Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
if Nkind (Ecall) = N_Procedure_Call_Statement then Analyze (N);
return;
-- Delay triggering statement processing
-- Add a Delay_Block object to the parameter list of the else
-- delay procedure to form the parameter list of the Wait -- Add a Delay_Block object to the parameter list of the delay
-- entry call. -- procedure to form the parameter list of the Wait entry call.
Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); Dblock_Ent :=
Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
Pdef := Entity (Name (Ecall)); Pdef := Entity (Name (Ecall));
if Is_RTE (Pdef, RO_CA_Delay_For) then if Is_RTE (Pdef, RO_CA_Delay_For) then
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc); Enqueue_Call :=
New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
elsif Is_RTE (Pdef, RO_CA_Delay_Until) then elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc); Enqueue_Call :=
New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc); Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
...@@ -4396,7 +5272,7 @@ package body Exp_Ch9 is ...@@ -4396,7 +5272,7 @@ package body Exp_Ch9 is
Abortable_Block := Abortable_Block :=
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc), Identifier => New_Reference_To (Blk_Ent, Loc),
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => Astats), Statements => Astats),
...@@ -4416,7 +5292,7 @@ package body Exp_Ch9 is ...@@ -4416,7 +5292,7 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Make_Implicit_Label_Declaration (Loc, Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent, Defining_Identifier => Blk_Ent,
Label_Construct => Abortable_Block), Label_Construct => Abortable_Block),
Abortable_Block), Abortable_Block),
Exception_Handlers => Hdle))))); Exception_Handlers => Hdle)))));
...@@ -4438,7 +5314,7 @@ package body Exp_Ch9 is ...@@ -4438,7 +5314,7 @@ package body Exp_Ch9 is
-- The result is the new block -- The result is the new block
Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent); Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
Rewrite (N, Rewrite (N,
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
...@@ -4454,7 +5330,7 @@ package body Exp_Ch9 is ...@@ -4454,7 +5330,7 @@ package body Exp_Ch9 is
Analyze (N); Analyze (N);
return; return;
end if;
else else
N_Orig := N; N_Orig := N;
end if; end if;
...@@ -4471,9 +5347,10 @@ package body Exp_Ch9 is ...@@ -4471,9 +5347,10 @@ package body Exp_Ch9 is
Decl := First (Decls); Decl := First (Decls);
while Present (Decl) while Present (Decl)
and then (Nkind (Decl) /= N_Object_Declaration and then
or else not Is_RTE (Nkind (Decl) /= N_Object_Declaration
(Etype (Object_Definition (Decl)), RE_Communication_Block)) or else not Is_RTE (Etype (Object_Definition (Decl)),
RE_Communication_Block))
loop loop
Next (Decl); Next (Decl);
end loop; end loop;
...@@ -4481,7 +5358,8 @@ package body Exp_Ch9 is ...@@ -4481,7 +5358,8 @@ package body Exp_Ch9 is
pragma Assert (Present (Decl)); pragma Assert (Present (Decl));
Cancel_Param := Defining_Identifier (Decl); Cancel_Param := Defining_Identifier (Decl);
-- Change the mode of the Protected_Entry_Call call. -- Change the mode of the Protected_Entry_Call call
-- Protected_Entry_Call ( -- Protected_Entry_Call (
-- Object => po._object'Access, -- Object => po._object'Access,
-- E => <entry index>; -- E => <entry index>;
...@@ -4491,7 +5369,8 @@ package body Exp_Ch9 is ...@@ -4491,7 +5369,8 @@ package body Exp_Ch9 is
Stmt := First (Stmts); Stmt := First (Stmts);
-- Skip assignments to temporaries created for in-out parameters. -- Skip assignments to temporaries created for in-out parameters
-- This makes unwarranted assumptions about the shape of the expanded -- This makes unwarranted assumptions about the shape of the expanded
-- tree for the call, and should be cleaned up ??? -- tree for the call, and should be cleaned up ???
...@@ -4501,18 +5380,20 @@ package body Exp_Ch9 is ...@@ -4501,18 +5380,20 @@ package body Exp_Ch9 is
Call := Stmt; Call := Stmt;
Parm := First (Parameter_Associations (Call)); Param := First (Parameter_Associations (Call));
while Present (Parm) while Present (Param)
and then not Is_RTE (Etype (Parm), RE_Call_Modes) and then not Is_RTE (Etype (Param), RE_Call_Modes)
loop loop
Next (Parm); Next (Param);
end loop; end loop;
pragma Assert (Present (Parm)); pragma Assert (Present (Param));
Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); Rewrite (Param, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
Analyze (Parm); Analyze (Param);
-- Append an if statement to execute the abortable part
-- Append an if statement to execute the abortable part. -- Generate:
-- if Enqueued (Bnn) then -- if Enqueued (Bnn) then
Append_To (Stmts, Append_To (Stmts,
...@@ -4526,7 +5407,7 @@ package body Exp_Ch9 is ...@@ -4526,7 +5407,7 @@ package body Exp_Ch9 is
Abortable_Block := Abortable_Block :=
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc), Identifier => New_Reference_To (Blk_Ent, Loc),
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts), Statements => Stmts),
...@@ -4552,7 +5433,7 @@ package body Exp_Ch9 is ...@@ -4552,7 +5433,7 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Make_Implicit_Label_Declaration (Loc, Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent, Defining_Identifier => Blk_Ent,
Label_Construct => Abortable_Block), Label_Construct => Abortable_Block),
Abortable_Block), Abortable_Block),
...@@ -4640,7 +5521,7 @@ package body Exp_Ch9 is ...@@ -4640,7 +5521,7 @@ package body Exp_Ch9 is
Abortable_Block := Abortable_Block :=
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Identifier => New_Reference_To (Blkent, Loc), Identifier => New_Reference_To (Blk_Ent, Loc),
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => Astats), Statements => Astats),
...@@ -4653,26 +5534,32 @@ package body Exp_Ch9 is ...@@ -4653,26 +5534,32 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Make_Implicit_Label_Declaration (Loc, Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Blkent, Defining_Identifier => Blk_Ent,
Label_Construct => Abortable_Block), Label_Construct => Abortable_Block),
Abortable_Block), Abortable_Block),
Exception_Handlers => Hdle))); Exception_Handlers => Hdle)));
-- Create new call statement -- Create new call statement
Parms := Parameter_Associations (Call); Params := Parameter_Associations (Call);
Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
Append_To (Parms, New_Reference_To (B, Loc)); Append_To (Params,
New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
Append_To (Params,
New_Reference_To (B, Loc));
Rewrite (Call, Rewrite (Call,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), Name =>
Parameter_Associations => Parms)); New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations => Params));
-- Construct statement sequence for new block -- Construct statement sequence for new block
Append_To (Stmts, Append_To (Stmts,
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => Make_Op_Not (Loc, Condition =>
Make_Op_Not (Loc,
New_Reference_To (Cancel_Param, Loc)), New_Reference_To (Cancel_Param, Loc)),
Then_Statements => Tstats)); Then_Statements => Tstats));
...@@ -4684,7 +5571,7 @@ package body Exp_Ch9 is ...@@ -4684,7 +5571,7 @@ package body Exp_Ch9 is
Parameter_Associations => Empty_List)); Parameter_Associations => Empty_List));
end if; end if;
Set_Entry_Cancel_Parameter (Blkent, Cancel_Param); Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
-- The result is the new block -- The result is the new block
...@@ -4786,21 +5673,199 @@ package body Exp_Ch9 is ...@@ -4786,21 +5673,199 @@ package body Exp_Ch9 is
-- ... -- ...
-- end; -- end;
-- Ada 2005 (AI-345): A dispatching conditional entry call is converted
-- into:
-- declare
-- B : Boolean := False;
-- C : Ada.Tags.Prim_Op_Kind;
-- P : Parameters := (Param1 .. ParamN);
-- S : constant Integer := DT_Position (<dispatching-procedure>);
-- begin
-- disp_conditional_select (<object>, S, P'address, C, B);
-- if C = POK_Protected_Entry
-- or else C = POK_Task_Entry
-- then
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- end if;
-- if B then
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
-- <dispatching-procedure> (<object>, Param1 .. ParamN);
-- end if;
-- <normal-statements>
-- else
-- <else-statements>
-- end if;
-- end;
procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Alt : constant Node_Id := Entry_Call_Alternative (N); Alt : constant Node_Id := Entry_Call_Alternative (N);
Blk : Node_Id := Entry_Call_Statement (Alt); Blk : Node_Id := Entry_Call_Statement (Alt);
Transient_Blk : Node_Id; Transient_Blk : Node_Id;
Parms : List_Id; Actuals : List_Id;
Parm : Node_Id; Blk_Typ : Entity_Id;
Call : Node_Id; Call : Node_Id;
Stmts : List_Id; Call_Ent : Entity_Id;
B : Entity_Id;
Decl : Node_Id; Decl : Node_Id;
Decls : List_Id;
Formals : List_Id;
N_Stats : List_Id;
Obj : Entity_Id;
Param : Node_Id;
Params : List_Id;
Stmt : Node_Id; Stmt : Node_Id;
Stmts : List_Id;
B : Entity_Id; -- Call status flag
C : Entity_Id; -- Call kind
P : Node_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
begin begin
if Ada_Version >= Ada_05
and then Nkind (Blk) = N_Procedure_Call_Statement
then
Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
Decls := New_List;
Stmts := New_List;
-- Call status flag processing, generate:
-- B : Boolean := False;
B := SEU.Build_B (Loc, Decls);
-- Call kind processing, generate:
-- C : Ada.Tags.Prim_Op_Kind;
C := SEU.Build_C (Loc, Decls);
-- Parameter block processing
Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals,
Decls, Stmts);
-- Dispatch table slot processing, generate:
-- S : constant Integer :=
-- DT_Position (<dispatching-procedure>);
S := SEU.Build_S (Loc, Decls, Call_Ent);
-- Generate:
-- _dispatching_conditional_select (<object>, S, P'address, C, B);
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uDisp_Conditional_Select),
Parameter_Associations =>
New_List (
New_Copy_Tree (Obj),
New_Reference_To (S, Loc),
P,
New_Reference_To (C, Loc),
New_Reference_To (B, Loc))));
-- Generate:
-- if C = POK_Protected_Entry
-- or else C = POK_Task_Entry
-- then
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- end if;
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
Then_Statements =>
Parameter_Block_Unpack (Loc, Actuals, Formals)));
-- Generate:
-- if B then
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
-- <dispatching-procedure-call>
-- end if;
-- <normal-statements>
-- else
-- <else-statements>
-- end if;
N_Stats := New_Copy_List (Statements (Alt));
Prepend_To (N_Stats,
Make_If_Statement (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Procedure), Loc)),
Right_Opnd =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (
RE_POK_Protected_Procedure), Loc)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (
RE_POK_Task_Procedure), Loc)))),
Then_Statements =>
New_List (Blk)));
Append_To (Stmts,
Make_If_Statement (Loc,
Condition => New_Reference_To (B, Loc),
Then_Statements => N_Stats,
Else_Statements => Else_Statements (N)));
Rewrite (N,
Make_Block_Statement (Loc,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
-- As described above, The entry alternative is transformed into a -- As described above, The entry alternative is transformed into a
-- block that contains the gnulli call, and possibly assignment -- block that contains the gnulli call, and possibly assignment
-- statements for in-out parameters. The gnulli call may itself be -- statements for in-out parameters. The gnulli call may itself be
...@@ -4808,52 +5873,48 @@ package body Exp_Ch9 is ...@@ -4808,52 +5873,48 @@ package body Exp_Ch9 is
-- require it. We need to retrieve the call to complete its parameter -- require it. We need to retrieve the call to complete its parameter
-- list. -- list.
else
Transient_Blk := Transient_Blk :=
First_Real_Statement (Handled_Statement_Sequence (Blk)); First_Real_Statement (Handled_Statement_Sequence (Blk));
if Present (Transient_Blk) if Present (Transient_Blk)
and then and then Nkind (Transient_Blk) = N_Block_Statement
Nkind (Transient_Blk) = N_Block_Statement
then then
Blk := Transient_Blk; Blk := Transient_Blk;
end if; end if;
Stmts := Statements (Handled_Statement_Sequence (Blk)); Stmts := Statements (Handled_Statement_Sequence (Blk));
Stmt := First (Stmts); Stmt := First (Stmts);
while Nkind (Stmt) /= N_Procedure_Call_Statement loop while Nkind (Stmt) /= N_Procedure_Call_Statement loop
Next (Stmt); Next (Stmt);
end loop; end loop;
Call := Stmt; Call := Stmt;
Params := Parameter_Associations (Call);
Parms := Parameter_Associations (Call);
if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
-- Substitute Conditional_Entry_Call for Simple_Call -- Substitute Conditional_Entry_Call for Simple_Call parameter
-- parameter.
Parm := First (Parms); Param := First (Params);
while Present (Parm) while Present (Param)
and then not Is_RTE (Etype (Parm), RE_Call_Modes) and then not Is_RTE (Etype (Param), RE_Call_Modes)
loop loop
Next (Parm); Next (Param);
end loop; end loop;
pragma Assert (Present (Parm)); pragma Assert (Present (Param));
Rewrite (Parm, New_Reference_To (RTE (RE_Conditional_Call), Loc)); Rewrite (Param, New_Reference_To (RTE (RE_Conditional_Call), Loc));
Analyze (Parm); Analyze (Param);
-- Find the Communication_Block parameter for the call -- Find the Communication_Block parameter for the call to the
-- to the Cancelled function. -- Cancelled function.
Decl := First (Declarations (Blk)); Decl := First (Declarations (Blk));
while Present (Decl) while Present (Decl)
and then not and then not Is_RTE (Etype (Object_Definition (Decl)),
Is_RTE (Etype (Object_Definition (Decl)), RE_Communication_Block) RE_Communication_Block)
loop loop
Next (Decl); Next (Decl);
end loop; end loop;
...@@ -4882,17 +5943,19 @@ package body Exp_Ch9 is ...@@ -4882,17 +5943,19 @@ package body Exp_Ch9 is
Prepend_To (Declarations (Blk), Prepend_To (Declarations (Blk),
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => B, Defining_Identifier => B,
Object_Definition => New_Reference_To (Standard_Boolean, Loc))); Object_Definition =>
New_Reference_To (Standard_Boolean, Loc)));
-- Create new call statement -- Create new call statement
Append_To (Parms, New_Reference_To (RTE (RE_Conditional_Call), Loc)); Append_To (Params,
Append_To (Parms, New_Reference_To (B, Loc)); New_Reference_To (RTE (RE_Conditional_Call), Loc));
Append_To (Params, New_Reference_To (B, Loc));
Rewrite (Call, Rewrite (Call,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations => Parms)); Parameter_Associations => Params));
-- Construct statement sequence for new block -- Construct statement sequence for new block
...@@ -4901,7 +5964,6 @@ package body Exp_Ch9 is ...@@ -4901,7 +5964,6 @@ package body Exp_Ch9 is
Condition => New_Reference_To (B, Loc), Condition => New_Reference_To (B, Loc),
Then_Statements => Statements (Alt), Then_Statements => Statements (Alt),
Else_Statements => Else_Statements (N))); Else_Statements => Else_Statements (N)));
end if; end if;
-- The result is the new block -- The result is the new block
...@@ -4911,6 +5973,7 @@ package body Exp_Ch9 is ...@@ -4911,6 +5973,7 @@ package body Exp_Ch9 is
Declarations => Declarations (Blk), Declarations => Declarations (Blk),
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts))); Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
end if;
Analyze (N); Analyze (N);
end Expand_N_Conditional_Entry_Call; end Expand_N_Conditional_Entry_Call;
...@@ -4925,7 +5988,6 @@ package body Exp_Ch9 is ...@@ -4925,7 +5988,6 @@ package body Exp_Ch9 is
procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
begin begin
Rewrite (N, Rewrite (N,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
...@@ -5193,7 +6255,7 @@ package body Exp_Ch9 is ...@@ -5193,7 +6255,7 @@ package body Exp_Ch9 is
-- <sequence of statements> -- <sequence of statements>
-- end pprocN; -- end pprocN;
-- procedure pproc (_object : in out poV;...) is -- procedure pprocP (_object : in out poV;...) is
-- procedure _clean is -- procedure _clean is
-- Pn : Boolean; -- Pn : Boolean;
-- begin -- begin
...@@ -5217,7 +6279,7 @@ package body Exp_Ch9 is ...@@ -5217,7 +6279,7 @@ package body Exp_Ch9 is
-- <sequence of statements> -- <sequence of statements>
-- end pfuncN; -- end pfuncN;
-- function pfunc (_object : poV) return Return_Type is -- function pfuncP (_object : poV) return Return_Type is
-- procedure _clean is -- procedure _clean is
-- begin -- begin
-- Unlock (_object._object'Access); -- Unlock (_object._object'Access);
...@@ -5264,10 +6326,97 @@ package body Exp_Ch9 is ...@@ -5264,10 +6326,97 @@ package body Exp_Ch9 is
Op_Decl : Node_Id; Op_Decl : Node_Id;
Op_Body : Node_Id; Op_Body : Node_Id;
Op_Id : Entity_Id; Op_Id : Entity_Id;
Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id; New_Op_Body : Node_Id;
Current_Node : Node_Id; Current_Node : Node_Id;
Num_Entries : Natural := 0; Num_Entries : Natural := 0;
function Build_Dispatching_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
Prot_Bod : Node_Id) return Node_Id;
-- Build a dispatching version of the protected subprogram body. The
-- newly generated subprogram contains a call to the original protected
-- body. The following code is generated:
--
-- function <protected-function-name> (Param1 .. ParamN) return
-- <return-type> is
-- begin
-- return <protected-function-name>P (Param1 .. ParamN);
-- end <protected-function-name>;
--
-- or
--
-- procedure <protected-procedure-name> (Param1 .. ParamN) is
-- begin
-- <protected-procedure-name>P (Param1 .. ParamN);
-- end <protected-procedure-name>
---------------------------------------
-- Build_Dispatching_Subprogram_Body --
---------------------------------------
function Build_Dispatching_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
Prot_Bod : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Actuals : List_Id;
Formal : Node_Id;
Spec : Node_Id;
Stmts : List_Id;
begin
-- Generate a specification without a letter suffix in order to
-- override an interface function or procedure.
Spec :=
Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
-- The formal parameters become the actuals of the protected
-- function or procedure call.
Actuals := New_List;
Formal := First (Parameter_Specifications (Spec));
while Present (Formal) loop
Append_To (Actuals,
Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
Next (Formal);
end loop;
if Nkind (Spec) = N_Procedure_Specification then
Stmts :=
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
Parameter_Associations => Actuals));
else
pragma Assert (Nkind (Spec) = N_Function_Specification);
Stmts :=
New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
Parameter_Associations => Actuals)));
end if;
return
Make_Subprogram_Body (Loc,
Declarations => Empty_List,
Specification => Spec,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Build_Dispatching_Subprogram_Body;
-- Start of processing for Expand_N_Protected_Body
begin begin
if No_Run_Time_Mode then if No_Run_Time_Mode then
Error_Msg_CRT ("protected body", N); Error_Msg_CRT ("protected body", N);
...@@ -5340,6 +6489,26 @@ package body Exp_Ch9 is ...@@ -5340,6 +6489,26 @@ package body Exp_Ch9 is
Insert_After (Current_Node, New_Op_Body); Insert_After (Current_Node, New_Op_Body);
Analyze (New_Op_Body); Analyze (New_Op_Body);
Current_Node := New_Op_Body;
-- Generate an overriding primitive operation body for
-- this subprogram if the protected type implements
-- an inerface.
if Ada_Version >= Ada_05
and then Present (Abstract_Interfaces (
Corresponding_Record_Type (Pid)))
then
Disp_Op_Body :=
Build_Dispatching_Subprogram_Body (
Op_Body, Pid, New_Op_Body);
Insert_After (Current_Node, Disp_Op_Body);
Analyze (Disp_Op_Body);
Current_Node := Disp_Op_Body;
end if;
end if; end if;
end if; end if;
end if; end if;
...@@ -5723,7 +6892,13 @@ package body Exp_Ch9 is ...@@ -5723,7 +6892,13 @@ package body Exp_Ch9 is
Sloc => Loc, Sloc => Loc,
Constraints => New_List (Entry_Count_Expr))); Constraints => New_List (Entry_Count_Expr)));
elsif Has_Entries (Prottyp) then -- The type has explicit entries or generated primitive entry
-- wrappers.
elsif Has_Entries (Prottyp)
or else (Ada_Version >= Ada_05
and then Present (Interface_List (N)))
then
if Abort_Allowed if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (Prottyp) > 1 or else Number_Entries (Prottyp) > 1
...@@ -5795,7 +6970,7 @@ package body Exp_Ch9 is ...@@ -5795,7 +6970,7 @@ package body Exp_Ch9 is
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
Specification => Specification =>
Build_Protected_Sub_Specification Build_Protected_Sub_Specification
(Priv, Prottyp, Unprotected => True)); (Priv, Prottyp, Unprotected_Mode));
Insert_After (Current_Node, Sub); Insert_After (Current_Node, Sub);
Analyze (Sub); Analyze (Sub);
...@@ -5805,6 +6980,7 @@ package body Exp_Ch9 is ...@@ -5805,6 +6980,7 @@ package body Exp_Ch9 is
Defining_Unit_Name (Specification (Sub))); Defining_Unit_Name (Specification (Sub)));
Current_Node := Sub; Current_Node := Sub;
if Is_Interrupt_Handler if Is_Interrupt_Handler
(Defining_Unit_Name (Specification (Priv))) (Defining_Unit_Name (Specification (Priv)))
then then
...@@ -5812,7 +6988,7 @@ package body Exp_Ch9 is ...@@ -5812,7 +6988,7 @@ package body Exp_Ch9 is
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
Specification => Specification =>
Build_Protected_Sub_Specification Build_Protected_Sub_Specification
(Priv, Prottyp, Unprotected => False)); (Priv, Prottyp, Protected_Mode));
Insert_After (Current_Node, Sub); Insert_After (Current_Node, Sub);
Analyze (Sub); Analyze (Sub);
...@@ -5939,7 +7115,7 @@ package body Exp_Ch9 is ...@@ -5939,7 +7115,7 @@ package body Exp_Ch9 is
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
Specification => Specification =>
Build_Protected_Sub_Specification Build_Protected_Sub_Specification
(Comp, Prottyp, Unprotected => True)); (Comp, Prottyp, Unprotected_Mode));
Insert_After (Current_Node, Sub); Insert_After (Current_Node, Sub);
Analyze (Sub); Analyze (Sub);
...@@ -5957,11 +7133,32 @@ package body Exp_Ch9 is ...@@ -5957,11 +7133,32 @@ package body Exp_Ch9 is
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
Specification => Specification =>
Build_Protected_Sub_Specification Build_Protected_Sub_Specification
(Comp, Prottyp, Unprotected => False)); (Comp, Prottyp, Protected_Mode));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Current_Node := Sub;
-- Generate an overriding primitive operation specification for
-- this subprogram if the protected type implements an inerface.
if Ada_Version >= Ada_05
and then
Present (Abstract_Interfaces
(Corresponding_Record_Type (Prottyp)))
then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
(Comp, Prottyp, Dispatching_Mode));
Insert_After (Current_Node, Sub); Insert_After (Current_Node, Sub);
Analyze (Sub); Analyze (Sub);
Current_Node := Sub; Current_Node := Sub;
end if;
-- If a pragma Interrupt_Handler applies, build and add -- If a pragma Interrupt_Handler applies, build and add
-- a call to Register_Interrupt_Handler to the freezing actions -- a call to Register_Interrupt_Handler to the freezing actions
...@@ -6042,7 +7239,6 @@ package body Exp_Ch9 is ...@@ -6042,7 +7239,6 @@ package body Exp_Ch9 is
if Present (Private_Declarations (Pdef)) then if Present (Private_Declarations (Pdef)) then
Comp := First (Private_Declarations (Pdef)); Comp := First (Private_Declarations (Pdef));
while Present (Comp) loop while Present (Comp) loop
if Nkind (Comp) = N_Entry_Declaration then if Nkind (Comp) = N_Entry_Declaration then
E_Count := E_Count + 1; E_Count := E_Count + 1;
...@@ -8160,6 +9356,40 @@ package body Exp_Ch9 is ...@@ -8160,6 +9356,40 @@ package body Exp_Ch9 is
-- end if; -- end if;
-- end; -- end;
-- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
-- declare
-- B : Boolean := False;
-- C : Ada.Tags.Prim_Op_Kind;
-- DX : Duration := To_Duration (D)
-- M : Integer :=...;
-- P : Parameters := (Param1 .. ParamN);
-- S : constant Iteger := DT_Position (<dispatching-procedure>);
-- begin
-- disp_timed_select (<object>, S, P'Address, DX, M, C, B);
-- if C = POK_Protected_Entry
-- or else C = POK_Task_Entry
-- then
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- end if;
-- if B then
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
-- T.E;
-- end if;
-- S1;
-- else
-- S2;
-- end if;
-- end;
procedure Expand_N_Timed_Entry_Call (N : Node_Id) is procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -8172,25 +9402,32 @@ package body Exp_Ch9 is ...@@ -8172,25 +9402,32 @@ package body Exp_Ch9 is
D_Stats : constant List_Id := D_Stats : constant List_Id :=
Statements (Delay_Alternative (N)); Statements (Delay_Alternative (N));
Stmts : List_Id; Actuals : List_Id;
Stmt : Node_Id; Blk_Typ : Entity_Id;
Parms : List_Id; Call : Node_Id;
Parm : Node_Id; Call_Ent : Entity_Id;
Concval : Node_Id; Concval : Node_Id;
D_Conv : Node_Id;
D_Disc : Node_Id;
D_Type : Entity_Id;
Decls : List_Id;
Dummy : Node_Id;
Ename : Node_Id; Ename : Node_Id;
Formals : List_Id;
Index : Node_Id; Index : Node_Id;
N_Stats : List_Id;
Obj : Entity_Id;
Param : Node_Id;
Params : List_Id;
Stmt : Node_Id;
Stmts : List_Id;
Decls : List_Id; B : Entity_Id; -- Call status flag
Disc : Node_Id; C : Entity_Id; -- Call kind
Conv : Node_Id; D : Entity_Id; -- Delay
B : Entity_Id; M : Entity_Id; -- Delay mode
D : Entity_Id; P : Node_Id; -- Parameter block
Dtyp : Entity_Id; S : Entity_Id; -- Primitive operation slot
M : Entity_Id;
Call : Node_Id;
Dummy : Node_Id;
begin begin
-- The arguments in the call may require dynamic allocation, and the -- The arguments in the call may require dynamic allocation, and the
...@@ -8200,7 +9437,6 @@ package body Exp_Ch9 is ...@@ -8200,7 +9437,6 @@ package body Exp_Ch9 is
if Nkind (E_Call) = N_Block_Statement then if Nkind (E_Call) = N_Block_Statement then
E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
while Nkind (E_Call) /= N_Procedure_Call_Statement while Nkind (E_Call) /= N_Procedure_Call_Statement
and then Nkind (E_Call) /= N_Entry_Call_Statement and then Nkind (E_Call) /= N_Entry_Call_Statement
loop loop
...@@ -8208,87 +9444,268 @@ package body Exp_Ch9 is ...@@ -8208,87 +9444,268 @@ package body Exp_Ch9 is
end loop; end loop;
end if; end if;
-- Build an entry call using Simple_Entry_Call. We will use this as the if Ada_Version >= Ada_05
-- base for creating appropriate calls. and then Nkind (E_Call) = N_Procedure_Call_Statement
then
Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
Decls := New_List;
Stmts := New_List;
else
-- Build an entry call using Simple_Entry_Call
Extract_Entry (E_Call, Concval, Ename, Index); Extract_Entry (E_Call, Concval, Ename, Index);
Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
Stmts := Statements (Handled_Statement_Sequence (E_Call));
Decls := Declarations (E_Call); Decls := Declarations (E_Call);
Stmts := Statements (Handled_Statement_Sequence (E_Call));
if No (Decls) then if No (Decls) then
Decls := New_List; Decls := New_List;
end if; end if;
end if;
-- Call status flag processing
if Ada_Version >= Ada_05
and then Nkind (E_Call) = N_Procedure_Call_Statement
then
-- Generate:
-- B : Boolean := False;
B := SEU.Build_B (Loc, Decls);
else
-- Generate:
-- B : Boolean;
B := Make_Defining_Identifier (Loc, Name_uB);
Prepend_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
B,
Object_Definition =>
New_Reference_To (Standard_Boolean, Loc)));
end if;
-- Call kind processing
if Ada_Version >= Ada_05
and then Nkind (E_Call) = N_Procedure_Call_Statement
then
-- Generate:
-- C : Ada.Tags.Prim_Op_Kind;
C := SEU.Build_C (Loc, Decls);
end if;
-- Duration and mode processing
Dtyp := Base_Type (Etype (Expression (D_Stat))); D_Type := Base_Type (Etype (Expression (D_Stat)));
-- Use the type of the delay expression (Calendar or Real_Time) -- Use the type of the delay expression (Calendar or Real_Time)
-- to generate the appropriate conversion. -- to generate the appropriate conversion.
if Nkind (D_Stat) = N_Delay_Relative_Statement then if Nkind (D_Stat) = N_Delay_Relative_Statement then
Disc := Make_Integer_Literal (Loc, 0); D_Disc := Make_Integer_Literal (Loc, 0);
Conv := Relocate_Node (Expression (D_Stat)); D_Conv := Relocate_Node (Expression (D_Stat));
elsif Is_RTE (Dtyp, RO_CA_Time) then elsif Is_RTE (D_Type, RO_CA_Time) then
Disc := Make_Integer_Literal (Loc, 1); D_Disc := Make_Integer_Literal (Loc, 1);
Conv := Make_Function_Call (Loc, D_Conv := Make_Function_Call (Loc,
New_Reference_To (RTE (RO_CA_To_Duration), Loc), New_Reference_To (RTE (RO_CA_To_Duration), Loc),
New_List (New_Copy (Expression (D_Stat)))); New_List (New_Copy (Expression (D_Stat))));
else pragma Assert (Is_RTE (Dtyp, RO_RT_Time)); else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
Disc := Make_Integer_Literal (Loc, 2); D_Disc := Make_Integer_Literal (Loc, 2);
Conv := Make_Function_Call (Loc, D_Conv := Make_Function_Call (Loc,
New_Reference_To (RTE (RO_RT_To_Duration), Loc), New_Reference_To (RTE (RO_RT_To_Duration), Loc),
New_List (New_Copy (Expression (D_Stat)))); New_List (New_Copy (Expression (D_Stat))));
end if; end if;
-- Create Duration and Delay_Mode objects for passing a delay value
D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
-- Generate:
-- D : Duration;
Append_To (Decls, Append_To (Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => D, Defining_Identifier =>
Object_Definition => New_Reference_To (Standard_Duration, Loc))); D,
Object_Definition =>
New_Reference_To (Standard_Duration, Loc)));
M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
-- Generate:
-- M : Integer := (0 | 1 | 2);
Append_To (Decls, Append_To (Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => M, Defining_Identifier =>
Object_Definition => New_Reference_To (Standard_Integer, Loc), M,
Expression => Disc)); Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
Expression =>
D_Disc));
B := Make_Defining_Identifier (Loc, Name_uB); -- Do the assignement at this stage only because the evaluation of the
-- expression must not occur before (see ACVC C97302A).
-- Create a boolean object used for a return parameter Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
New_Reference_To (D, Loc),
Expression =>
D_Conv));
Prepend_To (Decls, -- Parameter block processing
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
Stmt := First (Stmts); -- Manually create the parameter block for dispatching calls. In the
-- case of entries, the block has already been created during the call
-- to Build_Simple_Entry_Call.
if Ada_Version >= Ada_05
and then Nkind (E_Call) = N_Procedure_Call_Statement
then
Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
P := Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals,
Decls, Stmts);
-- Dispatch table slot processing, generate:
-- S : constant Integer :=
-- DT_Prosition (<dispatching-procedure>)
S := SEU.Build_S (Loc, Decls, Call_Ent);
-- Generate:
-- _dispatching_timed_select (Obj, S, P'address, D, M, C, B);
-- where Obj is the controlling formal parameter, S is the dispatch
-- table slot number of the dispatching operation, P is the wrapped
-- parameter block, D is the duration, M is the duration mode, C is
-- the call kind and B is the call status.
Params := New_List;
Append_To (Params, New_Copy_Tree (Obj));
Append_To (Params, New_Reference_To (S, Loc));
Append_To (Params, P);
Append_To (Params, New_Reference_To (D, Loc));
Append_To (Params, New_Reference_To (M, Loc));
Append_To (Params, New_Reference_To (C, Loc));
Append_To (Params, New_Reference_To (B, Loc));
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uDisp_Timed_Select),
Parameter_Associations =>
Params));
-- Generate:
-- if C = POK_Protected_Entry
-- or else C = POK_Task_Entry
-- then
-- Param1 := P.Param1;
-- ...
-- ParamN := P.ParamN;
-- end if;
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
Then_Statements =>
Parameter_Block_Unpack (Loc, Actuals, Formals)));
-- Generate:
-- if B then
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure
-- then
-- <dispatching-procedure-call>
-- end if;
-- <normal-statements>
-- else
-- <delay-statements>
-- end if;
N_Stats := New_Copy_List (E_Stats);
Prepend_To (N_Stats,
Make_If_Statement (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Procedure), Loc)),
Right_Opnd =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (
RE_POK_Protected_Procedure), Loc)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Reference_To (C, Loc),
Right_Opnd =>
New_Reference_To (RTE (
RE_POK_Task_Procedure), Loc)))),
Then_Statements =>
New_List (E_Call)));
Append_To (Stmts,
Make_If_Statement (Loc,
Condition => New_Reference_To (B, Loc),
Then_Statements => N_Stats,
Else_Statements => D_Stats));
else
-- Skip assignments to temporaries created for in-out parameters. -- Skip assignments to temporaries created for in-out parameters.
-- This makes unwarranted assumptions about the shape of the expanded -- This makes unwarranted assumptions about the shape of the expanded
-- tree for the call, and should be cleaned up ??? -- tree for the call, and should be cleaned up ???
Stmt := First (Stmts);
while Nkind (Stmt) /= N_Procedure_Call_Statement loop while Nkind (Stmt) /= N_Procedure_Call_Statement loop
Next (Stmt); Next (Stmt);
end loop; end loop;
-- Do the assignement at this stage only because the evaluation of the -- Do the assignement at this stage only because the evaluation
-- expression must not occur before (see ACVC C97302A). -- of the expression must not occur before (see ACVC C97302A).
Insert_Before (Stmt, Insert_Before (Stmt,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Reference_To (D, Loc), Name => New_Reference_To (D, Loc),
Expression => Conv)); Expression => D_Conv));
Call := Stmt; Call := Stmt;
Params := Parameter_Associations (Call);
Parms := Parameter_Associations (Call);
-- For a protected type, we build a Timed_Protected_Entry_Call -- For a protected type, we build a Timed_Protected_Entry_Call
...@@ -8296,32 +9713,31 @@ package body Exp_Ch9 is ...@@ -8296,32 +9713,31 @@ package body Exp_Ch9 is
-- Create a new call statement -- Create a new call statement
Parm := First (Parms); Param := First (Params);
while Present (Param)
while Present (Parm) and then not Is_RTE (Etype (Param), RE_Call_Modes)
and then not Is_RTE (Etype (Parm), RE_Call_Modes)
loop loop
Next (Parm); Next (Param);
end loop; end loop;
Dummy := Remove_Next (Next (Parm)); Dummy := Remove_Next (Next (Param));
-- Remove garbage is following the Cancel_Param if present -- Remove garbage is following the Cancel_Param if present
Dummy := Next (Parm); Dummy := Next (Param);
-- Remove the mode of the Protected_Entry_Call call, then remove the -- Remove the mode of the Protected_Entry_Call call, then remove
-- Communication_Block of the Protected_Entry_Call call, and finally -- the Communication_Block of the Protected_Entry_Call call, and
-- add Duration and a Delay_Mode parameter -- finally add Duration and a Delay_Mode parameter
pragma Assert (Present (Parm)); pragma Assert (Present (Param));
Rewrite (Parm, New_Reference_To (D, Loc)); Rewrite (Param, New_Reference_To (D, Loc));
Rewrite (Dummy, New_Reference_To (M, Loc)); Rewrite (Dummy, New_Reference_To (M, Loc));
-- Add a Boolean flag for successful entry call -- Add a Boolean flag for successful entry call
Append_To (Parms, New_Reference_To (B, Loc)); Append_To (Params, New_Reference_To (B, Loc));
if Abort_Allowed if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False or else Restriction_Active (No_Entry_Queue) = False
...@@ -8330,25 +9746,24 @@ package body Exp_Ch9 is ...@@ -8330,25 +9746,24 @@ package body Exp_Ch9 is
Rewrite (Call, Rewrite (Call,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name =>
New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), New_Reference_To (RTE (
Parameter_Associations => Parms)); RE_Timed_Protected_Entry_Call), Loc),
Parameter_Associations => Params));
else else
Parm := First (Parms); Param := First (Params);
while Present (Param)
while Present (Parm) and then not Is_RTE (Etype (Param), RE_Protected_Entry_Index)
and then not Is_RTE (Etype (Parm), RE_Protected_Entry_Index)
loop loop
Next (Parm); Next (Param);
end loop; end loop;
Remove (Parm); Remove (Param);
Rewrite (Call, Rewrite (Call,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To ( Name => New_Reference_To (
RTE (RE_Timed_Protected_Single_Entry_Call), Loc), RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
Parameter_Associations => Parms)); Parameter_Associations => Params));
end if; end if;
-- For the task case, build a Timed_Task_Entry_Call -- For the task case, build a Timed_Task_Entry_Call
...@@ -8356,15 +9771,15 @@ package body Exp_Ch9 is ...@@ -8356,15 +9771,15 @@ package body Exp_Ch9 is
else else
-- Create a new call statement -- Create a new call statement
Append_To (Parms, New_Reference_To (D, Loc)); Append_To (Params, New_Reference_To (D, Loc));
Append_To (Parms, New_Reference_To (M, Loc)); Append_To (Params, New_Reference_To (M, Loc));
Append_To (Parms, New_Reference_To (B, Loc)); Append_To (Params, New_Reference_To (B, Loc));
Rewrite (Call, Rewrite (Call,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), Name =>
Parameter_Associations => Parms)); New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
Parameter_Associations => Params));
end if; end if;
Append_To (Stmts, Append_To (Stmts,
...@@ -8372,6 +9787,7 @@ package body Exp_Ch9 is ...@@ -8372,6 +9787,7 @@ package body Exp_Ch9 is
Condition => New_Reference_To (B, Loc), Condition => New_Reference_To (B, Loc),
Then_Statements => E_Stats, Then_Statements => E_Stats,
Else_Statements => D_Stats)); Else_Statements => D_Stats));
end if;
Rewrite (N, Rewrite (N,
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
...@@ -8481,6 +9897,55 @@ package body Exp_Ch9 is ...@@ -8481,6 +9897,55 @@ package body Exp_Ch9 is
end if; end if;
end External_Subprogram; end External_Subprogram;
------------------------------
-- Extract_Dispatching_Call --
------------------------------
procedure Extract_Dispatching_Call
(N : Node_Id;
Call_Ent : out Entity_Id;
Object : out Entity_Id;
Actuals : out List_Id;
Formals : out List_Id)
is
Call_Nam : Node_Id;
begin
pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
if Present (Original_Node (N)) then
Call_Nam := Name (Original_Node (N));
else
Call_Nam := Name (N);
end if;
-- Retrieve the name of the dispatching procedure. It contains the
-- dispatch table slot number.
loop
case Nkind (Call_Nam) is
when N_Identifier =>
exit;
when N_Selected_Component =>
Call_Nam := Selector_Name (Call_Nam);
when others =>
raise Program_Error;
end case;
end loop;
Actuals := Parameter_Associations (N);
Call_Ent := Entity (Call_Nam);
Formals := Parameter_Specifications (Parent (Call_Ent));
Object := First (Actuals);
if Present (Original_Node (Object)) then
Object := Original_Node (Object);
end if;
end Extract_Dispatching_Call;
------------------- -------------------
-- Extract_Entry -- -- Extract_Entry --
------------------- -------------------
...@@ -8502,15 +9967,13 @@ package body Exp_Ch9 is ...@@ -8502,15 +9967,13 @@ package body Exp_Ch9 is
Ename := Selector_Name (Nam); Ename := Selector_Name (Nam);
Index := Empty; Index := Empty;
-- For a member of an entry family, the name is an indexed -- For a member of an entry family, the name is an indexed component
-- component where the prefix is a selected component, -- where the prefix is a selected component, whose prefix in turn is
-- whose prefix in turn is the task value, and whose -- the task value, and whose selector is the entry family. The single
-- selector is the entry family. The single expression in -- expression in the expressions list of the indexed component is the
-- the expressions list of the indexed component is the
-- subscript for the family. -- subscript for the family.
else else pragma Assert (Nkind (Nam) = N_Indexed_Component);
pragma Assert (Nkind (Nam) = N_Indexed_Component);
Concval := Prefix (Prefix (Nam)); Concval := Prefix (Prefix (Nam));
Ename := Selector_Name (Prefix (Nam)); Ename := Selector_Name (Prefix (Nam));
Index := First (Expressions (Nam)); Index := First (Expressions (Nam));
...@@ -8899,6 +10362,8 @@ package body Exp_Ch9 is ...@@ -8899,6 +10362,8 @@ package body Exp_Ch9 is
if Has_Entry if Has_Entry
or else Has_Interrupt_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp) or else Has_Attach_Handler (Ptyp)
or else (Ada_Version >= Ada_05
and then Present (Interface_List (Parent (Ptyp))))
then then
-- Compiler_Info parameter. This parameter allows entry body -- Compiler_Info parameter. This parameter allows entry body
-- procedures and barrier functions to be called from the runtime. -- procedures and barrier functions to be called from the runtime.
...@@ -9287,6 +10752,168 @@ package body Exp_Ch9 is ...@@ -9287,6 +10752,168 @@ package body Exp_Ch9 is
return Next_Op; return Next_Op;
end Next_Protected_Operation; end Next_Protected_Operation;
--------------------------
-- Parameter_Block_Pack --
--------------------------
function Parameter_Block_Pack
(Loc : Source_Ptr;
Blk_Typ : Entity_Id;
Actuals : List_Id;
Formals : List_Id;
Decls : List_Id;
Stmts : List_Id) return Node_Id
is
Actual : Entity_Id;
Blk_Nam : Node_Id;
Formal : Entity_Id;
Params : List_Id;
Temp_Asn : Node_Id;
Temp_Nam : Node_Id;
begin
Actual := First (Actuals);
Formal := Defining_Identifier (First (Formals));
Params := New_List;
while Present (Actual) loop
if Is_By_Copy_Type (Etype (Actual)) then
-- Generate:
-- Jnn : aliased <formal-type>
Temp_Nam :=
Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Aliased_Present =>
True,
Defining_Identifier =>
Temp_Nam,
Object_Definition =>
New_Reference_To (Etype (Formal), Loc)));
if Ekind (Formal) /= E_Out_Parameter then
-- Generate:
-- Jnn := <actual>
Temp_Asn :=
New_Reference_To (Temp_Nam, Loc);
Set_Assignment_OK (Temp_Asn);
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
Temp_Asn,
Expression =>
New_Copy_Tree (Actual)));
end if;
-- Generate:
-- Jnn'unchecked_access
Append_To (Params,
Make_Attribute_Reference (Loc,
Attribute_Name =>
Name_Unchecked_Access,
Prefix =>
New_Reference_To (Temp_Nam, Loc)));
else
Append_To (Params,
Make_Reference (Loc, New_Copy_Tree (Actual)));
end if;
Next_Actual (Actual);
Next_Formal_With_Extras (Formal);
end loop;
-- Generate:
-- P : Ann := (
-- J1'unchecked_access;
-- <actual2>'reference;
-- ...);
Blk_Nam := Make_Defining_Identifier (Loc, Name_uP);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Blk_Nam,
Object_Definition =>
New_Reference_To (Blk_Typ, Loc),
Expression =>
Make_Aggregate (Loc, Params)));
-- Return:
-- P'address
return
Make_Attribute_Reference (Loc,
Attribute_Name =>
Name_Address,
Prefix =>
New_Reference_To (Blk_Nam, Loc));
end Parameter_Block_Pack;
----------------------------
-- Parameter_Block_Unpack --
----------------------------
function Parameter_Block_Unpack
(Loc : Source_Ptr;
Actuals : List_Id;
Formals : List_Id) return List_Id
is
Actual : Entity_Id;
Asnmt : Node_Id;
Formal : Entity_Id;
Result : constant List_Id := New_List;
At_Least_One_Asnmt : Boolean := False;
begin
Actual := First (Actuals);
Formal := Defining_Identifier (First (Formals));
while Present (Actual) loop
if Is_By_Copy_Type (Etype (Actual))
and then Ekind (Formal) /= E_In_Parameter
then
At_Least_One_Asnmt := True;
-- Generate:
-- <actual> := P.<formal>;
Asnmt :=
Make_Assignment_Statement (Loc,
Name =>
New_Copy (Actual),
Expression =>
Make_Explicit_Dereference (Loc,
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uP),
Selector_Name =>
Make_Identifier (Loc, Chars (Formal)))));
Set_Assignment_OK (Name (Asnmt));
Append_To (Result, Asnmt);
end if;
Next_Actual (Actual);
Next_Formal_With_Extras (Formal);
end loop;
if At_Least_One_Asnmt then
return Result;
end if;
return New_List (Make_Null_Statement (Loc));
end Parameter_Block_Unpack;
---------------------- ----------------------
-- Set_Discriminals -- -- Set_Discriminals --
---------------------- ----------------------
...@@ -9302,7 +10929,6 @@ package body Exp_Ch9 is ...@@ -9302,7 +10929,6 @@ package body Exp_Ch9 is
if Has_Discriminants (Pdef) then if Has_Discriminants (Pdef) then
D := First_Discriminant (Pdef); D := First_Discriminant (Pdef);
while Present (D) loop while Present (D) loop
D_Minal := D_Minal :=
Make_Defining_Identifier (Sloc (D), Make_Defining_Identifier (Sloc (D),
...@@ -9366,11 +10992,10 @@ package body Exp_Ch9 is ...@@ -9366,11 +10992,10 @@ package body Exp_Ch9 is
Set_Esize (Priv, Esize (Etype (P_Id))); Set_Esize (Priv, Esize (Etype (P_Id)));
Set_Alignment (Priv, Alignment (Etype (P_Id))); Set_Alignment (Priv, Alignment (Etype (P_Id)));
-- If the type of the component is an itype, we must -- If the type of the component is an itype, we must create a
-- create a new itype for the corresponding prival in -- new itype for the corresponding prival in each protected
-- each protected operation, to avoid scoping problems. -- operation, to avoid scoping problems. We create new itypes
-- We create new itypes by copying the tree for the -- by copying the tree for the component definition.
-- component definition.
if Is_Itype (Etype (P_Id)) then if Is_Itype (Etype (P_Id)) then
Append_Elmt (P_Id, Assoc_L); Append_Elmt (P_Id, Assoc_L);
...@@ -9394,9 +11019,8 @@ package body Exp_Ch9 is ...@@ -9394,9 +11019,8 @@ package body Exp_Ch9 is
end loop; end loop;
end if; end if;
-- There is one more implicit private declaration: the object -- There is one more implicit private decl: the object itself. "prival"
-- itself. A "prival" for this is attached to the protected -- for this is attached to the protected body defining identifier.
-- body defining identifier.
Body_Ent := Corresponding_Body (Dec); Body_Ent := Corresponding_Body (Dec);
...@@ -9492,11 +11116,12 @@ package body Exp_Ch9 is ...@@ -9492,11 +11116,12 @@ package body Exp_Ch9 is
Update_Array_Bounds (Etype (Defining_Identifier (N))); Update_Array_Bounds (Etype (Defining_Identifier (N)));
return OK; return OK;
-- For array components of discriminated records, use the -- For array components of discriminated records, use the base type
-- base type directly, because it may depend indirectly -- directly, because it may depend indirectly on the discriminants of
-- on the discriminants of the protected type. Cleaner would -- the protected type.
-- be a systematic mechanism to compute actual subtypes of
-- private components ??? -- Cleaner would be a systematic mechanism to compute actual subtypes
-- of private components???
elsif Nkind (N) in N_Has_Etype elsif Nkind (N) in N_Has_Etype
and then Present (Etype (N)) and then Present (Etype (N))
...@@ -9532,10 +11157,8 @@ package body Exp_Ch9 is ...@@ -9532,10 +11157,8 @@ package body Exp_Ch9 is
procedure Update_Array_Bounds (E : Entity_Id) is procedure Update_Array_Bounds (E : Entity_Id) is
Ind : Node_Id; Ind : Node_Id;
begin begin
Ind := First_Index (E); Ind := First_Index (E);
while Present (Ind) loop while Present (Ind) loop
Update_Prival_Subtypes (Type_Low_Bound (Etype (Ind))); Update_Prival_Subtypes (Type_Low_Bound (Etype (Ind)));
Update_Prival_Subtypes (Type_High_Bound (Etype (Ind))); Update_Prival_Subtypes (Type_High_Bound (Etype (Ind)));
...@@ -9550,13 +11173,13 @@ package body Exp_Ch9 is ...@@ -9550,13 +11173,13 @@ package body Exp_Ch9 is
procedure Update_Index_Types (N : Node_Id) is procedure Update_Index_Types (N : Node_Id) is
Indx1 : Node_Id; Indx1 : Node_Id;
I_Typ : Node_Id; I_Typ : Node_Id;
begin begin
-- If the prefix has an actual subtype that is different -- If the prefix has an actual subtype that is different from the
-- from the nominal one, update the types of the indices, -- nominal one, update the types of the indices, so that the proper
-- so that the proper constraints are applied. Do not -- constraints are applied. Do not apply this transformation to a
-- apply this transformation to a packed array, where the -- packed array, where the index type is computed for a byte array
-- index type is computed for a byte array and is different -- and is different from the source index.
-- from the source index.
if Nkind (Parent (N)) = N_Indexed_Component if Nkind (Parent (N)) = N_Indexed_Component
and then and then
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -30,6 +30,13 @@ with Types; use Types; ...@@ -30,6 +30,13 @@ with Types; use Types;
package Exp_Ch9 is package Exp_Ch9 is
type Subprogram_Protection_Mode is
(Dispatching_Mode,
Protected_Mode,
Unprotected_Mode);
-- This type is used to distinguish the different protection modes of a
-- protected subprogram.
procedure Add_Discriminal_Declarations procedure Add_Discriminal_Declarations
(Decls : List_Id; (Decls : List_Id;
Typ : Entity_Id; Typ : Entity_Id;
...@@ -104,8 +111,7 @@ package Exp_Ch9 is ...@@ -104,8 +111,7 @@ package Exp_Ch9 is
function Build_Protected_Sub_Specification function Build_Protected_Sub_Specification
(N : Node_Id; (N : Node_Id;
Prottyp : Entity_Id; Prottyp : Entity_Id;
Unprotected : Boolean := False) Mode : Subprogram_Protection_Mode) return Node_Id;
return Node_Id;
-- Build specification for protected subprogram. This is called when -- Build specification for protected subprogram. This is called when
-- expanding a protected type, and also when expanding the declaration for -- expanding a protected type, and also when expanding the declaration for
-- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is -- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is
...@@ -214,7 +220,7 @@ package Exp_Ch9 is ...@@ -214,7 +220,7 @@ package Exp_Ch9 is
-- routine to make sure Complete_Master is called on exit). -- routine to make sure Complete_Master is called on exit).
procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id); procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id);
-- Build Equivalent_Type for an Access_to_protected_Subprogram. -- Build Equivalent_Type for an Access_to_protected_Subprogram
procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id); procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id);
-- Expand declarations required for accept statement. See bodies of -- Expand declarations required for accept statement. See bodies of
......
...@@ -49,19 +49,276 @@ with Sinfo; use Sinfo; ...@@ -49,19 +49,276 @@ with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp; with Uintp; use Uintp;
package body Exp_Disp is package body Exp_Disp is
--------------------------------
-- Select_Expansion_Utilities --
--------------------------------
-- The following package contains helper routines used in the expansion of
-- dispatching asynchronous, conditional and timed selects.
package Select_Expansion_Utilities is
procedure Build_B
(Loc : Source_Ptr;
Params : List_Id);
-- Generate:
-- B : out Communication_Block
procedure Build_C
(Loc : Source_Ptr;
Params : List_Id);
-- Generate:
-- C : out Prim_Op_Kind
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
Typ : Entity_Id;
Stmts : List_Id);
-- Ada 2005 (AI-345): Generate statements that are common between
-- asynchronous, conditional and timed select expansion.
procedure Build_F
(Loc : Source_Ptr;
Params : List_Id);
-- Generate:
-- F : out Boolean
procedure Build_P
(Loc : Source_Ptr;
Params : List_Id);
-- Generate:
-- P : Address
procedure Build_S
(Loc : Source_Ptr;
Params : List_Id);
-- Generate:
-- S : Integer
procedure Build_T
(Loc : Source_Ptr;
Typ : Entity_Id;
Params : List_Id);
-- Generate:
-- T : in out Typ
end Select_Expansion_Utilities;
package body Select_Expansion_Utilities is
-------------
-- Build_B --
-------------
procedure Build_B
(Loc : Source_Ptr;
Params : List_Id)
is
begin
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uB),
Parameter_Type =>
New_Reference_To (RTE (RE_Communication_Block), Loc),
Out_Present => True));
end Build_B;
-------------
-- Build_C --
-------------
procedure Build_C
(Loc : Source_Ptr;
Params : List_Id)
is
begin
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uC),
Parameter_Type =>
New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
Out_Present => True));
end Build_C;
------------------------------------------------
-- Build_Common_Dispatching_Select_Statements --
------------------------------------------------
procedure Build_Common_Dispatching_Select_Statements
(Loc : Source_Ptr;
Typ : Entity_Id;
Stmts : List_Id)
is
DT_Ptr : Entity_Id;
DT_Ptr_Typ : Entity_Id := Typ;
begin
-- Typ may be a derived type, climb the derivation chain in order to
-- find the root.
while Present (Parent_Subtype (DT_Ptr_Typ)) loop
DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
end loop;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
-- where C is the out parameter capturing the call kind and S is the
-- dispatch table slot number.
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uC),
Expression =>
Make_DT_Access_Action (Typ,
Action =>
Get_Prim_Op_Kind,
Args =>
New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)),
Make_Identifier (Loc, Name_uS)))));
-- Generate:
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
-- then
-- F := True;
-- return;
-- where F is the out parameter capturing the status of a potential
-- entry call.
Append_To (Stmts,
Make_If_Statement (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Identifier (Loc, Name_uC),
Right_Opnd =>
New_Reference_To (RTE (RE_POK_Procedure), Loc)),
Right_Opnd =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Identifier (Loc, Name_uC),
Right_Opnd =>
New_Reference_To (RTE (
RE_POK_Protected_Procedure), Loc)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Identifier (Loc, Name_uC),
Right_Opnd =>
New_Reference_To (RTE (
RE_POK_Task_Procedure), Loc)))),
Then_Statements =>
New_List (
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_True, Loc)),
Make_Return_Statement (Loc))));
end Build_Common_Dispatching_Select_Statements;
-------------
-- Build_F --
-------------
procedure Build_F
(Loc : Source_Ptr;
Params : List_Id)
is
begin
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uF),
Parameter_Type =>
New_Reference_To (Standard_Boolean, Loc),
Out_Present => True));
end Build_F;
-------------
-- Build_P --
-------------
procedure Build_P
(Loc : Source_Ptr;
Params : List_Id)
is
begin
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uP),
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)));
end Build_P;
-------------
-- Build_S --
-------------
procedure Build_S
(Loc : Source_Ptr;
Params : List_Id)
is
begin
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uS),
Parameter_Type =>
New_Reference_To (Standard_Integer, Loc)));
end Build_S;
-------------
-- Build_T --
-------------
procedure Build_T
(Loc : Source_Ptr;
Typ : Entity_Id;
Params : List_Id)
is
begin
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uT),
Parameter_Type =>
New_Reference_To (Typ, Loc),
In_Present => True,
Out_Present => True));
end Build_T;
end Select_Expansion_Utilities;
package SEU renames Select_Expansion_Utilities;
Ada_Actions : constant array (DT_Access_Action) of RE_Id := Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
(CW_Membership => RE_CW_Membership, (CW_Membership => RE_CW_Membership,
IW_Membership => RE_IW_Membership, IW_Membership => RE_IW_Membership,
DT_Entry_Size => RE_DT_Entry_Size, DT_Entry_Size => RE_DT_Entry_Size,
DT_Prologue_Size => RE_DT_Prologue_Size, DT_Prologue_Size => RE_DT_Prologue_Size,
Get_Access_Level => RE_Get_Access_Level, Get_Access_Level => RE_Get_Access_Level,
Get_Entry_Index => RE_Get_Entry_Index,
Get_External_Tag => RE_Get_External_Tag, Get_External_Tag => RE_Get_External_Tag,
Get_Prim_Op_Address => RE_Get_Prim_Op_Address, Get_Prim_Op_Address => RE_Get_Prim_Op_Address,
Get_Prim_Op_Kind => RE_Get_Prim_Op_Kind,
Get_RC_Offset => RE_Get_RC_Offset, Get_RC_Offset => RE_Get_RC_Offset,
Get_Remotely_Callable => RE_Get_Remotely_Callable, Get_Remotely_Callable => RE_Get_Remotely_Callable,
Inherit_DT => RE_Inherit_DT, Inherit_DT => RE_Inherit_DT,
...@@ -69,9 +326,11 @@ package body Exp_Disp is ...@@ -69,9 +326,11 @@ package body Exp_Disp is
Register_Interface_Tag => RE_Register_Interface_Tag, Register_Interface_Tag => RE_Register_Interface_Tag,
Register_Tag => RE_Register_Tag, Register_Tag => RE_Register_Tag,
Set_Access_Level => RE_Set_Access_Level, Set_Access_Level => RE_Set_Access_Level,
Set_Entry_Index => RE_Set_Entry_Index,
Set_Expanded_Name => RE_Set_Expanded_Name, Set_Expanded_Name => RE_Set_Expanded_Name,
Set_External_Tag => RE_Set_External_Tag, Set_External_Tag => RE_Set_External_Tag,
Set_Prim_Op_Address => RE_Set_Prim_Op_Address, Set_Prim_Op_Address => RE_Set_Prim_Op_Address,
Set_Prim_Op_Kind => RE_Set_Prim_Op_Kind,
Set_RC_Offset => RE_Set_RC_Offset, Set_RC_Offset => RE_Set_RC_Offset,
Set_Remotely_Callable => RE_Set_Remotely_Callable, Set_Remotely_Callable => RE_Set_Remotely_Callable,
Set_TSD => RE_Set_TSD, Set_TSD => RE_Set_TSD,
...@@ -84,8 +343,10 @@ package body Exp_Disp is ...@@ -84,8 +343,10 @@ package body Exp_Disp is
DT_Entry_Size => False, DT_Entry_Size => False,
DT_Prologue_Size => False, DT_Prologue_Size => False,
Get_Access_Level => False, Get_Access_Level => False,
Get_Entry_Index => False,
Get_External_Tag => False, Get_External_Tag => False,
Get_Prim_Op_Address => False, Get_Prim_Op_Address => False,
Get_Prim_Op_Kind => False,
Get_Remotely_Callable => False, Get_Remotely_Callable => False,
Get_RC_Offset => False, Get_RC_Offset => False,
Inherit_DT => True, Inherit_DT => True,
...@@ -93,9 +354,11 @@ package body Exp_Disp is ...@@ -93,9 +354,11 @@ package body Exp_Disp is
Register_Interface_Tag => True, Register_Interface_Tag => True,
Register_Tag => True, Register_Tag => True,
Set_Access_Level => True, Set_Access_Level => True,
Set_Entry_Index => True,
Set_Expanded_Name => True, Set_Expanded_Name => True,
Set_External_Tag => True, Set_External_Tag => True,
Set_Prim_Op_Address => True, Set_Prim_Op_Address => True,
Set_Prim_Op_Kind => True,
Set_RC_Offset => True, Set_RC_Offset => True,
Set_Remotely_Callable => True, Set_Remotely_Callable => True,
Set_TSD => True, Set_TSD => True,
...@@ -108,8 +371,10 @@ package body Exp_Disp is ...@@ -108,8 +371,10 @@ package body Exp_Disp is
DT_Entry_Size => 0, DT_Entry_Size => 0,
DT_Prologue_Size => 0, DT_Prologue_Size => 0,
Get_Access_Level => 1, Get_Access_Level => 1,
Get_Entry_Index => 2,
Get_External_Tag => 1, Get_External_Tag => 1,
Get_Prim_Op_Address => 2, Get_Prim_Op_Address => 2,
Get_Prim_Op_Kind => 2,
Get_RC_Offset => 1, Get_RC_Offset => 1,
Get_Remotely_Callable => 1, Get_Remotely_Callable => 1,
Inherit_DT => 3, Inherit_DT => 3,
...@@ -117,21 +382,17 @@ package body Exp_Disp is ...@@ -117,21 +382,17 @@ package body Exp_Disp is
Register_Interface_Tag => 2, Register_Interface_Tag => 2,
Register_Tag => 1, Register_Tag => 1,
Set_Access_Level => 2, Set_Access_Level => 2,
Set_Entry_Index => 3,
Set_Expanded_Name => 2, Set_Expanded_Name => 2,
Set_External_Tag => 2, Set_External_Tag => 2,
Set_Prim_Op_Address => 3, Set_Prim_Op_Address => 3,
Set_Prim_Op_Kind => 3,
Set_RC_Offset => 2, Set_RC_Offset => 2,
Set_Remotely_Callable => 2, Set_Remotely_Callable => 2,
Set_TSD => 2, Set_TSD => 2,
TSD_Entry_Size => 0, TSD_Entry_Size => 0,
TSD_Prologue_Size => 0); TSD_Prologue_Size => 0);
function Build_Anonymous_Access_Type
(Directly_Designated_Type : Entity_Id;
Related_Nod : Node_Id) return Entity_Id;
-- Returns a decorated entity corresponding with an anonymous access type.
-- Used to generate unchecked type conversion of an address.
procedure Collect_All_Interfaces (T : Entity_Id); procedure Collect_All_Interfaces (T : Entity_Id);
-- Ada 2005 (AI-251): Collect the whole list of interfaces that are -- Ada 2005 (AI-251): Collect the whole list of interfaces that are
-- directly or indirectly implemented by T. Used to compute the size -- directly or indirectly implemented by T. Used to compute the size
...@@ -145,29 +406,12 @@ package body Exp_Disp is ...@@ -145,29 +406,12 @@ package body Exp_Disp is
-- Check if the type has a private view or if the public view appears -- Check if the type has a private view or if the public view appears
-- in the visible part of a package spec. -- in the visible part of a package spec.
---------------------------------- function Prim_Op_Kind
-- Build_Anonymous_Access_Type -- (Prim : Entity_Id;
---------------------------------- Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Determine the primitive operation kind of Prim
function Build_Anonymous_Access_Type -- according to its type Typ. Return a reference to an RTE Prim_Op_Kind
(Directly_Designated_Type : Entity_Id; -- enumeration value.
Related_Nod : Node_Id) return Entity_Id
is
New_E : Entity_Id;
begin
New_E := Create_Itype (Ekind => E_Anonymous_Access_Type,
Related_Nod => Related_Nod,
Scope_Id => Current_Scope);
Set_Etype (New_E, New_E);
Init_Size_Align (New_E);
Init_Size (New_E, System_Address_Size);
Set_Directly_Designated_Type (New_E, Directly_Designated_Type);
Set_Is_First_Subtype (New_E);
return New_E;
end Build_Anonymous_Access_Type;
---------------------------- ----------------------------
-- Collect_All_Interfaces -- -- Collect_All_Interfaces --
...@@ -187,9 +431,10 @@ package body Exp_Disp is ...@@ -187,9 +431,10 @@ package body Exp_Disp is
------------------- -------------------
procedure Add_Interface (Iface : Entity_Id) is procedure Add_Interface (Iface : Entity_Id) is
Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (T)); Elmt : Elmt_Id;
begin begin
Elmt := First_Elmt (Abstract_Interfaces (T));
while Present (Elmt) and then Node (Elmt) /= Iface loop while Present (Elmt) and then Node (Elmt) /= Iface loop
Next_Elmt (Elmt); Next_Elmt (Elmt);
end loop; end loop;
...@@ -238,9 +483,7 @@ package body Exp_Disp is ...@@ -238,9 +483,7 @@ package body Exp_Disp is
if Is_Non_Empty_List (Interface_List (Nod)) then if Is_Non_Empty_List (Interface_List (Nod)) then
Id := First (Interface_List (Nod)); Id := First (Interface_List (Nod));
while Present (Id) loop while Present (Id) loop
Iface := Etype (Id); Iface := Etype (Id);
if Is_Interface (Iface) then if Is_Interface (Iface) then
...@@ -309,6 +552,18 @@ package body Exp_Disp is ...@@ -309,6 +552,18 @@ package body Exp_Disp is
elsif TSS_Name = TSS_Deep_Finalize then elsif TSS_Name = TSS_Deep_Finalize then
return Uint_10; return Uint_10;
elsif Chars (E) = Name_uDisp_Asynchronous_Select then
return Uint_11;
elsif Chars (E) = Name_uDisp_Conditional_Select then
return Uint_12;
elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
return Uint_13;
elsif Chars (E) = Name_uDisp_Timed_Select then
return Uint_14;
else else
raise Program_Error; raise Program_Error;
end if; end if;
...@@ -373,9 +628,10 @@ package body Exp_Disp is ...@@ -373,9 +628,10 @@ package body Exp_Disp is
else else
declare declare
Formal : Entity_Id := First_Formal (Subp); Formal : Entity_Id;
begin begin
Formal := First_Formal (Subp);
while Present (Formal) loop while Present (Formal) loop
if Is_Controlling_Formal (Formal) then if Is_Controlling_Formal (Formal) then
if Is_Access_Type (Etype (Formal)) then if Is_Access_Type (Etype (Formal)) then
...@@ -441,6 +697,10 @@ package body Exp_Disp is ...@@ -441,6 +697,10 @@ package body Exp_Disp is
Typ := Root_Type (CW_Typ); Typ := Root_Type (CW_Typ);
if Ekind (Typ) = E_Incomplete_Type then
Typ := Non_Limited_View (Typ);
end if;
if not Is_Limited_Type (Typ) then if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if; end if;
...@@ -744,13 +1004,17 @@ package body Exp_Disp is ...@@ -744,13 +1004,17 @@ package body Exp_Disp is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Operand : constant Node_Id := Expression (N); Operand : constant Node_Id := Expression (N);
Operand_Typ : Entity_Id := Etype (Operand); Operand_Typ : Entity_Id := Etype (Operand);
Target_Type : Entity_Id := Etype (N); Iface_Typ : Entity_Id := Etype (N);
Iface_Tag : Entity_Id; Iface_Tag : Entity_Id;
Fent : Entity_Id;
Func : Node_Id;
P : Node_Id;
Null_Op_Nod : Node_Id;
begin begin
pragma Assert (Nkind (Operand) /= N_Attribute_Reference); pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
-- Ada 2005 (AI-345): Set Operand_Typ and Handle task interfaces -- Ada 2005 (AI-345): Handle task interfaces
if Ekind (Operand_Typ) = E_Task_Type if Ekind (Operand_Typ) = E_Task_Type
or else Ekind (Operand_Typ) = E_Protected_Type or else Ekind (Operand_Typ) = E_Protected_Type
...@@ -758,27 +1022,126 @@ package body Exp_Disp is ...@@ -758,27 +1022,126 @@ package body Exp_Disp is
Operand_Typ := Corresponding_Record_Type (Operand_Typ); Operand_Typ := Corresponding_Record_Type (Operand_Typ);
end if; end if;
if Is_Access_Type (Target_Type) then -- Handle access types to interfaces
Target_Type := Etype (Directly_Designated_Type (Target_Type));
elsif Is_Class_Wide_Type (Target_Type) then if Is_Access_Type (Iface_Typ) then
Target_Type := Etype (Target_Type); Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
end if; end if;
pragma Assert (not Is_Class_Wide_Type (Target_Type) -- Handle class-wide interface types. This conversion can appear
and then Is_Interface (Target_Type)); -- explicitly in the source code. Example: I'Class (Obj)
if Is_Class_Wide_Type (Iface_Typ) then
Iface_Typ := Etype (Iface_Typ);
end if;
Iface_Tag := Find_Interface_Tag (Operand_Typ, Target_Type); pragma Assert (not Is_Class_Wide_Type (Iface_Typ)
and then Is_Interface (Iface_Typ));
Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
pragma Assert (Iface_Tag /= Empty); pragma Assert (Iface_Tag /= Empty);
-- Keep separate access types to interfaces because one internal
-- function is used to handle the null value (see following comment)
if not Is_Access_Type (Etype (N)) then
Rewrite (N, Rewrite (N,
Unchecked_Convert_To (Etype (N), Unchecked_Convert_To (Etype (N),
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expression (N)),
Selector_Name =>
New_Occurrence_Of (Iface_Tag, Loc))));
else
-- Build internal function to handle the case in which the
-- actual is null. If the actual is null returns null because
-- no displacement is required; otherwise performs a type
-- conversion that will be expanded in the code that returns
-- the value of the displaced actual. That is:
-- function Func (O : Operand_Typ) return Iface_Typ is
-- begin
-- if O = null then
-- return null;
-- else
-- return Iface_Typ!(O);
-- end if;
-- end Func;
Fent :=
Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
-- Decorate the "null" in the if-statement condition
Null_Op_Nod := Make_Null (Loc);
Set_Etype (Null_Op_Nod, Etype (Operand));
Set_Analyzed (Null_Op_Nod);
Func :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Fent,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
Parameter_Type =>
New_Reference_To (Etype (Operand), Loc))),
Result_Definition =>
New_Reference_To (Etype (N), Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uO),
Right_Opnd => Null_Op_Nod),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Make_Null (Loc))),
Else_Statements => New_List (
Make_Return_Statement (Loc,
Unchecked_Convert_To (Etype (N),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Make_Selected_Component (Loc, Prefix =>
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Expression (N)), Prefix => Relocate_Node (Expression (N)),
Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)), Selector_Name =>
Attribute_Name => Name_Address))); New_Occurrence_Of (Iface_Tag, Loc)),
Attribute_Name => Name_Address))))))));
-- Insert the new declaration in the nearest enclosing scope
-- that has declarations.
P := N;
while not Has_Declarations (Parent (P)) loop
P := Parent (P);
end loop;
if Is_List_Member (P) then
Insert_Before (P, Func);
elsif Nkind (Parent (P)) = N_Package_Specification then
Append_To (Visible_Declarations (Parent (P)), Func);
else
Append_To (Declarations (Parent (P)), Func);
end if;
Analyze (Func);
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Fent, Loc),
Parameter_Associations => New_List (
Relocate_Node (Expression (N)))));
end if;
Analyze (N); Analyze (N);
end Expand_Interface_Conversion; end Expand_Interface_Conversion;
...@@ -790,12 +1153,16 @@ package body Exp_Disp is ...@@ -790,12 +1153,16 @@ package body Exp_Disp is
procedure Expand_Interface_Actuals (Call_Node : Node_Id) is procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
Loc : constant Source_Ptr := Sloc (Call_Node); Loc : constant Source_Ptr := Sloc (Call_Node);
Actual : Node_Id; Actual : Node_Id;
Actual_Dup : Node_Id;
Actual_Typ : Entity_Id; Actual_Typ : Entity_Id;
Anon : Entity_Id;
Conversion : Node_Id; Conversion : Node_Id;
Formal : Entity_Id; Formal : Entity_Id;
Formal_Typ : Entity_Id; Formal_Typ : Entity_Id;
Subp : Entity_Id; Subp : Entity_Id;
Nam : Name_Id; Nam : Name_Id;
Formal_DDT : Entity_Id;
Actual_DDT : Entity_Id;
begin begin
-- This subprogram is called directly from the semantics, so we need a -- This subprogram is called directly from the semantics, so we need a
...@@ -818,45 +1185,70 @@ package body Exp_Disp is ...@@ -818,45 +1185,70 @@ package body Exp_Disp is
Formal := First_Formal (Subp); Formal := First_Formal (Subp);
Actual := First_Actual (Call_Node); Actual := First_Actual (Call_Node);
while Present (Formal) loop while Present (Formal) loop
pragma Assert (Ekind (Etype (Etype (Formal)))
/= E_Record_Type_With_Private);
-- Ada 2005 (AI-251): Conversion to interface to force "this" -- Ada 2005 (AI-251): Conversion to interface to force "this"
-- displacement -- displacement.
Formal_Typ := Etype (Etype (Formal)); Formal_Typ := Etype (Etype (Formal));
if Ekind (Formal_Typ) = E_Record_Type_With_Private then
Formal_Typ := Full_View (Formal_Typ);
end if;
if Is_Access_Type (Formal_Typ) then
Formal_DDT := Directly_Designated_Type (Formal_Typ);
end if;
Actual_Typ := Etype (Actual); Actual_Typ := Etype (Actual);
if Is_Access_Type (Actual_Typ) then
Actual_DDT := Directly_Designated_Type (Actual_Typ);
end if;
if Is_Interface (Formal_Typ) then if Is_Interface (Formal_Typ) then
Conversion := Convert_To (Formal_Typ, New_Copy_Tree (Actual)); -- No need to displace the pointer if the type of the actual
Rewrite (Actual, Conversion); -- is class-wide of the formal-type interface; in this case the
Analyze_And_Resolve (Actual, Formal_Typ); -- displacement of the pointer was already done at the point of
-- the call to the enclosing subprogram. This case corresponds
-- with the call to P (Obj) in the following example:
Rewrite (Actual, -- type I is interface;
Make_Explicit_Dereference (Loc, -- procedure P (X : I) is abstract;
Unchecked_Convert_To
(Build_Anonymous_Access_Type (Formal_Typ, Call_Node), -- procedure General_Op (Obj : I'Class) is
Relocate_Node (Expression (Actual))))); -- begin
-- P (Obj);
-- end General_Op;
if Is_Class_Wide_Type (Actual_Typ)
and then Etype (Actual_Typ) = Formal_Typ
then
null;
-- No need to displace the pointer if the type of the actual is a
-- derivation of the formal-type interface because in this case
-- the interface primitives are located in the primary dispatch
-- table.
elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
null;
else
Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ); Analyze_And_Resolve (Actual, Formal_Typ);
end if;
-- Anonymous access type -- Anonymous access type
elsif Is_Access_Type (Formal_Typ) elsif Is_Access_Type (Formal_Typ)
and then Is_Interface (Etype and then Is_Interface (Etype (Formal_DDT))
(Directly_Designated_Type
(Formal_Typ)))
and then Interface_Present_In_Ancestor and then Interface_Present_In_Ancestor
(Typ => Etype (Directly_Designated_Type (Typ => Actual_DDT,
(Actual_Typ)), Iface => Etype (Formal_DDT))
Iface => Etype (Directly_Designated_Type
(Formal_Typ)))
then then
if Nkind (Actual) = N_Attribute_Reference if Nkind (Actual) = N_Attribute_Reference
and then and then
(Attribute_Name (Actual) = Name_Access (Attribute_Name (Actual) = Name_Access
...@@ -864,28 +1256,84 @@ package body Exp_Disp is ...@@ -864,28 +1256,84 @@ package body Exp_Disp is
then then
Nam := Attribute_Name (Actual); Nam := Attribute_Name (Actual);
Conversion := Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual));
Convert_To
(Etype (Directly_Designated_Type (Formal_Typ)),
Prefix (Actual));
Rewrite (Actual, Conversion); Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Etype (Formal_DDT));
Analyze_And_Resolve (Actual,
Etype (Directly_Designated_Type (Formal_Typ)));
Rewrite (Actual, Rewrite (Actual,
Unchecked_Convert_To (Formal_Typ, Unchecked_Convert_To (Formal_Typ,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix => Relocate_Node (Actual),
Relocate_Node (Prefix (Expression (Actual))),
Attribute_Name => Nam))); Attribute_Name => Nam)));
Analyze_And_Resolve (Actual, Formal_Typ); Analyze_And_Resolve (Actual, Formal_Typ);
-- No need to displace the pointer if the actual is a class-wide
-- type of the formal-type interface because in this case the
-- displacement of the pointer was already done at the point of
-- the call to the enclosing subprogram (this case is similar
-- to the example described above for the non access-type case)
elsif Is_Class_Wide_Type (Actual_DDT)
and then Etype (Actual_DDT) = Formal_DDT
then
null;
-- No need to displace the pointer if the type of the actual is a
-- derivation of the interface (because in this case the interface
-- primitives are located in the primary dispatch table)
elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
null;
else else
Conversion := Actual_Dup := Relocate_Node (Actual);
Convert_To (Formal_Typ, New_Copy_Tree (Actual));
if From_With_Type (Actual_Typ) then
-- If the type of the actual parameter comes from a limited
-- with-clause and the non-limited view is already available
-- we replace the anonymous access type by a duplicate decla
-- ration whose designated type is the non-limited view
if Ekind (Actual_DDT) = E_Incomplete_Type
and then Present (Non_Limited_View (Actual_DDT))
then
Anon := New_Copy (Actual_Typ);
if Is_Itype (Anon) then
Set_Scope (Anon, Current_Scope);
end if;
Set_Directly_Designated_Type (Anon,
Non_Limited_View (Actual_DDT));
Set_Etype (Actual_Dup, Anon);
elsif Is_Class_Wide_Type (Actual_DDT)
and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
and then Present (Non_Limited_View (Etype (Actual_DDT)))
then
Anon := New_Copy (Actual_Typ);
if Is_Itype (Anon) then
Set_Scope (Anon, Current_Scope);
end if;
Set_Directly_Designated_Type (Anon,
New_Copy (Actual_DDT));
Set_Class_Wide_Type (Directly_Designated_Type (Anon),
New_Copy (Class_Wide_Type (Actual_DDT)));
Set_Etype (Directly_Designated_Type (Anon),
Non_Limited_View (Etype (Actual_DDT)));
Set_Etype (
Class_Wide_Type (Directly_Designated_Type (Anon)),
Non_Limited_View (Etype (Actual_DDT)));
Set_Etype (Actual_Dup, Anon);
end if;
end if;
Conversion := Convert_To (Formal_Typ, Actual_Dup);
Rewrite (Actual, Conversion); Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ); Analyze_And_Resolve (Actual, Formal_Typ);
end if; end if;
...@@ -904,40 +1352,38 @@ package body Exp_Disp is ...@@ -904,40 +1352,38 @@ package body Exp_Disp is
(N : Node_Id; (N : Node_Id;
Thunk_Alias : Entity_Id; Thunk_Alias : Entity_Id;
Thunk_Id : Entity_Id; Thunk_Id : Entity_Id;
Iface_Tag : Entity_Id) return Node_Id Thunk_Tag : Entity_Id) return Node_Id
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Actuals : constant List_Id := New_List; Actuals : constant List_Id := New_List;
Decl : constant List_Id := New_List; Decl : constant List_Id := New_List;
Formals : constant List_Id := New_List; Formals : constant List_Id := New_List;
Thunk_Tag : constant Node_Id := Iface_Tag;
Target : Entity_Id; Target : Entity_Id;
New_Code : Node_Id; New_Code : Node_Id;
Formal : Node_Id; Formal : Node_Id;
New_Formal : Node_Id; New_Formal : Node_Id;
Decl_1 : Node_Id; Decl_1 : Node_Id;
Decl_2 : Node_Id; Decl_2 : Node_Id;
Subtyp_Mark : Node_Id; E : Entity_Id;
begin begin
-- Traverse the list of alias to find the final target -- Traverse the list of alias to find the final target
Target := Thunk_Alias; Target := Thunk_Alias;
while Present (Alias (Target)) loop while Present (Alias (Target)) loop
Target := Alias (Target); Target := Alias (Target);
end loop; end loop;
-- Duplicate the formals -- Duplicate the formals
Formal := First_Formal (Thunk_Alias); Formal := First_Formal (Target);
E := First_Formal (N);
while Present (Formal) loop while Present (Formal) loop
New_Formal := Copy_Separate_Tree (Parent (Formal)); New_Formal := Copy_Separate_Tree (Parent (Formal));
-- Handle the case in which the subprogram covering -- Propagate the parameter type to the copy. This is required to
-- the interface has been inherited: -- properly handle the case in which the subprogram covering the
-- interface has been inherited:
-- Example: -- Example:
-- type I is interface; -- type I is interface;
...@@ -948,20 +1394,17 @@ package body Exp_Disp is ...@@ -948,20 +1394,17 @@ package body Exp_Disp is
-- type DT is new T and I with ... -- type DT is new T and I with ...
if Is_Controlling_Formal (Formal) then Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc));
Set_Parameter_Type (New_Formal,
New_Reference_To (Etype (First_Entity (N)), Loc));
end if;
Append_To (Formals, New_Formal); Append_To (Formals, New_Formal);
Next_Formal (Formal); Next_Formal (Formal);
Next_Formal (E);
end loop; end loop;
if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter if Ekind (First_Formal (Target)) = E_In_Parameter
and then Ekind (Etype (First_Formal (Thunk_Alias))) and then Ekind (Etype (First_Formal (Target)))
= E_Anonymous_Access_Type = E_Anonymous_Access_Type
then then
-- Generate: -- Generate:
-- type T is access all <<type of the first formal>> -- type T is access all <<type of the first formal>>
...@@ -983,8 +1426,7 @@ package body Exp_Disp is ...@@ -983,8 +1426,7 @@ package body Exp_Disp is
Subtype_Indication => Subtype_Indication =>
New_Reference_To New_Reference_To
(Directly_Designated_Type (Directly_Designated_Type
(Etype (First_Formal (Thunk_Alias))), Loc) (Etype (First_Formal (Target))), Loc)));
));
Decl_1 := Decl_1 :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -1095,7 +1537,7 @@ package body Exp_Disp is ...@@ -1095,7 +1537,7 @@ package body Exp_Disp is
Next (Formal); Next (Formal);
end loop; end loop;
if Ekind (Thunk_Alias) = E_Procedure then if Ekind (Target) = E_Procedure then
New_Code := New_Code :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
...@@ -1110,23 +1552,7 @@ package body Exp_Disp is ...@@ -1110,23 +1552,7 @@ package body Exp_Disp is
Name => New_Occurrence_Of (Target, Loc), Name => New_Occurrence_Of (Target, Loc),
Parameter_Associations => Actuals)))); Parameter_Associations => Actuals))));
else pragma Assert (Ekind (Thunk_Alias) = E_Function); else pragma Assert (Ekind (Target) = E_Function);
if not Present (Alias (Thunk_Alias)) then
Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias));
else
-- The last element in the alias list has the correct subtype_mark
-- of the function result
declare
E : Entity_Id := Alias (Thunk_Alias);
begin
while Present (Alias (E)) loop
E := Alias (E);
end loop;
Subtyp_Mark := Subtype_Mark (Parent (E));
end;
end if;
New_Code := New_Code :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
...@@ -1134,7 +1560,8 @@ package body Exp_Disp is ...@@ -1134,7 +1560,8 @@ package body Exp_Disp is
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => Thunk_Id, Defining_Unit_Name => Thunk_Id,
Parameter_Specifications => Formals, Parameter_Specifications => Formals,
Subtype_Mark => New_Copy (Subtyp_Mark)), Result_Definition =>
New_Copy (Result_Definition (Parent (Target)))),
Declarations => Decl, Declarations => Decl,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
...@@ -1234,6 +1661,49 @@ package body Exp_Disp is ...@@ -1234,6 +1661,49 @@ package body Exp_Disp is
Selector_Name => Make_Identifier (Loc, Name_uTag)))); Selector_Name => Make_Identifier (Loc, Name_uTag))));
end Get_Remotely_Callable; end Get_Remotely_Callable;
------------------------------------------
-- Init_Predefined_Interface_Primitives --
------------------------------------------
function Init_Predefined_Interface_Primitives
(Typ : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
DT_Ptr : constant Node_Id :=
Node (First_Elmt (Access_Disp_Table (Typ)));
Result : constant List_Id := New_List;
AI : Elmt_Id;
begin
-- No need to inherit primitives if it an abstract interface type
if Is_Interface (Typ) then
return Result;
end if;
AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
while Present (AI) loop
-- All the secondary tables inherit the dispatch table entries
-- associated with predefined primitives.
-- Generate:
-- Inherit_DT (T'Tag, Iface'Tag, Default_Prim_Op_Count);
Append_To (Result,
Make_DT_Access_Action (Typ,
Action => Inherit_DT,
Args => New_List (
Node1 => New_Reference_To (DT_Ptr, Loc),
Node2 => Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Node (AI), Loc)),
Node3 => Make_Integer_Literal (Loc, Default_Prim_Op_Count))));
Next_Elmt (AI);
end loop;
return Result;
end Init_Predefined_Interface_Primitives;
------------- -------------
-- Make_DT -- -- Make_DT --
------------- -------------
...@@ -1284,7 +1754,6 @@ package body Exp_Disp is ...@@ -1284,7 +1754,6 @@ package body Exp_Disp is
Num_Ifaces := 0; Num_Ifaces := 0;
AI := First_Elmt (Abstract_Interfaces (Typ_Copy)); AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
while Present (AI) loop while Present (AI) loop
Num_Ifaces := Num_Ifaces + 1; Num_Ifaces := Num_Ifaces + 1;
Next_Elmt (AI); Next_Elmt (AI);
...@@ -1300,7 +1769,6 @@ package body Exp_Disp is ...@@ -1300,7 +1769,6 @@ package body Exp_Disp is
begin begin
I_Depth := 0; I_Depth := 0;
loop loop
P := Etype (Parent_Type); P := Etype (Parent_Type);
...@@ -1315,9 +1783,25 @@ package body Exp_Disp is ...@@ -1315,9 +1783,25 @@ package body Exp_Disp is
end loop; end loop;
end; end;
TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
-- Ada 2005 (AI-345): The size of the TSD is increased to accomodate
-- the two tables used for dispatching in asynchronous, conditional
-- and timed selects. The tables are solely generated for limited
-- types that implement a limited interface.
if Ada_Version >= Ada_05
and then not Is_Interface (Typ)
and then not Is_Abstract (Typ)
and then not Is_Controlled (Typ)
and then Implements_Limited_Interface (Typ)
then
TSD_Num_Entries := I_Depth + Num_Ifaces + 1 +
2 * (Nb_Prim - Default_Prim_Op_Count);
else
TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
end if;
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
-- Dispatch table and related entities are allocated statically -- Dispatch table and related entities are allocated statically
...@@ -1400,7 +1884,7 @@ package body Exp_Disp is ...@@ -1400,7 +1884,7 @@ package body Exp_Disp is
-- Generate code to define the boolean that controls registration, in -- Generate code to define the boolean that controls registration, in
-- order to avoid multiple registrations for tagged types defined in -- order to avoid multiple registrations for tagged types defined in
-- multiple-called scopes -- multiple-called scopes.
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -1418,7 +1902,7 @@ package body Exp_Disp is ...@@ -1418,7 +1902,7 @@ package body Exp_Disp is
-- Generate code to create the storage for the type specific data object -- Generate code to create the storage for the type specific data object
-- with enough space to store the tags of the ancestors plus the tags -- with enough space to store the tags of the ancestors plus the tags
-- of all the implemented interfaces (as described in a-tags.adb) -- of all the implemented interfaces (as described in a-tags.adb).
-- --
-- TSD: Storage_Array -- TSD: Storage_Array
-- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size); -- (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
...@@ -1532,6 +2016,10 @@ package body Exp_Disp is ...@@ -1532,6 +2016,10 @@ package body Exp_Disp is
(Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc); (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
end if; end if;
if Typ /= Etype (Typ)
and then not Is_Interface (Typ)
and then not Is_Interface (Etype (Typ))
then
-- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent); -- Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
Append_To (Elab_Code, Append_To (Elab_Code,
...@@ -1540,7 +2028,8 @@ package body Exp_Disp is ...@@ -1540,7 +2028,8 @@ package body Exp_Disp is
Args => New_List ( Args => New_List (
Node1 => Old_Tag1, Node1 => Old_Tag1,
Node2 => New_Reference_To (DT_Ptr, Loc), Node2 => New_Reference_To (DT_Ptr, Loc),
Node3 => Make_Integer_Literal (Loc, Node3 =>
Make_Integer_Literal (Loc,
DT_Entry_Count (First_Tag_Component (Etype (Typ))))))); DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
-- Inherit the secondary dispatch tables of the ancestor -- Inherit the secondary dispatch tables of the ancestor
...@@ -1548,12 +2037,17 @@ package body Exp_Disp is ...@@ -1548,12 +2037,17 @@ package body Exp_Disp is
if not Is_CPP_Class (Etype (Typ)) then if not Is_CPP_Class (Etype (Typ)) then
declare declare
Sec_DT_Ancestor : Elmt_Id := Sec_DT_Ancestor : Elmt_Id :=
Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ)))); Next_Elmt
(First_Elmt
(Access_Disp_Table (Etype (Typ))));
Sec_DT_Typ : Elmt_Id := Sec_DT_Typ : Elmt_Id :=
Next_Elmt (First_Elmt (Access_Disp_Table (Typ))); Next_Elmt
(First_Elmt
(Access_Disp_Table (Typ)));
procedure Copy_Secondary_DTs (Typ : Entity_Id); procedure Copy_Secondary_DTs (Typ : Entity_Id);
-- ??? comment required -- Local procedure required to climb through the ancestors and
-- copy the contents of all their secondary dispatch tables.
------------------------ ------------------------
-- Copy_Secondary_DTs -- -- Copy_Secondary_DTs --
...@@ -1572,7 +2066,6 @@ package body Exp_Disp is ...@@ -1572,7 +2066,6 @@ package body Exp_Disp is
(Abstract_Interfaces (Typ)) (Abstract_Interfaces (Typ))
then then
E := First_Entity (Typ); E := First_Entity (Typ);
while Present (E) while Present (E)
and then Present (Node (Sec_DT_Ancestor)) and then Present (Node (Sec_DT_Ancestor))
loop loop
...@@ -1607,8 +2100,10 @@ package body Exp_Disp is ...@@ -1607,8 +2100,10 @@ package body Exp_Disp is
end if; end if;
end; end;
end if; end if;
end if;
-- Generate: Inherit_TSD (parent'tag, DT_Ptr); -- Generate:
-- Inherit_TSD (parent'tag, DT_Ptr);
Append_To (Elab_Code, Append_To (Elab_Code,
Make_DT_Access_Action (Typ, Make_DT_Access_Action (Typ,
...@@ -1962,6 +2457,832 @@ package body Exp_Disp is ...@@ -1962,6 +2457,832 @@ package body Exp_Disp is
end if; end if;
end Make_DT_Access_Action; end Make_DT_Access_Action;
----------------------------------------
-- Make_Disp_Asynchronous_Select_Body --
----------------------------------------
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id
is
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id;
DT_Ptr_Typ : Entity_Id;
Loc : constant Source_Ptr := Sloc (Typ);
Stmts : constant List_Id := New_List;
begin
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
end if;
-- Typ may be a derived type, climb the derivation chain in order to
-- find the root.
DT_Ptr_Typ := Typ;
while Present (Parent_Subtype (DT_Ptr_Typ)) loop
DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
end loop;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
if Present (Conc_Typ) then
-- Generate:
-- I : Integer := get_entry_index (tag! (<type>VP), S);
-- where I will be used to capture the entry index of the primitive
-- wrapper at position S.
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uI),
Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
Expression =>
Make_DT_Access_Action (Typ,
Action =>
Get_Entry_Index,
Args =>
New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)),
Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate:
-- Protected_Entry_Call (
-- T._object'access,
-- protected_entry_index! (I),
-- P,
-- Asynchronous_Call,
-- B);
-- where T is the protected object, I is the entry index, P are
-- the wrapped parameters and B is the name of the communication
-- block.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- T._object'access
Attribute_Name =>
Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Reference_To ( -- Asynchronous_Call
RTE (RE_Asynchronous_Call), Loc),
Make_Identifier (Loc, Name_uB)))); -- comm block
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
-- Generate:
-- Protected_Entry_Call (
-- T._task_id,
-- task_entry_index! (I),
-- P,
-- Conditional_Call,
-- F);
-- where T is the task object, I is the entry index, P are the
-- wrapped parameters and F is the status flag.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Selected_Component (Loc, -- T._task_id
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uTask_Id)),
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Reference_To ( -- Asynchronous_Call
RTE (RE_Asynchronous_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
-- Null implementation for limited tagged types
else
Append_To (Stmts,
Make_Null_Statement (Loc));
end if;
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Asynchronous_Select_Spec (Typ),
Declarations =>
Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Asynchronous_Select_Body;
----------------------------------------
-- Make_Disp_Asynchronous_Select_Spec --
----------------------------------------
function Make_Disp_Asynchronous_Select_Spec
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Params : constant List_Id := New_List;
begin
-- "T" - Object parameter
-- "S" - Primitive operation slot
-- "P" - Wrapped parameters
-- "B" - Communication block
-- "F" - Status flag
SEU.Build_T (Loc, Typ, Params);
SEU.Build_S (Loc, Params);
SEU.Build_P (Loc, Params);
SEU.Build_B (Loc, Params);
SEU.Build_F (Loc, Params);
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select),
Parameter_Specifications =>
Params);
end Make_Disp_Asynchronous_Select_Spec;
---------------------------------------
-- Make_Disp_Conditional_Select_Body --
---------------------------------------
function Make_Disp_Conditional_Select_Body
(Typ : Entity_Id) return Node_Id
is
Blk_Nam : Entity_Id;
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id;
DT_Ptr_Typ : Entity_Id;
Loc : constant Source_Ptr := Sloc (Typ);
Stmts : constant List_Id := New_List;
begin
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
end if;
-- Typ may be a derived type, climb the derivation chain in order to
-- find the root.
DT_Ptr_Typ := Typ;
while Present (Parent_Subtype (DT_Ptr_Typ)) loop
DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
end loop;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
if Present (Conc_Typ) then
-- Generate:
-- I : Integer;
-- where I will be used to capture the entry index of the primitive
-- wrapper at position S.
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uI),
Object_Definition =>
New_Reference_To (Standard_Integer, Loc)));
end if;
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
-- then
-- F := True;
-- return;
-- end if;
SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
if Present (Conc_Typ) then
-- Generate:
-- Bnn : Communication_Block;
-- where Bnn is the name of the communication block used in
-- the call to Protected_Entry_Call.
Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Blk_Nam,
Object_Definition =>
New_Reference_To (RTE (RE_Communication_Block), Loc)));
-- Generate:
-- I := get_entry_index (tag! (<type>VP), S);
-- where I is the entry index and S is the dispatch table slot.
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uI),
Expression =>
Make_DT_Access_Action (Typ,
Action =>
Get_Entry_Index,
Args =>
New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)),
Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate:
-- Protected_Entry_Call (
-- T._object'access,
-- protected_entry_index! (I),
-- P,
-- Conditional_Call,
-- Bnn);
-- where T is the protected object, I is the entry index, P are
-- the wrapped parameters and Bnn is the name of the communication
-- block.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- T._object'access
Attribute_Name =>
Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Reference_To ( -- Conditional_Call
RTE (RE_Conditional_Call), Loc),
New_Reference_To ( -- Bnn
Blk_Nam, Loc))));
-- Generate:
-- F := not Cancelled (Bnn);
-- where F is the success flag. The status of Cancelled is negated
-- in order to match the behaviour of the version for task types.
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uF),
Expression =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Cancelled), Loc),
Parameter_Associations =>
New_List (
New_Reference_To (Blk_Nam, Loc))))));
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
-- Generate:
-- Protected_Entry_Call (
-- T._task_id,
-- task_entry_index! (I),
-- P,
-- Conditional_Call,
-- F);
-- where T is the task object, I is the entry index, P are the
-- wrapped parameters and F is the status flag.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Selected_Component (Loc, -- T._task_id
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uTask_Id)),
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
New_Reference_To ( -- Conditional_Call
RTE (RE_Conditional_Call), Loc),
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
-- Null implementation for limited tagged types
else
Append_To (Stmts,
Make_Null_Statement (Loc));
end if;
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Conditional_Select_Spec (Typ),
Declarations =>
Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Conditional_Select_Body;
---------------------------------------
-- Make_Disp_Conditional_Select_Spec --
---------------------------------------
function Make_Disp_Conditional_Select_Spec
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Params : constant List_Id := New_List;
begin
-- "T" - Object parameter
-- "S" - Primitive operation slot
-- "P" - Wrapped parameters
-- "C" - Call kind
-- "F" - Status flag
SEU.Build_T (Loc, Typ, Params);
SEU.Build_S (Loc, Params);
SEU.Build_P (Loc, Params);
SEU.Build_C (Loc, Params);
SEU.Build_F (Loc, Params);
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Name_uDisp_Conditional_Select),
Parameter_Specifications =>
Params);
end Make_Disp_Conditional_Select_Spec;
-------------------------------------
-- Make_Disp_Get_Prim_Op_Kind_Body --
-------------------------------------
function Make_Disp_Get_Prim_Op_Kind_Body
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
DT_Ptr : Entity_Id;
DT_Ptr_Typ : Entity_Id;
begin
-- Typ may be a derived type, climb the derivation chain in order to
-- find the root.
DT_Ptr_Typ := Typ;
while Present (Parent_Subtype (DT_Ptr_Typ)) loop
DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
end loop;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
-- where C is the out parameter capturing the call kind and S is the
-- dispatch table slot number.
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
Declarations =>
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uC),
Expression =>
Make_DT_Access_Action (Typ,
Action =>
Get_Prim_Op_Kind,
Args =>
New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)),
Make_Identifier (Loc, Name_uS)))))));
end Make_Disp_Get_Prim_Op_Kind_Body;
-------------------------------------
-- Make_Disp_Get_Prim_Op_Kind_Spec --
-------------------------------------
function Make_Disp_Get_Prim_Op_Kind_Spec
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Params : constant List_Id := New_List;
begin
-- "T" - Object parameter
-- "S" - Primitive operation slot
-- "C" - Call kind
SEU.Build_T (Loc, Typ, Params);
SEU.Build_S (Loc, Params);
SEU.Build_C (Loc, Params);
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind),
Parameter_Specifications =>
Params);
end Make_Disp_Get_Prim_Op_Kind_Spec;
-----------------------------
-- Make_Disp_Select_Tables --
-----------------------------
function Make_Disp_Select_Tables
(Typ : Entity_Id) return List_Id
is
Assignments : constant List_Id := New_List;
DT_Ptr : Entity_Id;
DT_Ptr_Typ : Entity_Id;
Index : Uint := Uint_1;
Loc : constant Source_Ptr := Sloc (Typ);
Prim : Entity_Id;
Prim_Als : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Pos : Uint;
begin
pragma Assert (Present (Primitive_Operations (Typ)));
-- Typ may be a derived type, climb the derivation chain in order to
-- find the root.
DT_Ptr_Typ := Typ;
while Present (Parent_Subtype (DT_Ptr_Typ)) loop
DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
end loop;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
-- Retrieve the root of the alias chain
if Present (Alias (Prim)) then
Prim_Als := Prim;
while Present (Alias (Prim_Als)) loop
Prim_Als := Alias (Prim_Als);
end loop;
else
Prim_Als := Empty;
end if;
-- We either have a procedure or a wrapper. Set the primitive
-- operation kind for both cases and set the entry index for
-- wrappers.
if Ekind (Prim) = E_Procedure
and then Present (Prim_Als)
and then Is_Primitive_Wrapper (Prim_Als)
then
Prim_Pos := DT_Position (Prim);
-- Generate:
-- set_prim_op_kind (<tag>, <position>, <kind>);
Append_To (Assignments,
Make_DT_Access_Action (Typ,
Action =>
Set_Prim_Op_Kind,
Args =>
New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)),
Make_Integer_Literal (Loc, Prim_Pos),
Prim_Op_Kind (Prim, Typ))));
-- The wrapped entity of the alias is an entry
if Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then
-- Generate:
-- set_entry_index (<tag>, <position>, <index>);
Append_To (Assignments,
Make_DT_Access_Action (Typ,
Action =>
Set_Entry_Index,
Args =>
New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)),
Make_Integer_Literal (Loc, Prim_Pos),
Make_Integer_Literal (Loc, Index))));
Index := Index + 1;
end if;
end if;
Next_Elmt (Prim_Elmt);
end loop;
return Assignments;
end Make_Disp_Select_Tables;
---------------------------------
-- Make_Disp_Timed_Select_Body --
---------------------------------
function Make_Disp_Timed_Select_Body
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Conc_Typ : Entity_Id := Empty;
Decls : constant List_Id := New_List;
DT_Ptr : Entity_Id;
DT_Ptr_Typ : Entity_Id;
Stmts : constant List_Id := New_List;
begin
if Is_Concurrent_Record_Type (Typ) then
Conc_Typ := Corresponding_Concurrent_Type (Typ);
end if;
-- Typ may be a derived type, climb the derivation chain in order to
-- find the root.
DT_Ptr_Typ := Typ;
while Present (Parent_Subtype (DT_Ptr_Typ)) loop
DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
end loop;
DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
if Present (Conc_Typ) then
-- Generate:
-- I : Integer;
-- where I will be used to capture the entry index of the primitive
-- wrapper at position S.
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uI),
Object_Definition =>
New_Reference_To (Standard_Integer, Loc)));
end if;
-- Generate:
-- C := get_prim_op_kind (tag! (<type>VP), S);
-- if C = POK_Procedure
-- or else C = POK_Protected_Procedure
-- or else C = POK_Task_Procedure;
-- then
-- F := True;
-- return;
-- end if;
SEU.Build_Common_Dispatching_Select_Statements (Loc, Typ, Stmts);
if Present (Conc_Typ) then
-- Generate:
-- I := get_entry_index (tag! (<type>VP), S);
-- where I is the entry index and S is the dispatch table slot.
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
Make_Identifier (Loc, Name_uI),
Expression =>
Make_DT_Access_Action (Typ,
Action =>
Get_Entry_Index,
Args =>
New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (DT_Ptr, Loc)),
Make_Identifier (Loc, Name_uS)))));
if Ekind (Conc_Typ) = E_Protected_Type then
-- Generate:
-- Timed_Protected_Entry_Call (
-- T._object'access,
-- protected_entry_index! (I),
-- P,
-- D,
-- M,
-- F);
-- where T is the protected object, I is the entry index, P are
-- the wrapped parameters, D is the delay amount, M is the delay
-- mode and F is the status flag.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Attribute_Reference (Loc, -- T._object'access
Attribute_Name =>
Name_Unchecked_Access,
Prefix =>
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uObject))),
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
else
pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
-- Generate:
-- Timed_Task_Entry_Call (
-- T._task_id,
-- task_entry_index! (I),
-- P,
-- D,
-- M,
-- F);
-- where T is the task object, I is the entry index, P are the
-- wrapped parameters, D is the delay amount, M is the delay
-- mode and F is the status flag.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Make_Selected_Component (Loc, -- T._task_id
Prefix =>
Make_Identifier (Loc, Name_uT),
Selector_Name =>
Make_Identifier (Loc, Name_uTask_Id)),
Make_Unchecked_Type_Conversion (Loc, -- entry index
Subtype_Mark =>
New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
Expression =>
Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
end if;
-- Null implementation for limited tagged types
else
Append_To (Stmts,
Make_Null_Statement (Loc));
end if;
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Timed_Select_Spec (Typ),
Declarations =>
Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Timed_Select_Body;
---------------------------------
-- Make_Disp_Timed_Select_Spec --
---------------------------------
function Make_Disp_Timed_Select_Spec
(Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Typ);
Params : constant List_Id := New_List;
begin
-- "T" - Object parameter
-- "S" - Primitive operation slot
-- "P" - Wrapped parameters
-- "D" - Delay
-- "M" - Delay Mode
-- "C" - Call kind
-- "F" - Status flag
SEU.Build_T (Loc, Typ, Params);
SEU.Build_S (Loc, Params);
SEU.Build_P (Loc, Params);
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uD),
Parameter_Type =>
New_Reference_To (Standard_Duration, Loc)));
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uM),
Parameter_Type =>
New_Reference_To (Standard_Integer, Loc)));
SEU.Build_C (Loc, Params);
SEU.Build_F (Loc, Params);
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Name_uDisp_Timed_Select),
Parameter_Specifications =>
Params);
end Make_Disp_Timed_Select_Spec;
----------------------------------- -----------------------------------
-- Original_View_In_Visible_Part -- -- Original_View_In_Visible_Part --
----------------------------------- -----------------------------------
...@@ -1989,6 +3310,86 @@ package body Exp_Disp is ...@@ -1989,6 +3310,86 @@ package body Exp_Disp is
Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
end Original_View_In_Visible_Part; end Original_View_In_Visible_Part;
------------------
-- Prim_Op_Kind --
------------------
function Prim_Op_Kind
(Prim : Entity_Id;
Typ : Entity_Id) return Node_Id
is
Full_Typ : Entity_Id := Typ;
Loc : constant Source_Ptr := Sloc (Prim);
Prim_Op : Entity_Id := Prim;
begin
-- Retrieve the original primitive operation
while Present (Alias (Prim_Op)) loop
Prim_Op := Alias (Prim_Op);
end loop;
if Ekind (Typ) = E_Record_Type
and then Present (Corresponding_Concurrent_Type (Typ))
then
Full_Typ := Corresponding_Concurrent_Type (Typ);
end if;
if Ekind (Prim_Op) = E_Function then
-- Protected function
if Ekind (Full_Typ) = E_Protected_Type then
return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
-- Regular function
else
return New_Reference_To (RTE (RE_POK_Function), Loc);
end if;
else
pragma Assert (Ekind (Prim_Op) = E_Procedure);
if Ekind (Full_Typ) = E_Protected_Type then
-- Protected entry
if Is_Primitive_Wrapper (Prim_Op)
and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
then
return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
-- Protected procedure
else
return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
end if;
elsif Ekind (Full_Typ) = E_Task_Type then
-- Task entry
if Is_Primitive_Wrapper (Prim_Op)
and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
then
return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
-- Task "procedure". These are the internally Expander-generated
-- procedures (task body for instance).
else
return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
end if;
-- Regular procedure
else
return New_Reference_To (RTE (RE_POK_Procedure), Loc);
end if;
end if;
end Prim_Op_Kind;
------------------------- -------------------------
-- Set_All_DT_Position -- -- Set_All_DT_Position --
------------------------- -------------------------
...@@ -2020,6 +3421,7 @@ package body Exp_Disp is ...@@ -2020,6 +3421,7 @@ package body Exp_Disp is
procedure Validate_Position (Prim : Entity_Id) is procedure Validate_Position (Prim : Entity_Id) is
Prim_Elmt : Elmt_Id; Prim_Elmt : Elmt_Id;
begin begin
Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
while Present (Prim_Elmt) while Present (Prim_Elmt)
...@@ -2043,8 +3445,41 @@ package body Exp_Disp is ...@@ -2043,8 +3445,41 @@ package body Exp_Disp is
null; null;
elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then
-- Handle aliased subprograms
declare
Op_1 : Entity_Id;
Op_2 : Entity_Id;
begin
Op_1 := Node (Prim_Elmt);
loop
if Present (Overridden_Operation (Op_1)) then
Op_1 := Overridden_Operation (Op_1);
elsif Present (Alias (Op_1)) then
Op_1 := Alias (Op_1);
else
exit;
end if;
end loop;
Op_2 := Prim;
loop
if Present (Overridden_Operation (Op_2)) then
Op_2 := Overridden_Operation (Op_2);
elsif Present (Alias (Op_2)) then
Op_2 := Alias (Op_2);
else
exit;
end if;
end loop;
if Op_1 /= Op_2 then
raise Program_Error; raise Program_Error;
end if; end if;
end;
end if;
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
end loop; end loop;
...@@ -2096,9 +3531,10 @@ package body Exp_Disp is ...@@ -2096,9 +3531,10 @@ package body Exp_Disp is
-- Get the slot from the parent subprogram if any -- Get the slot from the parent subprogram if any
declare declare
H : Entity_Id := Homonym (Prim); H : Entity_Id;
begin begin
H := Homonym (Prim);
while Present (H) loop while Present (H) loop
if Present (DTC_Entity (H)) if Present (DTC_Entity (H))
and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
...@@ -2129,7 +3565,7 @@ package body Exp_Disp is ...@@ -2129,7 +3565,7 @@ package body Exp_Disp is
-- Check that the declared size of the Vtable is bigger or equal -- Check that the declared size of the Vtable is bigger or equal
-- than the number of primitive operations (if bigger it means that -- than the number of primitive operations (if bigger it means that
-- some of the c++ virtual functions were not imported, that is -- some of the c++ virtual functions were not imported, that is
-- allowed) -- allowed).
if DT_Entry_Count (The_Tag) = No_Uint if DT_Entry_Count (The_Tag) = No_Uint
or else not Is_CPP_Class (Typ) or else not Is_CPP_Class (Typ)
...@@ -2142,7 +3578,7 @@ package body Exp_Disp is ...@@ -2142,7 +3578,7 @@ package body Exp_Disp is
end if; end if;
-- Check that Positions are not duplicate nor outside the range of -- Check that Positions are not duplicate nor outside the range of
-- the Vtable -- the Vtable.
declare declare
Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag)); Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
...@@ -2175,13 +3611,19 @@ package body Exp_Disp is ...@@ -2175,13 +3611,19 @@ package body Exp_Disp is
end loop; end loop;
end; end;
-- Generate listing showing the contents of the dispatch tables
if Debug_Flag_ZZ then
Write_DT (Typ);
end if;
-- For regular Ada tagged types, just set the DT_Position for -- For regular Ada tagged types, just set the DT_Position for
-- each primitive operation. Perform some sanity checks to avoid -- each primitive operation. Perform some sanity checks to avoid
-- to build completely inconsistant dispatch tables. -- to build completely inconsistant dispatch tables.
-- Note that the _Size primitive is always set at position 1 in order -- Note that the _Size primitive is always set at position 1 in order
-- to comply with the needs of Ada.Tags.Parent_Size (see documentation -- to comply with the needs of Ada.Tags.Parent_Size (see documentation
-- in a-tags.ad?) -- in Ada.Tags).
else else
-- First stage: Set the DTC entity of all the primitive operations -- First stage: Set the DTC entity of all the primitive operations
...@@ -2190,7 +3632,6 @@ package body Exp_Disp is ...@@ -2190,7 +3632,6 @@ package body Exp_Disp is
Prim_Elmt := First_Prim; Prim_Elmt := First_Prim;
Count_Prim := 0; Count_Prim := 0;
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Count_Prim := Count_Prim + 1; Count_Prim := Count_Prim + 1;
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
...@@ -2218,16 +3659,17 @@ package body Exp_Disp is ...@@ -2218,16 +3659,17 @@ package body Exp_Disp is
end loop; end loop;
declare declare
Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim) Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count +
Parent_EC + Count_Prim)
of Boolean := (others => False); of Boolean := (others => False);
E : Entity_Id; E : Entity_Id;
begin begin
-- Second stage: Register fixed entries -- Second stage: Register fixed entries
Nb_Prim := 10; Nb_Prim := Default_Prim_Op_Count;
Prim_Elmt := First_Prim; Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
...@@ -2287,13 +3729,11 @@ package body Exp_Disp is ...@@ -2287,13 +3729,11 @@ package body Exp_Disp is
-- traversing the chain. This is required to properly -- traversing the chain. This is required to properly
-- handling renamed primitives -- handling renamed primitives
if Present (Alias (E)) then
while Present (Alias (E)) loop while Present (Alias (E)) loop
E := Alias (E); E := Alias (E);
Fixed_Prim (UI_To_Int (DT_Position (E))) := True; Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
end loop; end loop;
end if; end if;
end if;
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
end loop; end loop;
...@@ -2369,12 +3809,20 @@ package body Exp_Disp is ...@@ -2369,12 +3809,20 @@ package body Exp_Disp is
Next_Elmt (Prim_Elmt); Next_Elmt (Prim_Elmt);
end loop; end loop;
-- Generate listing showing the contents of the dispatch tables.
-- This action is done before some further static checks because
-- in case of critical errors caused by a wrong dispatch table
-- we need to see the contents of such table.
if Debug_Flag_ZZ then
Write_DT (Typ);
end if;
-- Final stage: Ensure that the table is correct plus some further -- Final stage: Ensure that the table is correct plus some further
-- verifications concerning the primitives. -- verifications concerning the primitives.
Prim_Elmt := First_Prim; Prim_Elmt := First_Prim;
DT_Length := 0; DT_Length := 0;
while Present (Prim_Elmt) loop while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt); Prim := Node (Prim_Elmt);
...@@ -2473,10 +3921,6 @@ package body Exp_Disp is ...@@ -2473,10 +3921,6 @@ package body Exp_Disp is
null; null;
end if; end if;
end if; end if;
if Debug_Flag_ZZ then
Write_DT (Typ);
end if;
end Set_All_DT_Position; end Set_All_DT_Position;
----------------------------- -----------------------------
...@@ -2546,7 +3990,7 @@ package body Exp_Disp is ...@@ -2546,7 +3990,7 @@ package body Exp_Disp is
if not (Typ in First_Node_Id .. Last_Node_Id) if not (Typ in First_Node_Id .. Last_Node_Id)
or else not Is_Tagged_Type (Typ) or else not Is_Tagged_Type (Typ)
then then
Write_Str ("wrong usage: write_dt must be used with tagged types"); Write_Str ("wrong usage: Write_DT must be used with tagged types");
Write_Eol; Write_Eol;
return; return;
end if; end if;
......
...@@ -30,14 +30,26 @@ ...@@ -30,14 +30,26 @@
with Types; use Types; with Types; use Types;
package Exp_Disp is package Exp_Disp is
-- Number of predefined primitive operations added by the Expander
-- for a tagged type. If more predefined primitive operations are
-- added, the following items must be changed:
-- Ada.Tags.Defailt_Prim_Op_Count - indirect use
-- Exp_Disp.Default_Prim_Op_Position - indirect use
-- Exp_Disp.Set_All_DT_Position - direct use
Default_Prim_Op_Count : constant Int := 14;
type DT_Access_Action is type DT_Access_Action is
(CW_Membership, (CW_Membership,
IW_Membership, IW_Membership,
DT_Entry_Size, DT_Entry_Size,
DT_Prologue_Size, DT_Prologue_Size,
Get_Access_Level, Get_Access_Level,
Get_Entry_Index,
Get_External_Tag, Get_External_Tag,
Get_Prim_Op_Address, Get_Prim_Op_Address,
Get_Prim_Op_Kind,
Get_RC_Offset, Get_RC_Offset,
Get_Remotely_Callable, Get_Remotely_Callable,
Inherit_DT, Inherit_DT,
...@@ -45,15 +57,42 @@ package Exp_Disp is ...@@ -45,15 +57,42 @@ package Exp_Disp is
Register_Interface_Tag, Register_Interface_Tag,
Register_Tag, Register_Tag,
Set_Access_Level, Set_Access_Level,
Set_Entry_Index,
Set_Expanded_Name, Set_Expanded_Name,
Set_External_Tag, Set_External_Tag,
Set_Prim_Op_Address, Set_Prim_Op_Address,
Set_Prim_Op_Kind,
Set_RC_Offset, Set_RC_Offset,
Set_Remotely_Callable, Set_Remotely_Callable,
Set_TSD, Set_TSD,
TSD_Entry_Size, TSD_Entry_Size,
TSD_Prologue_Size); TSD_Prologue_Size);
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 the call is
-- done through the Vtable (tag checks are not relevant)
procedure Expand_Interface_Actuals (Call_Node : Node_Id);
-- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
-- interfaces to reference the interface tag of the actual object
procedure Expand_Interface_Conversion (N : Node_Id);
-- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
-- the object to give access to the interface tag associated with the
-- secondary dispatch table
function Expand_Interface_Thunk
(N : Node_Id;
Thunk_Alias : Node_Id;
Thunk_Id : Entity_Id;
Thunk_Tag : Entity_Id) return Node_Id;
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible
-- with the C++ ABI. The thunk modifies the value of the first actual of
-- the call (that is, the pointer to the object) before transferring
-- control to the target function.
function Fill_DT_Entry function Fill_DT_Entry
(Loc : Source_Ptr; (Loc : Source_Ptr;
Prim : Entity_Id) return Node_Id; Prim : Entity_Id) return Node_Id;
...@@ -69,6 +108,15 @@ package Exp_Disp is ...@@ -69,6 +108,15 @@ package Exp_Disp is
-- the secondary dispatch table of Prim's controlling type with Thunk_Id's -- the secondary dispatch table of Prim's controlling type with Thunk_Id's
-- address. -- address.
function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
-- Return an expression that holds True if the object can be transmitted
-- onto another partition according to E.4 (18)
function Init_Predefined_Interface_Primitives
(Typ : Entity_Id) return List_Id;
-- Ada 2005 (AI-251): Initialize the entries associated with predefined
-- primitives in all the secondary dispatch tables of Typ.
procedure Make_Abstract_Interface_DT procedure Make_Abstract_Interface_DT
(AI_Tag : Entity_Id; (AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id; Acc_Disp_Tables : in out Elist_Id;
...@@ -90,45 +138,65 @@ package Exp_Disp is ...@@ -90,45 +138,65 @@ package Exp_Disp is
-- Expand the declarations for the Dispatch Table (or the Vtable in -- Expand the declarations for the Dispatch Table (or the Vtable in
-- the case of type whose ancestor is a CPP_Class) -- the case of type whose ancestor is a CPP_Class)
function Make_Disp_Asynchronous_Select_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for dispatching in asynchronous selects.
function Make_Disp_Asynchronous_Select_Spec
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the specification of the primitive operation
-- of type Typ used for dispatching in asynchronous selects.
function Make_Disp_Conditional_Select_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for dispatching in conditional selects.
function Make_Disp_Conditional_Select_Spec
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the specification of the primitive operation
-- of type Typ used for dispatching in conditional selects.
function Make_Disp_Get_Prim_Op_Kind_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for retrieving the callable entity kind during dispatching in
-- asynchronous selects.
function Make_Disp_Get_Prim_Op_Kind_Spec
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the specification of the primitive operation
-- of the type Typ use for retrieving the callable entity kind during
-- dispatching in asynchronous selects.
function Make_Disp_Select_Tables
(Typ : Entity_Id) return List_Id;
-- Ada 2005 (AI-345): Populate the two auxiliary tables in the TSD of Typ
-- used for dispatching in asynchronous, conditional and timed selects.
-- Generate code to set the primitive operation kinds and entry indices
-- of primitive operations and primitive wrappers.
function Make_Disp_Timed_Select_Body
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the body of the primitive operation of type
-- Typ used for dispatching in timed selects.
function Make_Disp_Timed_Select_Spec
(Typ : Entity_Id) return Node_Id;
-- Ada 2005 (AI-345): Generate the specification of the primitive operation
-- of type Typ used for dispatching in timed selects.
procedure Set_All_DT_Position (Typ : Entity_Id); procedure Set_All_DT_Position (Typ : Entity_Id);
-- Set the DT_Position field for each primitive operation. In the CPP -- Set the DT_Position field for each primitive operation. In the CPP
-- Class case check that no pragma CPP_Virtual is missing and that the -- Class case check that no pragma CPP_Virtual is missing and that the
-- DT_Position are coherent -- DT_Position are coherent
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 the call is
-- done through the Vtable (tag checks are not relevant)
procedure Expand_Interface_Actuals (Call_Node : Node_Id);
-- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
-- interfaces to reference the interface tag of the actual object
procedure Expand_Interface_Conversion (N : Node_Id);
-- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
-- the object to give access to the interface tag associated with the
-- secondary dispatch table
function Expand_Interface_Thunk
(N : Node_Id;
Thunk_Alias : Node_Id;
Thunk_Id : Entity_Id;
Iface_Tag : Entity_Id) return Node_Id;
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) to have a layout compatible
-- with the C++ ABI. The thunk modifies the value of the first actual of
-- the call (that is, the pointer to the object) before transferring
-- control to the target function.
procedure Set_Default_Constructor (Typ : Entity_Id); procedure Set_Default_Constructor (Typ : Entity_Id);
-- Typ is a CPP_Class type. Create the Init procedure of that type to -- Typ is a CPP_Class type. Create the Init procedure of that type to
-- be the default constructor (i.e. the function returning this type, -- be the default constructor (i.e. the function returning this type,
-- having a pragma CPP_Constructor and no parameter) -- having a pragma CPP_Constructor and no parameter)
function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
-- Return an expression that holds True if the object can be transmitted
-- onto another partition according to E.4 (18)
procedure Write_DT (Typ : Entity_Id); procedure Write_DT (Typ : Entity_Id);
pragma Export (Ada, Write_DT); pragma Export (Ada, Write_DT);
-- Debugging procedure (to be called within gdb) -- Debugging procedure (to be called within gdb)
......
...@@ -31,8 +31,6 @@ with Elists; use Elists; ...@@ -31,8 +31,6 @@ with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr; with Exp_Aggr; use Exp_Aggr;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Tss; use Exp_Tss;
with Hostparm; use Hostparm; with Hostparm; use Hostparm;
with Inline; use Inline; with Inline; use Inline;
with Itypes; use Itypes; with Itypes; use Itypes;
...@@ -49,7 +47,6 @@ with Sem_Eval; use Sem_Eval; ...@@ -49,7 +47,6 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res; with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type; with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Stringt; use Stringt; with Stringt; use Stringt;
...@@ -685,7 +682,7 @@ package body Exp_Util is ...@@ -685,7 +682,7 @@ package body Exp_Util is
Spec := Make_Function_Specification (Loc, Spec := Make_Function_Specification (Loc,
Defining_Unit_Name => Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('F')), Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
Subtype_Mark => New_Occurrence_Of (Standard_String, Loc)); Result_Definition => New_Occurrence_Of (Standard_String, Loc));
-- Calls to 'Image use the secondary stack, which must be cleaned -- Calls to 'Image use the secondary stack, which must be cleaned
-- up after the task name is built. -- up after the task name is built.
...@@ -1278,6 +1275,13 @@ package body Exp_Util is ...@@ -1278,6 +1275,13 @@ package body Exp_Util is
then then
null; null;
-- Nothing to be done if the type of the expression is limited, because
-- in this case the expression cannot be copied, and its use can only
-- be by reference and there is no need for the actual subtype.
elsif Is_Limited_Type (Exp_Typ) then
null;
else else
Remove_Side_Effects (Exp); Remove_Side_Effects (Exp);
Rewrite (Subtype_Indic, Rewrite (Subtype_Indic,
...@@ -1409,7 +1413,7 @@ package body Exp_Util is ...@@ -1409,7 +1413,7 @@ package body Exp_Util is
and then Present (Abstract_Interfaces (Typ)) and then Present (Abstract_Interfaces (Typ))
and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
then then
-- Skip the tag associated with the primary table. -- Skip the tag associated with the primary table
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ)); AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
...@@ -1449,12 +1453,21 @@ package body Exp_Util is ...@@ -1449,12 +1453,21 @@ package body Exp_Util is
-- Handle task and protected types implementing interfaces -- Handle task and protected types implementing interfaces
if Ekind (Typ) = E_Protected_Type if Is_Concurrent_Type (Typ) then
or else Ekind (Typ) = E_Task_Type
then
Typ := Corresponding_Record_Type (Typ); Typ := Corresponding_Record_Type (Typ);
end if; end if;
if Is_Class_Wide_Type (Typ) then
Typ := Etype (Typ);
end if;
-- Handle entities from the limited view
if Ekind (Typ) = E_Incomplete_Type then
pragma Assert (Present (Non_Limited_View (Typ)));
Typ := Non_Limited_View (Typ);
end if;
Find_Tag (Typ); Find_Tag (Typ);
pragma Assert (Found); pragma Assert (Found);
return AI_Tag; return AI_Tag;
...@@ -1729,6 +1742,68 @@ package body Exp_Util is ...@@ -1729,6 +1742,68 @@ package body Exp_Util is
return Count; return Count;
end Homonym_Number; end Homonym_Number;
----------------------------------
-- Implements_Limited_Interface --
----------------------------------
function Implements_Limited_Interface (Typ : Entity_Id) return Boolean is
function Contains_Limited_Interface
(Ifaces : Elist_Id) return Boolean;
-- Given a list of interfaces, determine whether one of them is limited
--------------------------------
-- Contains_Limited_Interface --
--------------------------------
function Contains_Limited_Interface
(Ifaces : Elist_Id) return Boolean
is
Iface_Elmt : Elmt_Id;
begin
if not Present (Ifaces) then
return False;
end if;
Iface_Elmt := First_Elmt (Ifaces);
while Present (Iface_Elmt) loop
if Is_Limited_Record (Node (Iface_Elmt)) then
return True;
end if;
Iface_Elmt := Next_Elmt (Iface_Elmt);
end loop;
return False;
end Contains_Limited_Interface;
-- Start of processing for Implements_Limited_Interface
begin
-- Typ is a derived type and may implement a limited interface
-- through its parent subtype. Check the parent subtype as well
-- as any interfaces explicitly implemented at this level.
if Ekind (Typ) = E_Record_Type
and then Present (Parent_Subtype (Typ))
then
return Contains_Limited_Interface (Abstract_Interfaces (Typ))
or else Implements_Limited_Interface (Parent_Subtype (Typ));
-- Typ is an abstract type derived from some interface
elsif Is_Abstract (Typ) then
return Is_Interface (Etype (Typ))
and then Is_Limited_Record (Etype (Typ));
-- Typ may directly implement some interface
else
return Contains_Limited_Interface (Abstract_Interfaces (Typ));
end if;
end Implements_Limited_Interface;
------------------------------ ------------------------------
-- In_Unconditional_Context -- -- In_Unconditional_Context --
------------------------------ ------------------------------
...@@ -2515,6 +2590,10 @@ package body Exp_Util is ...@@ -2515,6 +2590,10 @@ package body Exp_Util is
or else Chars (E) = Name_uAssign or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize or else TSS_Name = TSS_Deep_Finalize
or else Chars (E) = Name_uDisp_Asynchronous_Select
or else Chars (E) = Name_uDisp_Conditional_Select
or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
or else Chars (E) = Name_uDisp_Timed_Select
then then
return True; return True;
end if; end if;
...@@ -2919,7 +2998,6 @@ package body Exp_Util is ...@@ -2919,7 +2998,6 @@ package body Exp_Util is
procedure Kill_Dead_Code (N : Node_Id) is procedure Kill_Dead_Code (N : Node_Id) is
begin begin
if Present (N) then if Present (N) then
Remove_Handler_Entries (N);
Remove_Warning_Messages (N); Remove_Warning_Messages (N);
-- Recurse into block statements and bodies to process declarations -- Recurse into block statements and bodies to process declarations
......
...@@ -410,6 +410,12 @@ package Exp_Util is ...@@ -410,6 +410,12 @@ package Exp_Util is
-- chain, counting only entries in the curren scope. If an entity is not -- chain, counting only entries in the curren scope. If an entity is not
-- overloaded, the returned number will be one. -- overloaded, the returned number will be one.
function Implements_Limited_Interface (Typ : Entity_Id) return Boolean;
-- Ada 2005 (AI-345): Determine whether Typ implements some limited
-- interface. The interface may be of limited, protected, synchronized
-- or taks kind. Typ may also be derived from a type that implements a
-- limited interface.
function Inside_Init_Proc return Boolean; function Inside_Init_Proc return Boolean;
-- Returns True if current scope is within an init proc -- Returns True if current scope is within an init proc
......
...@@ -108,7 +108,7 @@ package Rtsfind is ...@@ -108,7 +108,7 @@ package Rtsfind is
-- package see declarations in the runtime entity table below. -- package see declarations in the runtime entity table below.
RTU_Null, RTU_Null,
-- Used as a null entry. Will cause an error if referenced. -- Used as a null entry. Will cause an error if referenced
-- Children of Ada -- Children of Ada
...@@ -199,7 +199,6 @@ package Rtsfind is ...@@ -199,7 +199,6 @@ package Rtsfind is
System_Compare_Array_Unsigned_64, System_Compare_Array_Unsigned_64,
System_Compare_Array_Unsigned_8, System_Compare_Array_Unsigned_8,
System_Exception_Table, System_Exception_Table,
System_Exceptions,
System_Exn_Int, System_Exn_Int,
System_Exn_LLF, System_Exn_LLF,
System_Exn_LLI, System_Exn_LLI,
...@@ -492,21 +491,33 @@ package Rtsfind is ...@@ -492,21 +491,33 @@ package Rtsfind is
RE_DT_Prologue_Size, -- Ada.Tags RE_DT_Prologue_Size, -- Ada.Tags
RE_External_Tag, -- Ada.Tags RE_External_Tag, -- Ada.Tags
RE_Get_Access_Level, -- Ada.Tags RE_Get_Access_Level, -- Ada.Tags
RE_Get_Entry_Index, -- Ada.Tags
RE_Get_External_Tag, -- Ada.Tags RE_Get_External_Tag, -- Ada.Tags
RE_Get_Prim_Op_Address, -- Ada.Tags RE_Get_Prim_Op_Address, -- Ada.Tags
RE_Get_Prim_Op_Kind, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags RE_Get_RC_Offset, -- Ada.Tags
RE_Get_Remotely_Callable, -- Ada.Tags RE_Get_Remotely_Callable, -- Ada.Tags
RE_Inherit_DT, -- Ada.Tags RE_Inherit_DT, -- Ada.Tags
RE_Inherit_TSD, -- Ada.Tags RE_Inherit_TSD, -- Ada.Tags
RE_Internal_Tag, -- Ada.Tags RE_Internal_Tag, -- Ada.Tags
RE_Is_Descendant_At_Same_Level, -- Ada.Tags RE_Is_Descendant_At_Same_Level, -- Ada.Tags
RE_POK_Function, -- Ada.Tags
RE_POK_Procedure, -- Ada.Tags
RE_POK_Protected_Entry, -- Ada.Tags
RE_POK_Protected_Function, -- Ada.Tags
RE_POK_Protected_Procedure, -- Ada.Tags
RE_POK_Task_Entry, -- Ada.Tags
RE_POK_Task_Procedure, -- Ada.Tags
RE_Prim_Op_Kind, -- Ada.Tags
RE_Register_Interface_Tag, -- Ada.Tags RE_Register_Interface_Tag, -- Ada.Tags
RE_Register_Tag, -- Ada.Tags RE_Register_Tag, -- Ada.Tags
RE_Set_Access_Level, -- Ada.Tags RE_Set_Access_Level, -- Ada.Tags
RE_Set_Entry_Index, -- Ada.Tags
RE_Set_Expanded_Name, -- Ada.Tags RE_Set_Expanded_Name, -- Ada.Tags
RE_Set_External_Tag, -- Ada.Tags RE_Set_External_Tag, -- Ada.Tags
RE_Set_Offset_To_Top, -- Ada.Tags RE_Set_Offset_To_Top, -- Ada.Tags
RE_Set_Prim_Op_Address, -- Ada.Tags RE_Set_Prim_Op_Address, -- Ada.Tags
RE_Set_Prim_Op_Kind, -- Ada.Tags
RE_Set_RC_Offset, -- Ada.Tags RE_Set_RC_Offset, -- Ada.Tags
RE_Set_Remotely_Callable, -- Ada.Tags RE_Set_Remotely_Callable, -- Ada.Tags
RE_Set_TSD, -- Ada.Tags RE_Set_TSD, -- Ada.Tags
...@@ -639,20 +650,6 @@ package Rtsfind is ...@@ -639,20 +650,6 @@ package Rtsfind is
RE_Register_Exception, -- System.Exception_Table RE_Register_Exception, -- System.Exception_Table
RE_All_Others_Id, -- System.Exceptions
RE_Handler_Record, -- System.Exceptions
RE_Handler_Record_Ptr, -- System.Exceptions
RE_Others_Id, -- System.Exceptions
RE_Subprogram_Descriptor, -- System.Exceptions
RE_Subprogram_Descriptor_0, -- System.Exceptions
RE_Subprogram_Descriptor_1, -- System.Exceptions
RE_Subprogram_Descriptor_2, -- System.Exceptions
RE_Subprogram_Descriptor_3, -- System.Exceptions
RE_Subprogram_Descriptor_List, -- System.Exceptions
RE_Subprogram_Descriptor_Ptr, -- System.Exceptions
RE_Subprogram_Descriptors_Record, -- System.Exceptions
RE_Subprogram_Descriptors_Ptr, -- System.Exceptions
RE_Exn_Integer, -- System.Exn_Int RE_Exn_Integer, -- System.Exn_Int
RE_Exn_Long_Long_Float, -- System.Exn_LLF RE_Exn_Long_Long_Float, -- System.Exn_LLF
...@@ -1421,6 +1418,10 @@ package Rtsfind is ...@@ -1421,6 +1418,10 @@ package Rtsfind is
RE_Lt_F, -- System.Vax_Float_Operations RE_Lt_F, -- System.Vax_Float_Operations
RE_Lt_G, -- System.Vax_Float_Operations RE_Lt_G, -- System.Vax_Float_Operations
RE_Valid_D, -- System.Vax_Float_Operations
RE_Valid_F, -- System.Vax_Float_Operations
RE_Valid_G, -- System.Vax_Float_Operations
RE_Version_String, -- System.Version_Control RE_Version_String, -- System.Version_Control
RE_Get_Version_String, -- System.Version_Control RE_Get_Version_String, -- System.Version_Control
...@@ -1599,21 +1600,33 @@ package Rtsfind is ...@@ -1599,21 +1600,33 @@ package Rtsfind is
RE_DT_Prologue_Size => Ada_Tags, RE_DT_Prologue_Size => Ada_Tags,
RE_External_Tag => Ada_Tags, RE_External_Tag => Ada_Tags,
RE_Get_Access_Level => Ada_Tags, RE_Get_Access_Level => Ada_Tags,
RE_Get_Entry_Index => Ada_Tags,
RE_Get_External_Tag => Ada_Tags, RE_Get_External_Tag => Ada_Tags,
RE_Get_Prim_Op_Address => Ada_Tags, RE_Get_Prim_Op_Address => Ada_Tags,
RE_Get_Prim_Op_Kind => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags, RE_Get_RC_Offset => Ada_Tags,
RE_Get_Remotely_Callable => Ada_Tags, RE_Get_Remotely_Callable => Ada_Tags,
RE_Inherit_DT => Ada_Tags, RE_Inherit_DT => Ada_Tags,
RE_Inherit_TSD => Ada_Tags, RE_Inherit_TSD => Ada_Tags,
RE_Internal_Tag => Ada_Tags, RE_Internal_Tag => Ada_Tags,
RE_Is_Descendant_At_Same_Level => Ada_Tags, RE_Is_Descendant_At_Same_Level => Ada_Tags,
RE_POK_Function => Ada_Tags,
RE_POK_Procedure => Ada_Tags,
RE_POK_Protected_Entry => Ada_Tags,
RE_POK_Protected_Function => Ada_Tags,
RE_POK_Protected_Procedure => Ada_Tags,
RE_POK_Task_Entry => Ada_Tags,
RE_POK_Task_Procedure => Ada_Tags,
RE_Prim_Op_Kind => Ada_Tags,
RE_Register_Interface_Tag => Ada_Tags, RE_Register_Interface_Tag => Ada_Tags,
RE_Register_Tag => Ada_Tags, RE_Register_Tag => Ada_Tags,
RE_Set_Access_Level => Ada_Tags, RE_Set_Access_Level => Ada_Tags,
RE_Set_Entry_Index => Ada_Tags,
RE_Set_Expanded_Name => Ada_Tags, RE_Set_Expanded_Name => Ada_Tags,
RE_Set_External_Tag => Ada_Tags, RE_Set_External_Tag => Ada_Tags,
RE_Set_Offset_To_Top => Ada_Tags, RE_Set_Offset_To_Top => Ada_Tags,
RE_Set_Prim_Op_Address => Ada_Tags, RE_Set_Prim_Op_Address => Ada_Tags,
RE_Set_Prim_Op_Kind => Ada_Tags,
RE_Set_RC_Offset => Ada_Tags, RE_Set_RC_Offset => Ada_Tags,
RE_Set_Remotely_Callable => Ada_Tags, RE_Set_Remotely_Callable => Ada_Tags,
RE_Set_TSD => Ada_Tags, RE_Set_TSD => Ada_Tags,
...@@ -1744,20 +1757,6 @@ package Rtsfind is ...@@ -1744,20 +1757,6 @@ package Rtsfind is
RE_Register_Exception => System_Exception_Table, RE_Register_Exception => System_Exception_Table,
RE_All_Others_Id => System_Exceptions,
RE_Handler_Record => System_Exceptions,
RE_Handler_Record_Ptr => System_Exceptions,
RE_Others_Id => System_Exceptions,
RE_Subprogram_Descriptor => System_Exceptions,
RE_Subprogram_Descriptor_0 => System_Exceptions,
RE_Subprogram_Descriptor_1 => System_Exceptions,
RE_Subprogram_Descriptor_2 => System_Exceptions,
RE_Subprogram_Descriptor_3 => System_Exceptions,
RE_Subprogram_Descriptor_List => System_Exceptions,
RE_Subprogram_Descriptor_Ptr => System_Exceptions,
RE_Subprogram_Descriptors_Record => System_Exceptions,
RE_Subprogram_Descriptors_Ptr => System_Exceptions,
RE_Exn_Integer => System_Exn_Int, RE_Exn_Integer => System_Exn_Int,
RE_Exn_Long_Long_Float => System_Exn_LLF, RE_Exn_Long_Long_Float => System_Exn_LLF,
...@@ -2525,6 +2524,10 @@ package Rtsfind is ...@@ -2525,6 +2524,10 @@ package Rtsfind is
RE_Lt_F => System_Vax_Float_Operations, RE_Lt_F => System_Vax_Float_Operations,
RE_Lt_G => System_Vax_Float_Operations, RE_Lt_G => System_Vax_Float_Operations,
RE_Valid_D => System_Vax_Float_Operations,
RE_Valid_F => System_Vax_Float_Operations,
RE_Valid_G => System_Vax_Float_Operations,
RE_Version_String => System_Version_Control, RE_Version_String => System_Version_Control,
RE_Get_Version_String => System_Version_Control, RE_Get_Version_String => System_Version_Control,
...@@ -2805,7 +2808,7 @@ package Rtsfind is ...@@ -2805,7 +2808,7 @@ package Rtsfind is
-- not mean that an attempt to load it subsequently would fail. -- not mean that an attempt to load it subsequently would fail.
procedure Set_RTU_Loaded (N : Node_Id); procedure Set_RTU_Loaded (N : Node_Id);
-- Register the predefined unit N as already loaded. -- Register the predefined unit N as already loaded
procedure Text_IO_Kludge (Nam : Node_Id); procedure Text_IO_Kludge (Nam : Node_Id);
-- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has -- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has
......
...@@ -1924,8 +1924,25 @@ package body Sem_Ch9 is ...@@ -1924,8 +1924,25 @@ package body Sem_Ch9 is
and then Nkind (Trigger) /= N_Delay_Relative_Statement and then Nkind (Trigger) /= N_Delay_Relative_Statement
and then Nkind (Trigger) /= N_Entry_Call_Statement and then Nkind (Trigger) /= N_Entry_Call_Statement
then then
if Ada_Version < Ada_05 then
Error_Msg_N Error_Msg_N
("triggering statement must be delay or entry call", Trigger); ("triggering statement must be delay or entry call", Trigger);
-- Ada 2005 (AI-345): If a procedure_call_statement is used
-- for a procedure_or_entry_call, the procedure_name or pro-
-- cedure_prefix of the procedure_call_statement shall denote
-- an entry renamed by a procedure, or (a view of) a primitive
-- subprogram of a limited interface whose first parameter is
-- a controlling parameter.
elsif Nkind (Trigger) = N_Procedure_Call_Statement
and then not Is_Renamed_Entry (Entity (Name (Trigger)))
and then not Is_Controlling_Limited_Procedure
(Entity (Name (Trigger)))
then
Error_Msg_N ("triggering statement must be delay, procedure " &
"or entry call", Trigger);
end if;
end if; end if;
if Is_Non_Empty_List (Statements (N)) then if Is_Non_Empty_List (Statements (N)) then
...@@ -2211,8 +2228,8 @@ package body Sem_Ch9 is ...@@ -2211,8 +2228,8 @@ package body Sem_Ch9 is
and then Matches_Prefixed_View_Profile (Ifaces, and then Matches_Prefixed_View_Profile (Ifaces,
Parameter_Specifications (Spec), Parameter_Specifications (Spec),
Parameter_Specifications (Parent (Hom))) Parameter_Specifications (Parent (Hom)))
and then Etype (Subtype_Mark (Spec)) = and then Etype (Result_Definition (Spec)) =
Etype (Subtype_Mark (Parent (Hom))) Etype (Result_Definition (Parent (Hom)))
then then
Overrides := True; Overrides := True;
exit; exit;
......
...@@ -64,7 +64,10 @@ package Uintp is ...@@ -64,7 +64,10 @@ package Uintp is
Uint_8 : constant Uint; Uint_8 : constant Uint;
Uint_9 : constant Uint; Uint_9 : constant Uint;
Uint_10 : constant Uint; Uint_10 : constant Uint;
Uint_11 : constant Uint;
Uint_12 : constant Uint; Uint_12 : constant Uint;
Uint_13 : constant Uint;
Uint_14 : constant Uint;
Uint_15 : constant Uint; Uint_15 : constant Uint;
Uint_16 : constant Uint; Uint_16 : constant Uint;
Uint_24 : constant Uint; Uint_24 : constant Uint;
...@@ -430,7 +433,10 @@ private ...@@ -430,7 +433,10 @@ private
Uint_8 : constant Uint := Uint (Uint_Direct_Bias + 8); Uint_8 : constant Uint := Uint (Uint_Direct_Bias + 8);
Uint_9 : constant Uint := Uint (Uint_Direct_Bias + 9); Uint_9 : constant Uint := Uint (Uint_Direct_Bias + 9);
Uint_10 : constant Uint := Uint (Uint_Direct_Bias + 10); Uint_10 : constant Uint := Uint (Uint_Direct_Bias + 10);
Uint_11 : constant Uint := Uint (Uint_Direct_Bias + 11);
Uint_12 : constant Uint := Uint (Uint_Direct_Bias + 12); Uint_12 : constant Uint := Uint (Uint_Direct_Bias + 12);
Uint_13 : constant Uint := Uint (Uint_Direct_Bias + 13);
Uint_14 : constant Uint := Uint (Uint_Direct_Bias + 14);
Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15); Uint_15 : constant Uint := Uint (Uint_Direct_Bias + 15);
Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16); Uint_16 : constant Uint := Uint (Uint_Direct_Bias + 16);
Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24); Uint_24 : constant Uint := Uint (Uint_Direct_Bias + 24);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment