===================================================================
@@ -2444,7 +2444,7 @@ package body Sem_Ch3 is
if Tagged_Present (N) then
Set_Is_Tagged_Type (T);
Make_Class_Wide_Type (T);
- Set_Primitive_Operations (T, New_Elmt_List);
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
end if;
Push_Scope (T);
@@ -2496,7 +2496,7 @@ package body Sem_Ch3 is
or else Task_Present (Def));
Set_Interfaces (T, New_Elmt_List);
- Set_Primitive_Operations (T, New_Elmt_List);
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
-- Complete the decoration of the class-wide entity if it was already
-- built (i.e. during the creation of the limited view)
@@ -3936,8 +3936,8 @@ package body Sem_Ch3 is
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
- Set_Primitive_Operations
- (Id, Primitive_Operations (T));
+ Set_Direct_Primitive_Operations
+ (Id, Direct_Primitive_Operations (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
if Is_Interface (T) then
@@ -3960,10 +3960,11 @@ package body Sem_Ch3 is
(Id, Known_To_Have_Preelab_Init (T));
if Is_Tagged_Type (T) then
- Set_Is_Tagged_Type (Id);
- Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
- Set_Primitive_Operations (Id, Primitive_Operations (T));
- Set_Class_Wide_Type (Id, Class_Wide_Type (T));
+ Set_Is_Tagged_Type (Id);
+ Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
+ Set_Class_Wide_Type (Id, Class_Wide_Type (T));
+ Set_Direct_Primitive_Operations (Id,
+ Direct_Primitive_Operations (T));
end if;
-- In general the attributes of the subtype of a private type
@@ -7352,7 +7353,7 @@ package body Sem_Ch3 is
-- Set fields for tagged types
if Is_Tagged then
- Set_Primitive_Operations (Derived_Type, New_Elmt_List);
+ Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
-- All tagged types defined in Ada.Finalization are controlled
@@ -8237,7 +8238,8 @@ package body Sem_Ch3 is
Set_Corresponding_Record_Type (Def_Id,
Corresponding_Record_Type (T));
else
- Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
+ Set_Direct_Primitive_Operations (Def_Id,
+ Direct_Primitive_Operations (T));
end if;
Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T));
@@ -9811,7 +9813,8 @@ package body Sem_Ch3 is
if Is_Tagged_Type (Full_Base) then
Set_Is_Tagged_Type (Full);
- Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
+ Set_Direct_Primitive_Operations (Full,
+ Direct_Primitive_Operations (Full_Base));
-- Inherit class_wide type of full_base in case the partial view was
-- not tagged. Otherwise it has already been created when the private
@@ -11552,7 +11555,8 @@ package body Sem_Ch3 is
Conditional_Delay (Full, Priv);
if Is_Tagged_Type (Full) then
- Set_Primitive_Operations (Full, Primitive_Operations (Priv));
+ Set_Direct_Primitive_Operations (Full,
+ Direct_Primitive_Operations (Priv));
if Priv = Base_Type (Priv) then
Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
@@ -13529,8 +13533,10 @@ package body Sem_Ch3 is
Set_Etype (T, Any_Type);
Set_Scalar_Range (T, Scalar_Range (Any_Type));
- if Is_Tagged_Type (T) then
- Set_Primitive_Operations (T, New_Elmt_List);
+ if Is_Tagged_Type (T)
+ and then Is_Record_Type (T)
+ then
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
end if;
return;
@@ -14290,7 +14296,6 @@ package body Sem_Ch3 is
if not Tagged_Present (Type_Definition (N)) then
Tag_Mismatch;
Set_Is_Tagged_Type (Id);
- Set_Primitive_Operations (Id, New_Elmt_List);
end if;
elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
@@ -14302,7 +14307,6 @@ package body Sem_Ch3 is
-- Set some attributes to produce a usable full view
Set_Is_Tagged_Type (Id);
- Set_Primitive_Operations (Id, New_Elmt_List);
end if;
else
@@ -15421,12 +15425,12 @@ package body Sem_Ch3 is
-- Customize the class-wide type: It has no prim. op., it cannot be
-- abstract and its Etype points back to the specific root type.
- Set_Ekind (CW_Type, E_Class_Wide_Type);
- Set_Is_Tagged_Type (CW_Type, True);
- Set_Primitive_Operations (CW_Type, New_Elmt_List);
- Set_Is_Abstract_Type (CW_Type, False);
- Set_Is_Constrained (CW_Type, False);
- Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
+ Set_Ekind (CW_Type, E_Class_Wide_Type);
+ Set_Is_Tagged_Type (CW_Type, True);
+ Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List);
+ Set_Is_Abstract_Type (CW_Type, False);
+ Set_Is_Constrained (CW_Type, False);
+ Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
if Ekind (T) = E_Class_Wide_Subtype then
Set_Etype (CW_Type, Etype (Base_Type (T)));
@@ -16990,7 +16994,7 @@ package body Sem_Ch3 is
-- of the class-wide type which depend on the full declaration.
if Is_Tagged_Type (Priv_T) then
- Set_Primitive_Operations (Priv_T, Full_List);
+ Set_Direct_Primitive_Operations (Priv_T, Full_List);
Set_Class_Wide_Type
(Base_Type (Full_T), Class_Wide_Type (Priv_T));
@@ -18268,14 +18272,13 @@ package body Sem_Ch3 is
end if;
Make_Class_Wide_Type (T);
- Set_Primitive_Operations (T, New_Elmt_List);
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
end if;
- -- We must suppress range checks when processing the components
- -- of a record in the presence of discriminants, since we don't
- -- want spurious checks to be generated during their analysis, but
- -- must reset the Suppress_Range_Checks flags after having processed
- -- the record definition.
+ -- We must suppress range checks when processing record components in
+ -- the presence of discriminants, since we don't want spurious checks to
+ -- be generated during their analysis, but Suppress_Range_Checks flags
+ -- must be reset the after processing the record definition.
-- Note: this is the only use of Kill_Range_Checks, and is a bit odd,
-- couldn't we just use the normal range check suppression method here.
===================================================================
@@ -4115,8 +4115,8 @@ package body Exp_Util is
if Is_Tagged_Type (Priv_Subtyp) then
Set_Class_Wide_Type
(Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
- Set_Primitive_Operations (Priv_Subtyp,
- Primitive_Operations (Unc_Typ));
+ Set_Direct_Primitive_Operations (Priv_Subtyp,
+ Direct_Primitive_Operations (Unc_Typ));
end if;
Set_Full_View (Priv_Subtyp, Full_Subtyp);
===================================================================
@@ -1956,11 +1956,11 @@ package body Sem_Ch7 is
Set_Private_Dependents (Id, New_Elmt_List);
if Tagged_Present (Def) then
- Set_Ekind (Id, E_Record_Type_With_Private);
- Set_Primitive_Operations (Id, New_Elmt_List);
- Set_Is_Abstract_Type (Id, Abstract_Present (Def));
- Set_Is_Limited_Record (Id, Limited_Present (Def));
- Set_Has_Delayed_Freeze (Id, True);
+ Set_Ekind (Id, E_Record_Type_With_Private);
+ Set_Direct_Primitive_Operations (Id, New_Elmt_List);
+ Set_Is_Abstract_Type (Id, Abstract_Present (Def));
+ Set_Is_Limited_Record (Id, Limited_Present (Def));
+ Set_Has_Delayed_Freeze (Id, True);
-- Create a class-wide type with the same attributes
===================================================================
@@ -121,7 +121,7 @@ package body Einfo is
-- Entry_Parameters_Type Node15
-- Extra_Formal Node15
-- Lit_Indexes Node15
- -- Primitive_Operations Elist15
+ -- Direct_Primitive_Operations Elist15
-- Related_Instance Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
@@ -817,6 +817,12 @@ package body Einfo is
return Uint17 (Id);
end Digits_Value;
+ function Direct_Primitive_Operations (Id : E) return L is
+ begin
+ pragma Assert (Is_Tagged_Type (Id));
+ return Elist15 (Id);
+ end Direct_Primitive_Operations;
+
function Directly_Designated_Type (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
@@ -2355,8 +2361,16 @@ package body Einfo is
function Primitive_Operations (Id : E) return L is
begin
- pragma Assert (Is_Tagged_Type (Id));
- return Elist15 (Id);
+ if Is_Concurrent_Type (Id) then
+ if Present (Corresponding_Record_Type (Id)) then
+ return Direct_Primitive_Operations
+ (Corresponding_Record_Type (Id));
+ else
+ return No_Elist;
+ end if;
+ else
+ return Direct_Primitive_Operations (Id);
+ end if;
end Primitive_Operations;
function Prival (Id : E) return E is
@@ -4817,11 +4831,18 @@ package body Einfo is
Set_Node8 (Id, V);
end Set_Postcondition_Proc;
- procedure Set_Primitive_Operations (Id : E; V : L) is
+ procedure Set_Direct_Primitive_Operations (Id : E; V : L) is
begin
- pragma Assert (Is_Tagged_Type (Id));
+ pragma Assert
+ (Is_Tagged_Type (Id)
+ and then
+ (Is_Record_Type (Id)
+ or else
+ Is_Incomplete_Type (Id)
+ or else
+ Ekind_In (Id, E_Private_Type, E_Private_Subtype)));
Set_Elist15 (Id, V);
- end Set_Primitive_Operations;
+ end Set_Direct_Primitive_Operations;
procedure Set_Prival (Id : E; V : E) is
begin
@@ -7583,7 +7604,7 @@ package body Einfo is
E_Record_Type |
E_Record_Subtype |
Private_Kind =>
- Write_Str ("Primitive_Operations");
+ Write_Str ("Direct_Primitive_Operations");
when E_Component =>
Write_Str ("DT_Entry_Count");
===================================================================
@@ -769,6 +769,16 @@ package Einfo is
-- Present in floating point types and subtypes and decimal types and
-- subtypes. Contains the Digits value specified in the declaration.
+-- Direct_Primitive_Operations (Elist15)
+-- Present in tagged record types and subtypes, in tagged private types
+-- and in tagged incomplete types. Points to an element list of entities
+-- for primitive operations for the tagged type. Not present in untagged
+-- types (it is an error to reference the primitive operations field of a
+-- type that is not tagged). In order to fulfill the C++ ABI, entities of
+-- primitives that come from source must be stored in this list following
+-- their order of occurrence in the sources. For incomplete types the
+-- list is always empty.
+
-- Directly_Designated_Type (Node20)
-- Present in access types. This field points to the type that is
-- directly designated by the access type. In the case of an access
@@ -3201,15 +3211,12 @@ package Einfo is
-- to generate the call to this procedure in case the expander inserts
-- implicit return statements.
+-- Primitive_Operations (synthesized)
+-- Present in concurrent types, tagged record types and subtypes, tagged
+-- private types and tagged incomplete types. For concurrent types that
+-- have available their Corresponding_Record_Type (CRT) returns the list
+-- of Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
+-- For all the other types returns its Direct_Primitive_Operations.
-- Prival (Node17)
-- Present in private components of protected types. Refers to the entity
@@ -5262,7 +5269,7 @@ package Einfo is
-- E_Private_Type
-- E_Private_Subtype
- -- Primitive_Operations (Elist15)
+ -- Direct_Primitive_Operations (Elist15)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
@@ -5369,7 +5376,7 @@ package Einfo is
-- E_Record_Type
-- E_Record_Subtype
- -- Primitive_Operations (Elist15)
+ -- Direct_Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
@@ -5402,7 +5409,7 @@ package Einfo is
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
- -- Primitive_Operations (Elist15)
+ -- Direct_Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- First_Entity (Node17)
@@ -6072,7 +6079,7 @@ package Einfo is
function Packed_Array_Type (Id : E) return E;
function Parent_Subtype (Id : E) return E;
function Postcondition_Proc (Id : E) return E;
- function Primitive_Operations (Id : E) return L;
+ function Direct_Primitive_Operations (Id : E) return L;
function Prival (Id : E) return E;
function Prival_Link (Id : E) return E;
function Private_Dependents (Id : E) return L;
@@ -6248,8 +6255,9 @@ package Einfo is
function Number_Dimensions (Id : E) return Pos;
function Number_Entries (Id : E) return Nat;
function Number_Formals (Id : E) return Pos;
- function Root_Type (Id : E) return E;
function Parameter_Mode (Id : E) return Formal_Kind;
+ function Primitive_Operations (Id : E) return L;
+ function Root_Type (Id : E) return E;
function Scope_Depth_Set (Id : E) return B;
function Size_Clause (Id : E) return N;
function Stream_Size_Clause (Id : E) return N;
@@ -6641,7 +6649,7 @@ package Einfo is
procedure Set_Packed_Array_Type (Id : E; V : E);
procedure Set_Parent_Subtype (Id : E; V : E);
procedure Set_Postcondition_Proc (Id : E; V : E);
- procedure Set_Primitive_Operations (Id : E; V : L);
+ procedure Set_Direct_Primitive_Operations (Id : E; V : L);
procedure Set_Prival (Id : E; V : E);
procedure Set_Prival_Link (Id : E; V : E);
procedure Set_Private_Dependents (Id : E; V : L);
@@ -7047,6 +7055,7 @@ package Einfo is
pragma Inline (Dependent_Instances);
pragma Inline (Depends_On_Private);
pragma Inline (Digits_Value);
+ pragma Inline (Direct_Primitive_Operations);
pragma Inline (Directly_Designated_Type);
pragma Inline (Discard_Names);
pragma Inline (Discriminal);
@@ -7358,7 +7367,6 @@ package Einfo is
pragma Inline (Parameter_Mode);
pragma Inline (Parent_Subtype);
pragma Inline (Postcondition_Proc);
- pragma Inline (Primitive_Operations);
pragma Inline (Prival);
pragma Inline (Prival_Link);
pragma Inline (Private_Dependents);
@@ -7482,6 +7490,7 @@ package Einfo is
pragma Inline (Set_Dependent_Instances);
pragma Inline (Set_Depends_On_Private);
pragma Inline (Set_Digits_Value);
+ pragma Inline (Set_Direct_Primitive_Operations);
pragma Inline (Set_Directly_Designated_Type);
pragma Inline (Set_Discard_Names);
pragma Inline (Set_Discriminal);
@@ -7748,7 +7757,6 @@ package Einfo is
pragma Inline (Set_Packed_Array_Type);
pragma Inline (Set_Parent_Subtype);
pragma Inline (Set_Postcondition_Proc);
- pragma Inline (Set_Primitive_Operations);
pragma Inline (Set_Prival);
pragma Inline (Set_Prival_Link);
pragma Inline (Set_Private_Dependents);
===================================================================
@@ -5707,7 +5707,7 @@ package body Sem_Ch8 is
end if;
Set_Is_Tagged_Type (T);
- Set_Primitive_Operations (T, New_Elmt_List);
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
Make_Class_Wide_Type (T);
Set_Entity (N, Class_Wide_Type (T));
Set_Etype (N, Class_Wide_Type (T));
===================================================================
@@ -1334,6 +1334,12 @@ package body Sem_Cat is
begin
Desig_Type := Etype (Designated_Type (T));
+ -- No action needed for concurrent types
+
+ if Is_Concurrent_Type (Desig_Type) then
+ return;
+ end if;
+
Primitive_Subprograms := Primitive_Operations (Desig_Type);
Subprogram_Elmt := First_Elmt (Primitive_Subprograms);
===================================================================
@@ -1316,7 +1316,9 @@ package body Exp_Dist is
-- Build callers, receivers for every primitive operations and a RPC
-- receiver for this type.
- if Present (Primitive_Operations (Designated_Type)) then
+ if not Is_Concurrent_Type (Designated_Type)
+ and then Present (Primitive_Operations (Designated_Type))
+ then
Overload_Counter_Table.Reset;
Current_Primitive_Elmt :=
@@ -1336,8 +1338,9 @@ package body Exp_Dist is
Is_TSS (Current_Primitive, TSS_Stream_Input) or else
Is_TSS (Current_Primitive, TSS_Stream_Output) or else
Is_TSS (Current_Primitive, TSS_Stream_Read) or else
- Is_TSS (Current_Primitive, TSS_Stream_Write) or else
- Is_Predefined_Interface_Primitive (Current_Primitive))
+ Is_TSS (Current_Primitive, TSS_Stream_Write)
+ or else
+ Is_Predefined_Interface_Primitive (Current_Primitive))
and then not Is_Hidden (Current_Primitive)
then
-- The first thing to do is build an up-to-date copy of the
@@ -1413,8 +1416,8 @@ package body Exp_Dist is
RACW_Type => Stub_Elements.RACW_Type,
Parent_Primitive => Current_Primitive);
- Current_Receiver := Defining_Unit_Name (
- Specification (Current_Receiver_Body));
+ Current_Receiver :=
+ Defining_Unit_Name (Specification (Current_Receiver_Body));
Append_To (Body_Decls, Current_Receiver_Body);
===================================================================
@@ -241,14 +241,7 @@ package body Lib.Xref is
-- The check for Present here is to protect against previously
-- reported critical errors.
- if Is_Concurrent_Type (Base_T)
- and then Present (Corresponding_Record_Type (Base_T))
- then
- Prim_List := Primitive_Operations
- (Corresponding_Record_Type (Base_T));
- else
- Prim_List := Primitive_Operations (Base_T);
- end if;
+ Prim_List := Primitive_Operations (Base_T);
if No (Prim_List) then
return;
===================================================================
@@ -6144,8 +6144,8 @@ package body Exp_Ch3 is
(Rep, Access_Disp_Table (Def_Id));
Set_Dispatch_Table_Wrappers
(Rep, Dispatch_Table_Wrappers (Def_Id));
- Set_Primitive_Operations
- (Rep, Primitive_Operations (Def_Id));
+ Set_Direct_Primitive_Operations
+ (Rep, Direct_Primitive_Operations (Def_Id));
end;
end if;