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,27 +65,44 @@ package body Ada.Tags is
-- | tags |
-- +-------------------+
-- | table of |
-- | interface |
-- : interface :
-- | tags |
-- +-------------------+
-- | table of |
-- : primitive op :
-- | kinds |
-- +-------------------+
-- | table of |
-- : entry :
-- | indices |
-- +-------------------+
subtype Cstring is String (Positive);
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;
pragma Suppress_Initialization (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
Idepth : Natural;
Idepth : Natural;
-- Inheritance Depth Level: Used to implement the membership test
-- associated with single inheritance of tagged types in constant-time.
-- In addition it also indicates the size of the first table stored in
-- the Tags_Table component (see comment below).
Access_Level : Natural;
Access_Level : Natural;
-- Accessibility level required to give support to Ada 2005 nested type
-- extensions. This feature allows safe nested type extensions by
-- shifting the accessibility checks to certain operations, rather than
......@@ -94,20 +111,20 @@ package body Ada.Tags is
-- function return, and class-wide stream I/O, the danger of objects
-- outliving their type declaration can be eliminated (Ada 2005: AI-344)
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag;
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag;
-- Components used to give support to the Ada.Tags subprograms described
-- in ARM 3.9
Remotely_Callable : Boolean;
-- Used to check ARM E.4 (18)
RC_Offset : SSE.Storage_Offset;
RC_Offset : SSE.Storage_Offset;
-- Controller Offset: Used to give support to tagged controlled objects
-- (see Get_Deep_Controller at s-finimp)
Num_Interfaces : Natural;
Num_Interfaces : Natural;
-- Number of abstract interface types implemented by the tagged type.
-- The value Idepth+Num_Interfaces indicates the end of the second table
-- stored in the Tags_Table component. It is used to implement the
......@@ -121,6 +138,16 @@ package body Ada.Tags is
-- 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
-- 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;
type Dispatch_Table is record
......@@ -175,7 +202,7 @@ package body Ada.Tags is
type Storage_Offset_Ptr is access System.Storage_Elements.Storage_Offset;
function To_Storage_Offset_Ptr is
new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
new Unchecked_Conversion (System.Address, Storage_Offset_Ptr);
-----------------------
-- Local Subprograms --
......@@ -242,15 +269,12 @@ package body Ada.Tags is
Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
J : Integer := 1;
begin
loop
if Str1 (J) /= Str2 (J) then
return False;
elsif Str1 (J) = ASCII.NUL then
return True;
else
J := J + 1;
end if;
......@@ -330,22 +354,27 @@ package body Ada.Tags is
-- that are contained in the dispatch table referenced by Obj'Tag.
function IW_Membership
(This : System.Address;
Iface_Tag : Tag) return Boolean
(This : System.Address;
T : Tag) return Boolean
is
T : constant Tag := To_Tag_Ptr (This).all;
Obj_Base : constant System.Address := This - Offset_To_Top (T);
T_Base : constant Tag := To_Tag_Ptr (Obj_Base).all;
Curr_DT : constant Tag := To_Tag_Ptr (This).all;
Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT);
Obj_DT : constant Tag := To_Tag_Ptr (Obj_Base).all;
Obj_TSD : constant Type_Specific_Data_Ptr := TSD (T_Base);
Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
Id : Natural;
Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT);
Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
Id : Natural;
begin
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
if Obj_TSD.Tags_Table (Id) = Iface_Tag then
if Obj_TSD.Tags_Table (Id) = T then
return True;
end if;
......@@ -413,6 +442,17 @@ package body Ada.Tags is
return TSD (T).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 --
----------------------
......@@ -433,6 +473,17 @@ package body Ada.Tags is
return T.Prims_Ptr (Position);
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 --
-------------------
......@@ -485,9 +536,9 @@ package body Ada.Tags is
-- of the parent
New_TSD_Ptr.Tags_Table
(1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces)
:= Old_TSD_Ptr.Tags_Table
(0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
(1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
Old_TSD_Ptr.Tags_Table
(0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
else
New_TSD_Ptr.Idepth := 0;
New_TSD_Ptr.Num_Interfaces := 0;
......@@ -588,8 +639,8 @@ package body Ada.Tags is
-- The tag of the parent type through the dispatch table
F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
-- Access to the _size primitive of the parent. We assume that
-- it is always in the first slot of the dispatch table
-- Access to the _size primitive of the parent. We assume that it is
-- always in the first slot of the dispatch table
begin
-- Here we compute the size of the _parent field of the object
......@@ -672,6 +723,18 @@ package body Ada.Tags is
TSD (T).Access_Level := Value;
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 --
-----------------------
......@@ -718,6 +781,18 @@ package body Ada.Tags is
T.Prims_Ptr (Position) := Value;
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 --
-------------------
......
......@@ -40,11 +40,8 @@ with System.Storage_Elements;
with Unchecked_Conversion;
package Ada.Tags is
pragma Preelaborate_05 (Tags);
-- In accordance with Ada 2005 AI-362
pragma Elaborate_Body;
-- We need a dummy body to solve bootstrap path issues (why ???)
pragma Preelaborate_05;
-- In accordance with Ada 2005 AI-362
type Tag is private;
......@@ -101,6 +98,29 @@ private
type 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;
function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
......@@ -108,15 +128,31 @@ private
-- true if Obj is in Typ'Class.
function IW_Membership
(This : System.Address;
Iface_Tag : Tag) return Boolean;
-- Ada 2005 (AI-251): Given the tag of an object and the tag associated
-- with an interface, return true if Obj is in Iface'Class.
(This : System.Address;
T : Tag) return Boolean;
-- Ada 2005 (AI-251): General routine that checks if a given object
-- 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;
-- Given the tag associated with a type, returns the accessibility level
-- 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;
-- Retrieve the address of a null terminated string containing
-- the external name
......@@ -124,10 +160,16 @@ private
function Get_Prim_Op_Address
(T : Tag;
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
-- 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;
-- Return the Offset of the implicit record controller when the object
-- has controlled components. O otherwise.
......@@ -173,6 +215,13 @@ private
-- Insert the Tag and its associated external_tag in a table for the
-- 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
(T : Tag;
Value : System.Storage_Elements.Storage_Offset);
......@@ -185,13 +234,20 @@ private
(T : Tag;
Position : Positive;
Value : System.Address);
-- Given a pointer to a dispatch Table (T) and a position in the
-- dispatch Table put the address of the virtual function in it
-- (used for overriding)
-- Given a pointer to a dispatch Table (T) and a position in the dispatch
-- Table put the address of the virtual function in it (used for
-- 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);
-- 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);
-- Sets the accessibility level of the tagged type associated with T
......@@ -199,11 +255,11 @@ private
procedure Set_Expanded_Name (T : Tag; Value : System.Address);
-- 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);
-- 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);
-- Sets the Offset of the implicit record controller when the object
......
......@@ -215,9 +215,9 @@ package body Einfo is
-- Abstract_Interface_Alias Node25
-- (unused) Node26
-- Overridden_Operation Node26
-- (unused) Node27
-- Wrapped_Entity Node27
---------------------------------------------
-- Usage of Flags in Defining Entity Nodes --
......@@ -442,9 +442,9 @@ package body Einfo is
-- Has_Specified_Stream_Read Flag192
-- Has_Specified_Stream_Write Flag193
-- Is_Local_Anonymous_Access Flag194
-- Is_Primitive_Wrapper Flag195
-- Was_Hidden Flag196
-- (unused) Flag195
-- (unused) Flag196
-- (unused) Flag197
-- (unused) Flag198
-- (unused) Flag199
......@@ -512,8 +512,7 @@ package body Einfo is
function Abstract_Interface_Alias (Id : E) return E is
begin
pragma Assert
(Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
pragma Assert (Is_Subprogram (Id));
return Node25 (Id);
end Abstract_Interface_Alias;
......@@ -1734,6 +1733,12 @@ package body Einfo is
return Flag59 (Id);
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
begin
pragma Assert (Is_Type (Id));
......@@ -2038,6 +2043,11 @@ package body Einfo is
return Node22 (Id);
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
begin
pragma Assert (Is_Array_Type (Id));
......@@ -2325,6 +2335,18 @@ package body Einfo is
return Flag96 (Id);
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 --
------------------------------
......@@ -3799,6 +3821,12 @@ package body Einfo is
Set_Flag59 (Id, V);
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
begin
pragma Assert (Is_Type (Id));
......@@ -4107,6 +4135,11 @@ package body Einfo is
Set_Node22 (Id, V);
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
begin
pragma Assert (Is_Array_Type (Id));
......@@ -4400,6 +4433,18 @@ package body Einfo is
Set_Flag96 (Id, V);
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 --
-----------------------------------
......@@ -6328,6 +6373,15 @@ package body Einfo is
return Underlying_Type (Full_View (Id));
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
-- subtype, and if so get the Underlying_Type of the parent type.
......@@ -6538,6 +6592,7 @@ package body Einfo is
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive_Wrapper", Flag195 (Id));
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Public", Flag10 (Id));
......@@ -6589,6 +6644,7 @@ package body Einfo is
W ("Uses_Sec_Stack", Flag95 (Id));
W ("Vax_Float", Flag151 (Id));
W ("Warnings_Off", Flag96 (Id));
W ("Was_Hidden", Flag196 (Id));
end Write_Entity_Flags;
-----------------------
......@@ -7504,6 +7560,10 @@ package body Einfo is
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Procedure |
E_Function =>
Write_Str ("Overridden_Operation");
when others =>
Write_Str ("Field26??");
end case;
......@@ -7516,6 +7576,9 @@ package body Einfo is
procedure Write_Field27_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Procedure =>
Write_Str ("Wrapped_Entity");
when others =>
Write_Str ("Field27??");
end case;
......
......@@ -183,7 +183,7 @@ package Einfo is
-- dynamic bounds, it is assumed that the value can range down or up
-- 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 Value_Size of the first-named subtype to the given value, and the
......@@ -2243,6 +2243,11 @@ package Einfo is
-- flag is set does not necesarily mean that no elaboration code is
-- 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)
-- Present in composite types that have a private component. Used to
-- enforce the rule that operations on the composite type that depend
......@@ -2769,6 +2774,10 @@ package Einfo is
-- In subtypes (tagged and untagged):
-- 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)
-- Present in array types and subtypes, including the string literal
-- subtype case, if the corresponding type is packed (either bit packed
......@@ -3220,6 +3229,14 @@ package Einfo is
-- is used to suppress warnings for a given entity. It is also used by
-- 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 --
------------------
......@@ -3488,7 +3505,7 @@ package Einfo is
-- A record type, created by a record type declaration
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,
-- Used for types defined by a private extension declaration, and
......@@ -3499,7 +3516,7 @@ package Einfo is
-- a private type.
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,
-- A private type, created by a private type declaration
......@@ -4033,6 +4050,7 @@ package Einfo is
-- Is_Packed_Array_Type (Flag138)
-- Is_Potentially_Use_Visible (Flag9)
-- Is_Preelaborated (Flag59)
-- Is_Primitive_Wrapper (Flag195)
-- Is_Public (Flag10)
-- Is_Pure (Flag44)
-- Is_Remote_Call_Interface (Flag62)
......@@ -4050,6 +4068,7 @@ package Einfo is
-- Referenced_As_LHS (Flag36)
-- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
-- Was_Hidden (Flag196)
-- Declaration_Node (synth)
-- Enclosing_Dynamic_Scope (synth)
......@@ -4401,6 +4420,7 @@ package Einfo is
-- Privals_Chain (Elist23) (for a protected function)
-- Obsolescent_Warning (Node24)
-- Abstract_Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169)
......@@ -4648,6 +4668,9 @@ package Einfo is
-- Privals_Chain (Elist23) (for a protected procedure)
-- Obsolescent_Warning (Node24)
-- Abstract_Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169) (always False for procedure)
......@@ -4673,6 +4696,8 @@ package Einfo is
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
-- Is_Thread_Body (Flag77) (non-generic case only)
......@@ -5299,6 +5324,8 @@ package Einfo is
function Is_Packed_Array_Type (Id : E) return B;
function Is_Potentially_Use_Visible (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_Descendant (Id : E) return B;
function Is_Public (Id : E) return B;
......@@ -5351,6 +5378,7 @@ package Einfo is
function Original_Access_Type (Id : E) return E;
function Original_Array_Type (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 Parent_Subtype (Id : E) return E;
function Primitive_Operations (Id : E) return L;
......@@ -5402,6 +5430,8 @@ package Einfo is
function Uses_Sec_Stack (Id : E) return B;
function Vax_Float (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 --
......@@ -5792,6 +5822,8 @@ package Einfo is
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_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_Descendant (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
......@@ -5843,6 +5875,7 @@ package Einfo is
procedure Set_Original_Access_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_Overridden_Operation (Id : E; V : E);
procedure Set_Packed_Array_Type (Id : E; V : E);
procedure Set_Parent_Subtype (Id : E; V : E);
procedure Set_Primitive_Operations (Id : E; V : L);
......@@ -5894,6 +5927,8 @@ package Einfo is
procedure Set_Uses_Sec_Stack (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_Was_Hidden (Id : E; V : B := True);
procedure Set_Wrapped_Entity (Id : E; V : E);
-----------------------------------
-- Field Initialization Routines --
......@@ -6360,6 +6395,8 @@ package Einfo is
pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Preelaborated);
pragma Inline (Is_Primitive_Wrapper);
pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Type);
......@@ -6421,6 +6458,7 @@ package Einfo is
pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
pragma Inline (Overridden_Operation);
pragma Inline (Packed_Array_Type);
pragma Inline (Parameter_Mode);
pragma Inline (Parent_Subtype);
......@@ -6473,6 +6511,8 @@ package Einfo is
pragma Inline (Uses_Sec_Stack);
pragma Inline (Vax_Float);
pragma Inline (Warnings_Off);
pragma Inline (Was_Hidden);
pragma Inline (Wrapped_Entity);
pragma Inline (Init_Alignment);
pragma Inline (Init_Component_Bit_Offset);
......@@ -6692,6 +6732,8 @@ package Einfo is
pragma Inline (Set_Is_Packed_Array_Type);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Primitive_Wrapper);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Public);
......@@ -6743,6 +6785,7 @@ package Einfo is
pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overridden_Operation);
pragma Inline (Set_Packed_Array_Type);
pragma Inline (Set_Parent_Subtype);
pragma Inline (Set_Primitive_Operations);
......@@ -6794,6 +6837,8 @@ package Einfo is
pragma Inline (Set_Uses_Sec_Stack);
pragma Inline (Set_Vax_Float);
pragma Inline (Set_Warnings_Off);
pragma Inline (Set_Was_Hidden);
pragma Inline (Set_Wrapped_Entity);
-- END XEINFO INLINES
......
......@@ -27,7 +27,6 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch4; use Exp_Ch4;
......@@ -867,8 +866,8 @@ package body Exp_Ch3 is
Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
Set_Parameter_Specifications (Spec_Node, Parameter_List);
Set_Subtype_Mark (Spec_Node,
New_Reference_To (Standard_Boolean, Loc));
Set_Result_Definition (Spec_Node,
New_Reference_To (Standard_Boolean, Loc));
Set_Specification (Body_Node, Spec_Node);
Set_Declarations (Body_Node, New_List);
......@@ -1482,16 +1481,21 @@ package body Exp_Ch3 is
Attribute_Name => Name_Unrestricted_Access);
end if;
-- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check.
-- Ada 2005 (AI-231): Add the run-time check if required
if Ada_Version >= Ada_05
and then Can_Never_Be_Null (Etype (Id)) -- Lhs
and then Present (Etype (Exp))
and then not Can_Never_Be_Null (Etype (Exp))
and then Can_Never_Be_Null (Etype (Id)) -- Lhs
then
Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Etype (Id));
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))
then
Install_Null_Excluding_Check (Exp);
end if;
end if;
-- Take a copy of Exp to ensure that later copies of this
......@@ -3017,7 +3021,7 @@ package body Exp_Ch3 is
Make_Function_Specification (Loc,
Defining_Unit_Name => F,
Parameter_Specifications => Pspecs,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
......@@ -3698,19 +3702,6 @@ package body Exp_Ch3 is
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
-- initializing value is known to be non-null. We can also set
-- Can_Never_Be_Null if this is a constant.
......@@ -4362,7 +4353,7 @@ package body Exp_Ch3 is
Make_Defining_Identifier (Loc, Name_uF),
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,
......@@ -4392,10 +4383,10 @@ package body Exp_Ch3 is
------------------------
procedure Freeze_Record_Type (N : Node_Id) is
Def_Id : constant Node_Id := Entity (N);
Comp : Entity_Id;
Type_Decl : constant Node_Id := Parent (Def_Id);
Def_Id : constant Node_Id := Entity (N);
Predef_List : List_Id;
Type_Decl : constant Node_Id := Parent (Def_Id);
Renamed_Eq : Node_Id := Empty;
-- Could use some comments ???
......@@ -4534,6 +4525,7 @@ package body Exp_Ch3 is
Make_Predefined_Primitive_Specs
(Def_Id, Predef_List, Renamed_Eq);
Insert_List_Before_And_Analyze (N, Predef_List);
Set_Is_Frozen (Def_Id, True);
Set_All_DT_Position (Def_Id);
......@@ -4623,6 +4615,8 @@ package body Exp_Ch3 is
Append_Freeze_Actions
(Def_Id, Predefined_Primitive_Freeze (Def_Id));
Append_Freeze_Actions
(Def_Id, Init_Predefined_Interface_Primitives (Def_Id));
end if;
-- In the non-tagged case, an equality function is provided only for
......@@ -4696,8 +4690,20 @@ package body Exp_Ch3 is
if Is_Tagged_Type (Def_Id) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
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;
------------------------------
......@@ -5887,6 +5893,67 @@ package body Exp_Ch3 is
Parameter_Type => New_Reference_To (Tag_Typ, Loc)))));
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
-- future extension contain a controlled element. We generate those
-- only for root tagged types where they will get dummy bodies or
......@@ -6059,7 +6126,7 @@ package body Exp_Ch3 is
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => Profile,
Subtype_Mark =>
Result_Definition =>
New_Reference_To (Ret_Type, Loc));
end if;
......@@ -6242,6 +6309,29 @@ package body Exp_Ch3 is
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
-- Body for equality
......
......@@ -1560,19 +1560,6 @@ package body Exp_Ch7 is
end if;
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 to encode entity names in package body before gigi is called
......@@ -2220,6 +2207,8 @@ package body Exp_Ch7 is
or else Has_Interrupt_Handler (Pid)
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
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
......
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -30,6 +30,13 @@ with Types; use Types;
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
(Decls : List_Id;
Typ : Entity_Id;
......@@ -102,10 +109,9 @@ package Exp_Ch9 is
-- declarative part.
function Build_Protected_Sub_Specification
(N : Node_Id;
Prottyp : Entity_Id;
Unprotected : Boolean := False)
return Node_Id;
(N : Node_Id;
Prottyp : Entity_Id;
Mode : Subprogram_Protection_Mode) return Node_Id;
-- Build specification for protected subprogram. This is called when
-- expanding a protected type, and also when expanding the declaration for
-- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is
......@@ -214,7 +220,7 @@ package Exp_Ch9 is
-- routine to make sure Complete_Master is called on exit).
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);
-- Expand declarations required for accept statement. See bodies of
......
......@@ -30,14 +30,26 @@
with Types; use Types;
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
(CW_Membership,
IW_Membership,
DT_Entry_Size,
DT_Prologue_Size,
Get_Access_Level,
Get_Entry_Index,
Get_External_Tag,
Get_Prim_Op_Address,
Get_Prim_Op_Kind,
Get_RC_Offset,
Get_Remotely_Callable,
Inherit_DT,
......@@ -45,15 +57,42 @@ package Exp_Disp is
Register_Interface_Tag,
Register_Tag,
Set_Access_Level,
Set_Entry_Index,
Set_Expanded_Name,
Set_External_Tag,
Set_Prim_Op_Address,
Set_Prim_Op_Kind,
Set_RC_Offset,
Set_Remotely_Callable,
Set_TSD,
TSD_Entry_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
(Loc : Source_Ptr;
Prim : Entity_Id) return Node_Id;
......@@ -69,6 +108,15 @@ package Exp_Disp is
-- the secondary dispatch table of Prim's controlling type with Thunk_Id's
-- 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
(AI_Tag : Entity_Id;
Acc_Disp_Tables : in out Elist_Id;
......@@ -90,45 +138,65 @@ package Exp_Disp is
-- Expand the declarations for the Dispatch Table (or the Vtable in
-- 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);
-- 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
-- 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);
-- 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,
-- 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);
pragma Export (Ada, Write_DT);
-- Debugging procedure (to be called within gdb)
......
......@@ -31,8 +31,6 @@ with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Tss; use Exp_Tss;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Itypes; use Itypes;
......@@ -49,7 +47,6 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
......@@ -685,7 +682,7 @@ package body Exp_Util is
Spec := Make_Function_Specification (Loc,
Defining_Unit_Name =>
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
-- up after the task name is built.
......@@ -1278,6 +1275,13 @@ package body Exp_Util is
then
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
Remove_Side_Effects (Exp);
Rewrite (Subtype_Indic,
......@@ -1409,7 +1413,7 @@ package body Exp_Util is
and then Present (Abstract_Interfaces (Typ))
and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
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));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
......@@ -1449,12 +1453,21 @@ package body Exp_Util is
-- Handle task and protected types implementing interfaces
if Ekind (Typ) = E_Protected_Type
or else Ekind (Typ) = E_Task_Type
then
if Is_Concurrent_Type (Typ) then
Typ := Corresponding_Record_Type (Typ);
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);
pragma Assert (Found);
return AI_Tag;
......@@ -1729,6 +1742,68 @@ package body Exp_Util is
return Count;
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 --
------------------------------
......@@ -2515,6 +2590,10 @@ package body Exp_Util is
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
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
return True;
end if;
......@@ -2919,7 +2998,6 @@ package body Exp_Util is
procedure Kill_Dead_Code (N : Node_Id) is
begin
if Present (N) then
Remove_Handler_Entries (N);
Remove_Warning_Messages (N);
-- Recurse into block statements and bodies to process declarations
......
......@@ -410,6 +410,12 @@ package Exp_Util is
-- chain, counting only entries in the curren scope. If an entity is not
-- 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;
-- Returns True if current scope is within an init proc
......
......@@ -108,7 +108,7 @@ package Rtsfind is
-- package see declarations in the runtime entity table below.
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
......@@ -199,7 +199,6 @@ package Rtsfind is
System_Compare_Array_Unsigned_64,
System_Compare_Array_Unsigned_8,
System_Exception_Table,
System_Exceptions,
System_Exn_Int,
System_Exn_LLF,
System_Exn_LLI,
......@@ -492,21 +491,33 @@ package Rtsfind is
RE_DT_Prologue_Size, -- Ada.Tags
RE_External_Tag, -- Ada.Tags
RE_Get_Access_Level, -- Ada.Tags
RE_Get_Entry_Index, -- Ada.Tags
RE_Get_External_Tag, -- Ada.Tags
RE_Get_Prim_Op_Address, -- Ada.Tags
RE_Get_Prim_Op_Kind, -- Ada.Tags
RE_Get_RC_Offset, -- Ada.Tags
RE_Get_Remotely_Callable, -- Ada.Tags
RE_Inherit_DT, -- Ada.Tags
RE_Inherit_TSD, -- Ada.Tags
RE_Internal_Tag, -- 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_Tag, -- Ada.Tags
RE_Set_Access_Level, -- Ada.Tags
RE_Set_Entry_Index, -- Ada.Tags
RE_Set_Expanded_Name, -- Ada.Tags
RE_Set_External_Tag, -- Ada.Tags
RE_Set_Offset_To_Top, -- Ada.Tags
RE_Set_Prim_Op_Address, -- Ada.Tags
RE_Set_Prim_Op_Kind, -- Ada.Tags
RE_Set_RC_Offset, -- Ada.Tags
RE_Set_Remotely_Callable, -- Ada.Tags
RE_Set_TSD, -- Ada.Tags
......@@ -639,20 +650,6 @@ package Rtsfind is
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_Long_Long_Float, -- System.Exn_LLF
......@@ -1421,6 +1418,10 @@ package Rtsfind is
RE_Lt_F, -- 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_Get_Version_String, -- System.Version_Control
......@@ -1599,21 +1600,33 @@ package Rtsfind is
RE_DT_Prologue_Size => Ada_Tags,
RE_External_Tag => Ada_Tags,
RE_Get_Access_Level => Ada_Tags,
RE_Get_Entry_Index => Ada_Tags,
RE_Get_External_Tag => Ada_Tags,
RE_Get_Prim_Op_Address => Ada_Tags,
RE_Get_Prim_Op_Kind => Ada_Tags,
RE_Get_RC_Offset => Ada_Tags,
RE_Get_Remotely_Callable => Ada_Tags,
RE_Inherit_DT => Ada_Tags,
RE_Inherit_TSD => Ada_Tags,
RE_Internal_Tag => 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_Tag => Ada_Tags,
RE_Set_Access_Level => Ada_Tags,
RE_Set_Entry_Index => Ada_Tags,
RE_Set_Expanded_Name => Ada_Tags,
RE_Set_External_Tag => Ada_Tags,
RE_Set_Offset_To_Top => Ada_Tags,
RE_Set_Prim_Op_Address => Ada_Tags,
RE_Set_Prim_Op_Kind => Ada_Tags,
RE_Set_RC_Offset => Ada_Tags,
RE_Set_Remotely_Callable => Ada_Tags,
RE_Set_TSD => Ada_Tags,
......@@ -1744,20 +1757,6 @@ package Rtsfind is
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_Long_Long_Float => System_Exn_LLF,
......@@ -2525,6 +2524,10 @@ package Rtsfind is
RE_Lt_F => 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_Get_Version_String => System_Version_Control,
......@@ -2805,7 +2808,7 @@ package Rtsfind is
-- not mean that an attempt to load it subsequently would fail.
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);
-- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has
......
......@@ -1924,8 +1924,25 @@ package body Sem_Ch9 is
and then Nkind (Trigger) /= N_Delay_Relative_Statement
and then Nkind (Trigger) /= N_Entry_Call_Statement
then
Error_Msg_N
("triggering statement must be delay or entry call", Trigger);
if Ada_Version < Ada_05 then
Error_Msg_N
("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;
if Is_Non_Empty_List (Statements (N)) then
......@@ -2211,8 +2228,8 @@ package body Sem_Ch9 is
and then Matches_Prefixed_View_Profile (Ifaces,
Parameter_Specifications (Spec),
Parameter_Specifications (Parent (Hom)))
and then Etype (Subtype_Mark (Spec)) =
Etype (Subtype_Mark (Parent (Hom)))
and then Etype (Result_Definition (Spec)) =
Etype (Result_Definition (Parent (Hom)))
then
Overrides := True;
exit;
......
......@@ -64,7 +64,10 @@ package Uintp is
Uint_8 : constant Uint;
Uint_9 : constant Uint;
Uint_10 : constant Uint;
Uint_11 : constant Uint;
Uint_12 : constant Uint;
Uint_13 : constant Uint;
Uint_14 : constant Uint;
Uint_15 : constant Uint;
Uint_16 : constant Uint;
Uint_24 : constant Uint;
......@@ -430,7 +433,10 @@ private
Uint_8 : constant Uint := Uint (Uint_Direct_Bias + 8);
Uint_9 : constant Uint := Uint (Uint_Direct_Bias + 9);
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_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_16 : constant Uint := Uint (Uint_Direct_Bias + 16);
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