From 2e1f3a5e3e76aa1149b9061304a4ef0ea40483b3 Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Mon, 3 May 2021 01:56:38 -0400 Subject: [PATCH] [Ada] Support for Object.Op subprogram-call notation for untagged types gcc/ada/ * doc/gnat_rm/implementation_defined_pragmas.rst: Add a description of the feature of prefixed-view calls for untagged types to the section on pragma Extensions_Allowed. * gnat_rm.texi: Regenerate. * einfo.ads: Update specification for Direct_Primitive_Operations to reflect its use for untagged types when Extensions_Allowed is True. * gen_il-gen-gen_entities.adb: Allow Direct_Primitive_Operations as a field of untagged classes of types by removing the "Pre" test of "Is_Tagged_Type (N)", and making that field generally available for all types and subtypes by defining it for Type_Kind and removing its specification for individual classes of types. * sem_ch3.adb (Analyze_Full_Type_Declaration): Initialize the Direct_Primitive_Operations list when not already set for the new (sub)type and its base type (except when Ekind of the type is E_Void, which can happen due to errors in cases where Derived_Type_Declaration is called and perhaps in other situations). (Analyze_Subtype_Declaration): Inherit Direct_Primitive_Operations list from the base type, for record and private cases. (Build_Derived_Record_Type): Initialize the Direct_Primitive_Operations list for derived record and private types. (Build_Derived_Type): Initialize the Direct_Primitive_Operations list for derived types (and also for their associated base types when needed). (Process_Full_View): For full types that are untagged record and private types, copy the primitive operations of the partial view to the primitives list of the full view. * sem_ch4.adb (Analyze_Selected_Component): Allow prefixed notation for subprogram calls in the case of untagged types (when Extensions_Allowed is True). In the case where Is_Private_Type (Prefix_Type) is True, call Try_Object_Operation when a discriminant selector wasn't found. Also call Try_Object_Operation in other type kind cases (when Extensions_Allowed is True). (Try_Object_Operation.Try_One_Prefixed_Interpretation): Prevent early return in the untagged case (when Extensions_Allowed is True). Condition main call to Try_Primitive_Operation on the type having primitives, and after that, if Prim_Result is False, test for case where the prefix type is a named access type with primitive operations and in that case call Try_Primitive_Operation after temporarily resetting Obj_Type to denote the access type (and restore it to the designated type after the call) (Try_Object_Operation.Valid_First_Argument_Of): Do matching type comparison by testing Base_Type (Obj_Type) against Base_Type (Typ), rather than against just Typ, to properly handle cases where the object prefix has a constrained subtype. (Fixes a bug discovered while working on this feature.) * sem_ch6.adb (New_Overloaded_Entity.Check_For_Primitive_Subprogram): Add a primitive of an untagged type to the type's list of primitive operations, for both explicit and implicit (derived, so Comes_From_Source is False) subprogram declarations. In the case where the new primitive overrides an inherited subprogram, locate the primitives Elist that references the overridden subprogram, and replace that element of the list with the new subprogram (done by calling the new procedure Add_Or_Replace_Untagged_Primitive on the result type and each formal atype). (Check_For_Primitive_Subprogram.Add_Or_Replace_Untagged_Primitive): New nested procedure to either add or replace an untagged primitive subprogram in a given type's list of primitive operations (replacement happens in case where the new subprogram overrides a primitive of the type). * sem_ch7.adb (New_Private_Type): When Extensions_Allowed is True, initialize the Direct_Primitive_Operations list of a private type to New_Elmt_List in the case of untagged types. * sem_ch8.adb (Find_Selected_Component): In the case where the prefix is an entity name, relax condition that tests Has_Components so that Analyze_Selected_Component will also be called when Extensions_Allowed is True and the prefix type is any type. --- .../doc/gnat_rm/implementation_defined_pragmas.rst | 17 +++ gcc/ada/einfo.ads | 17 ++- gcc/ada/gen_il-gen-gen_entities.adb | 35 +---- gcc/ada/gnat_rm.texi | 18 +++ gcc/ada/sem_ch3.adb | 162 ++++++++++++++++----- gcc/ada/sem_ch4.adb | 60 +++++++- gcc/ada/sem_ch6.adb | 98 ++++++++++++- gcc/ada/sem_ch7.adb | 9 ++ gcc/ada/sem_ch8.adb | 14 +- 9 files changed, 346 insertions(+), 84 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index d86a2fd..c82658d 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2362,6 +2362,23 @@ of GNAT specific extensions are recognized as follows: knows the lower bound of unconstrained array formals when the formal's subtype has index ranges with static fixed lower bounds. +* Prefixed-view notation for calls to primitive subprograms of untagged types + + Since Ada 2005, calls to primitive subprograms of a tagged type that + have a "prefixed view" (see RM 4.1.3(9.2)) have been allowed to be + written using the form of a selected_component, with the first actual + parameter given as the prefix and the name of the subprogram as a + selector. This prefixed-view notation for calls is extended so as to + also allow such syntax for calls to primitive subprograms of untagged + types. The primitives of an untagged type T that have a prefixed view + are those where the first formal parameter of the subprogram either + is of type T or is an anonymous access parameter whose designated type + is T. For a type that has a component that happens to have the same + simple name as one of the type's primitive subprograms, where the + component is visible at the point of a selected_component using that + name, preference is given to the component in a selected_component + (as is currently the case for tagged types with such component names). + .. _Pragma-Extensions_Visible: Pragma Extensions_Visible diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 70b93b3..59588bb 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -933,14 +933,15 @@ package Einfo is -- Direct_Primitive_Operations -- Defined in tagged types and subtypes (including synchronized types), --- in tagged private types and in tagged incomplete types. Element list --- of entities for primitive operations of the tagged type. Not defined --- in untagged types. In order to follow the C++ ABI, entities of --- primitives that come from source must be stored in this list in the --- order of their occurrence in the sources. For incomplete types the --- list is always empty. --- When expansion is disabled the corresponding record type of a --- synchronized type is not constructed. In that case, such types +-- in tagged private types, and in tagged incomplete types. However, when +-- Extensions_Allowed is True (-gnatX), also defined for untagged types +-- (for support of the extension feature of prefixed calls for untagged +-- types). This field is an element list of entities for primitive +-- operations of the type. For incomplete types the list is always empty. +-- In order to follow the C++ ABI, entities of primitives that come from +-- source must be stored in this list in the order of their occurrence in +-- the sources. When expansion is disabled, the corresponding record type +-- of a synchronized type is not constructed. In that case, such types -- carry this attribute directly. -- Directly_Designated_Type diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index f5040b2..9538a74 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -461,6 +461,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Contract, Node_Id), Sm (Current_Use_Clause, Node_Id), Sm (Derived_Type_Link, Node_Id), + Sm (Direct_Primitive_Operations, Elist_Id), Sm (Predicates_Ignored, Flag), Sm (Esize, Uint), Sm (Finalize_Storage_Only, Flag, Base_Type_Only), @@ -560,11 +561,9 @@ begin -- Gen_IL.Gen.Gen_Entities Ab (Signed_Integer_Kind, Integer_Kind, (Sm (First_Entity, Node_Id))); - Cc (E_Signed_Integer_Type, Signed_Integer_Kind, + Cc (E_Signed_Integer_Type, Signed_Integer_Kind); -- Signed integer type, used for the anonymous base type of the -- integer subtype created by an integer type declaration. - (Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"))); Cc (E_Signed_Integer_Subtype, Signed_Integer_Kind); -- Signed integer subtype, created by either an integer subtype or @@ -648,14 +647,12 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (No_Strict_Aliasing, Flag, Base_Type_Only), Sm (Storage_Size_Variable, Node_Id, Impl_Base_Type_Only))); - Cc (E_Access_Type, Access_Kind, + Cc (E_Access_Type, Access_Kind); -- An access type created by an access type declaration with no all -- keyword present. Note that the predefined type Any_Access, which -- has E_Access_Type Ekind, is used to label NULL in the upwards pass -- of type analysis, to be replaced by the true access type in the -- downwards resolution pass. - (Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"))); Cc (E_Access_Subtype, Access_Kind); -- An access subtype created by a subtype declaration for any access @@ -739,8 +736,6 @@ begin -- Gen_IL.Gen.Gen_Entities -- An array subtype, created by an explicit array subtype declaration, -- or the use of an anonymous array subtype. (Sm (Predicated_Parent, Node_Id), - Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), Sm (First_Entity, Node_Id), Sm (Static_Real_Or_String_Predicate, Node_Id))); @@ -752,8 +747,6 @@ begin -- Gen_IL.Gen.Gen_Entities Ab (Class_Wide_Kind, Aggregate_Kind, (Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only), - Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), Sm (Equivalent_Type, Node_Id), Sm (First_Entity, Node_Id), Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only), @@ -785,8 +778,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only), Sm (Corresponding_Concurrent_Type, Node_Id), Sm (Corresponding_Remote_Type, Node_Id), - Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), Sm (Dispatch_Table_Wrappers, Elist_Id, Impl_Base_Type_Only), Sm (First_Entity, Node_Id), Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only), @@ -807,8 +798,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Cloned_Subtype, Node_Id), Sm (Corresponding_Remote_Type, Node_Id), Sm (Predicated_Parent, Node_Id), - Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), Sm (Dispatch_Table_Wrappers, Elist_Id, Impl_Base_Type_Only), Sm (First_Entity, Node_Id), Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only), @@ -841,8 +830,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only), Sm (Component_Alignment, Component_Alignment_Kind, Base_Type_Only), Sm (Corresponding_Remote_Type, Node_Id), - Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only), Sm (Has_Pragma_Pack, Flag, Impl_Base_Type_Only), Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only), @@ -861,8 +848,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Component_Alignment, Component_Alignment_Kind, Base_Type_Only), Sm (Corresponding_Remote_Type, Node_Id), Sm (Predicated_Parent, Node_Id), - Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only), Sm (Has_Pragma_Pack, Flag, Impl_Base_Type_Only), Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only), @@ -877,17 +862,13 @@ begin -- Gen_IL.Gen.Gen_Entities Cc (E_Private_Type, Private_Kind, -- A private type, created by a private type declaration that has -- neither the keyword limited nor the keyword tagged. - (Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), - Sm (Scalar_Range, Node_Id), + (Sm (Scalar_Range, Node_Id), Sm (Scope_Depth_Value, Uint))); Cc (E_Private_Subtype, Private_Kind, -- A subtype of a private type, created by a subtype declaration used -- to declare a subtype of a private type. - (Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), - Sm (Scope_Depth_Value, Uint))); + (Sm (Scope_Depth_Value, Uint))); Cc (E_Limited_Private_Type, Private_Kind, -- A limited private type, created by a private type declaration that @@ -901,9 +882,7 @@ begin -- Gen_IL.Gen.Gen_Entities (Sm (Scope_Depth_Value, Uint))); Ab (Incomplete_Kind, Incomplete_Or_Private_Kind, - (Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), - Sm (Non_Limited_View, Node_Id))); + (Sm (Non_Limited_View, Node_Id))); Cc (E_Incomplete_Type, Incomplete_Kind, -- An incomplete type, created by an incomplete type declaration @@ -915,8 +894,6 @@ begin -- Gen_IL.Gen.Gen_Entities Ab (Concurrent_Kind, Composite_Kind, (Sm (Corresponding_Record_Type, Node_Id), - Sm (Direct_Primitive_Operations, Elist_Id, - Pre => "Is_Tagged_Type (N)"), Sm (First_Entity, Node_Id), Sm (First_Private_Entity, Node_Id), Sm (Last_Entity, Node_Id), diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 771e6aa..19d6f33 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3793,6 +3793,24 @@ Use of this feature increases safety by simplifying code, and can also improve the efficiency of indexing operations, since the compiler statically knows the lower bound of unconstrained array formals when the formal’s subtype has index ranges with static fixed lower bounds. + +@item +Prefixed-view notation for calls to primitive subprograms of untagged types + +Since Ada 2005, calls to primitive subprograms of a tagged type that +have a “prefixed view” (see RM 4.1.3(9.2)) have been allowed to be +written using the form of a selected_component, with the first actual +parameter given as the prefix and the name of the subprogram as a +selector. This prefixed-view notation for calls is extended so as to +also allow such syntax for calls to primitive subprograms of untagged +types. The primitives of an untagged type T that have a prefixed view +are those where the first formal parameter of the subprogram either +is of type T or is an anonymous access parameter whose designated type +is T. For a type that has a component that happens to have the same +simple name as one of the type’s primitive subprograms, where the +component is visible at the point of a selected_component using that +name, preference is given to the component in a selected_component +(as is currently the case for tagged types with such component names). @end itemize @node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 95a27a2..936852c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3261,6 +3261,40 @@ package body Sem_Ch3 is return; end if; + -- Set the primitives list of the full type and its base type when + -- needed. T may be E_Void in cases of earlier errors, and in that + -- case we bypass this. + + if Ekind (T) /= E_Void + and then not Present (Direct_Primitive_Operations (T)) + then + if Etype (T) = T then + Set_Direct_Primitive_Operations (T, New_Elmt_List); + + -- If Etype of T is the base type (as opposed to a parent type) and + -- already has an associated list of primitive operations, then set + -- T's primitive list to the base type's list. Otherwise, create a + -- new empty primitives list and share the list between T and its + -- base type. The lists need to be shared in common between the two. + + elsif Etype (T) = Base_Type (T) then + + if not Present (Direct_Primitive_Operations (Base_Type (T))) then + Set_Direct_Primitive_Operations + (Base_Type (T), New_Elmt_List); + end if; + + Set_Direct_Primitive_Operations + (T, Direct_Primitive_Operations (Base_Type (T))); + + -- Case where the Etype is a parent type, so we need a new primitives + -- list for T. + + else + Set_Direct_Primitive_Operations (T, New_Elmt_List); + end if; + end if; + -- Some common processing for all types Set_Depends_On_Private (T, Has_Private_Component (T)); @@ -5706,6 +5740,14 @@ package body Sem_Ch3 is Inherit_Predicate_Flags (Id, T); end if; + -- When prefixed calls are enabled for untagged types, the subtype + -- shares the primitive operations of its base type. + + if Extensions_Allowed then + Set_Direct_Primitive_Operations + (Id, Direct_Primitive_Operations (Base_Type (T))); + end if; + if Etype (Id) = Any_Type then goto Leave; end if; @@ -9507,6 +9549,13 @@ package body Sem_Ch3 is end; end if; + -- When prefixed-call syntax is allowed for untagged types, initialize + -- the list of primitive operations to an empty list. + + if Extensions_Allowed and then not Is_Tagged then + Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); + end if; + -- Set fields for tagged types if Is_Tagged then @@ -9985,6 +10034,28 @@ package body Sem_Ch3 is return; end if; + -- If not already set, initialize the derived type's list of primitive + -- operations to an empty element list. + + if not Present (Direct_Primitive_Operations (Derived_Type)) then + Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); + + -- If Etype of the derived type is the base type (as opposed to + -- a parent type) and doesn't have an associated list of primitive + -- operations, then set the base type's primitive list to the + -- derived type's list. The lists need to be shared in common + -- between the two. + + if Etype (Derived_Type) = Base_Type (Derived_Type) + and then + not Present (Direct_Primitive_Operations (Etype (Derived_Type))) + then + Set_Direct_Primitive_Operations + (Etype (Derived_Type), + Direct_Primitive_Operations (Derived_Type)); + end if; + end if; + -- Set delayed freeze and then derive subprograms, we need to do this -- in this order so that derived subprograms inherit the derived freeze -- if necessary. @@ -21011,48 +21082,48 @@ package body Sem_Ch3 is end loop; end; - -- If the private view was tagged, copy the new primitive operations - -- from the private view to the full view. + declare + Disp_Typ : Entity_Id; + Full_List : Elist_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Priv_List : Elist_Id; + + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean; + -- Determine whether list L contains element E + + -------------- + -- Contains -- + -------------- + + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean + is + List_Elmt : Elmt_Id; - if Is_Tagged_Type (Full_T) then - declare - Disp_Typ : Entity_Id; - Full_List : Elist_Id; - Prim : Entity_Id; - Prim_Elmt : Elmt_Id; - Priv_List : Elist_Id; - - function Contains - (E : Entity_Id; - L : Elist_Id) return Boolean; - -- Determine whether list L contains element E - - -------------- - -- Contains -- - -------------- - - function Contains - (E : Entity_Id; - L : Elist_Id) return Boolean - is - List_Elmt : Elmt_Id; + begin + List_Elmt := First_Elmt (L); + while Present (List_Elmt) loop + if Node (List_Elmt) = E then + return True; + end if; - begin - List_Elmt := First_Elmt (L); - while Present (List_Elmt) loop - if Node (List_Elmt) = E then - return True; - end if; + Next_Elmt (List_Elmt); + end loop; - Next_Elmt (List_Elmt); - end loop; + return False; + end Contains; - return False; - end Contains; + -- Start of processing - -- Start of processing + begin + -- If the private view was tagged, copy the new primitive operations + -- from the private view to the full view. - begin + if Is_Tagged_Type (Full_T) then if Is_Tagged_Type (Priv_T) then Priv_List := Primitive_Operations (Priv_T); Prim_Elmt := First_Elmt (Priv_List); @@ -21186,8 +21257,23 @@ package body Sem_Ch3 is Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T); end if; - end; - end if; + + -- For untagged types, copy the primitives across from the private + -- view to the full view (when extensions are allowed), for support + -- of prefixed calls (when extensions are enabled). + + elsif Extensions_Allowed then + Priv_List := Primitive_Operations (Priv_T); + Prim_Elmt := First_Elmt (Priv_List); + + Full_List := Primitive_Operations (Full_T); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + Append_Elmt (Prim, Full_List); + Next_Elmt (Prim_Elmt); + end loop; + end if; + end; -- Ada 2005 AI 161: Check preelaborable initialization consistency diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d849834..eb1a556 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -5002,8 +5002,11 @@ package body Sem_Ch4 is -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the -- selected component should resolve to a name. + -- Extension feature: Also support calls with prefixed views for + -- untagged record types. + if Ada_Version >= Ada_2005 - and then Is_Tagged_Type (Prefix_Type) + and then (Is_Tagged_Type (Prefix_Type) or else Extensions_Allowed) and then not Is_Concurrent_Type (Prefix_Type) then if Nkind (Parent (N)) = N_Generic_Association @@ -5076,6 +5079,15 @@ package body Sem_Ch4 is Next_Entity (Comp); end loop; + -- Extension feature: Also support calls with prefixed views for + -- untagged private types. + + if Extensions_Allowed then + if Try_Object_Operation (N) then + return; + end if; + end if; + elsif Is_Concurrent_Type (Prefix_Type) then -- Find visible operation with given name. For a protected type, @@ -5328,6 +5340,14 @@ package body Sem_Ch4 is Set_Is_Overloaded (N, Is_Overloaded (Sel)); + -- Extension feature: Also support calls with prefixed views for + -- untagged types. + + elsif Extensions_Allowed + and then Try_Object_Operation (N) + then + return; + else -- Invalid prefix @@ -9536,7 +9556,11 @@ package body Sem_Ch4 is -- type, this is not a prefixed call. Restore the previous type as -- the current one is not a legal candidate. - if not Is_Tagged_Type (Obj_Type) + -- Extension feature: Calls with prefixed views are also supported + -- for untagged types, so skip the early return when extensions are + -- enabled. + + if (not Is_Tagged_Type (Obj_Type) and then not Extensions_Allowed) or else Is_Incomplete_Type (Obj_Type) then Obj_Type := Prev_Obj_Type; @@ -9554,6 +9578,36 @@ package body Sem_Ch4 is Try_Primitive_Operation (Call_Node => New_Call_Node, Node_To_Replace => Node_To_Replace); + + -- Extension feature: In the case where the prefix is of an + -- access type, and a primitive wasn't found for the designated + -- type, then if the access type has primitives we attempt a + -- prefixed call using one of its primitives. (It seems that + -- this isn't quite right to give preference to the designated + -- type in the case where both the access and designated types + -- have homographic prefixed-view operations that could result + -- in an ambiguity, but handling properly may be tricky. ???) + + if Extensions_Allowed + and then not Prim_Result + and then Is_Named_Access_Type (Prev_Obj_Type) + and then Present (Direct_Primitive_Operations (Prev_Obj_Type)) + then + -- Temporarily reset Obj_Type to the original access type + + Obj_Type := Prev_Obj_Type; + + Prim_Result := + Try_Primitive_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace); + + -- Restore Obj_Type to the designated type (is this really + -- necessary, or should it only be done when Prim_Result is + -- still False?). + + Obj_Type := Designated_Type (Obj_Type); + end if; end if; -- Check if there is a class-wide subprogram covering the @@ -9893,7 +9947,7 @@ package body Sem_Ch4 is -- be the corresponding record of a synchronized type. return Obj_Type = Typ - or else Base_Type (Obj_Type) = Typ + or else Base_Type (Obj_Type) = Base_Type (Typ) or else Corr_Type = Typ -- Object may be of a derived type whose parent has unknown diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index c7d4b96..abe8060 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -11022,6 +11022,12 @@ package body Sem_Ch6 is F_Typ : Entity_Id; B_Typ : Entity_Id; + procedure Add_Or_Replace_Untagged_Primitive (Typ : Entity_Id); + -- Either add the new subprogram to the list of primitives for + -- untagged type Typ, or if it overrides a primitive of Typ, then + -- replace the overridden primitive in Typ's primitives list with + -- the new subprogram. + function Visible_Part_Type (T : Entity_Id) return Boolean; -- Returns true if T is declared in the visible part of the current -- package scope; otherwise returns false. Assumes that T is declared @@ -11035,6 +11041,63 @@ package body Sem_Ch6 is -- in a private part, then it must override a function declared in -- the visible part. + --------------------------------------- + -- Add_Or_Replace_Untagged_Primitive -- + --------------------------------------- + + procedure Add_Or_Replace_Untagged_Primitive (Typ : Entity_Id) is + Replaced_Overridden_Subp : Boolean := False; + + begin + pragma Assert (not Is_Tagged_Type (Typ)); + + -- Anonymous access types don't have a primitives list. Normally + -- such types wouldn't make it here, but the case of anonymous + -- access-to-subprogram types can. + + if not Is_Anonymous_Access_Type (Typ) then + + -- If S overrides a subprogram that's a primitive of + -- the formal's type, then replace the overridden + -- subprogram with the new subprogram in the type's + -- list of primitives. + + if Is_Overriding then + pragma Assert (Present (Overridden_Subp) + and then Overridden_Subp = E); -- Added for now + + declare + Prim_Ops : constant Elist_Id := + Primitive_Operations (Typ); + Elmt : Elmt_Id; + begin + if Present (Prim_Ops) then + Elmt := First_Elmt (Prim_Ops); + + while Present (Elmt) + and then Node (Elmt) /= Overridden_Subp + loop + Next_Elmt (Elmt); + end loop; + + if Present (Elmt) then + Replace_Elmt (Elmt, S); + Replaced_Overridden_Subp := True; + end if; + end if; + end; + end if; + + -- If the new subprogram did not override an operation + -- of the formal's type, then add it to the primitives + -- list of the type. + + if not Replaced_Overridden_Subp then + Append_Unique_Elmt (S, Primitive_Operations (Typ)); + end if; + end if; + end Add_Or_Replace_Untagged_Primitive; + ------------------------------ -- Check_Private_Overriding -- ------------------------------ @@ -11213,7 +11276,17 @@ package body Sem_Ch6 is Is_Primitive := False; if not Comes_From_Source (S) then - null; + + -- Add an inherited primitive for an untagged derived type to + -- Derived_Type's list of primitives. Tagged primitives are dealt + -- with in Check_Dispatching_Operation. + + if Present (Derived_Type) + and then Extensions_Allowed + and then not Is_Tagged_Type (Derived_Type) + then + Append_Unique_Elmt (S, Primitive_Operations (Derived_Type)); + end if; -- If subprogram is at library level, it is not primitive operation @@ -11242,8 +11315,18 @@ package body Sem_Ch6 is Is_Primitive := True; Set_Has_Primitive_Operations (B_Typ); Set_Is_Primitive (S); - Check_Private_Overriding (B_Typ); + -- Add a primitive for an untagged type to B_Typ's list + -- of primitives. Tagged primitives are dealt with in + -- Check_Dispatching_Operation. + + if Extensions_Allowed + and then not Is_Tagged_Type (B_Typ) + then + Add_Or_Replace_Untagged_Primitive (B_Typ); + end if; + + Check_Private_Overriding (B_Typ); -- The Ghost policy in effect at the point of declaration -- or a tagged type and a primitive operation must match -- (SPARK RM 6.9(16)). @@ -11275,6 +11358,17 @@ package body Sem_Ch6 is Is_Primitive := True; Set_Is_Primitive (S); Set_Has_Primitive_Operations (B_Typ); + + -- Add a primitive for an untagged type to B_Typ's list + -- of primitives. Tagged primitives are dealt with in + -- Check_Dispatching_Operation. + + if Extensions_Allowed + and then not Is_Tagged_Type (B_Typ) + then + Add_Or_Replace_Untagged_Primitive (B_Typ); + end if; + Check_Private_Overriding (B_Typ); -- The Ghost policy in effect at the point of declaration diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 69ad184..f30a9aa 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2612,6 +2612,15 @@ package body Sem_Ch7 is elsif Abstract_Present (Def) then Error_Msg_N ("only a tagged type can be abstract", N); + + -- When extensions are enabled, we initialize the primitive operations + -- list of an untagged private type to an empty element list. (Note: + -- This could be done for all private types and shared with the tagged + -- case above, but for now we do it separately when the feature of + -- prefixed calls for untagged types is enabled.) + + elsif Extensions_Allowed then + Set_Direct_Primitive_Operations (Id, New_Elmt_List); end if; end New_Private_Type; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index aa33c50..d3bbfeb 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -7588,10 +7588,16 @@ package body Sem_Ch8 is P_Type := Implicitly_Designated_Type (P_Type); end if; - -- First check for components of a record object (not the - -- result of a call, which is handled below). - - if Has_Components (P_Type) + -- First check for components of a record object (not the result of + -- a call, which is handled below). This also covers the case where + -- where the extension feature that supports the prefixed form of + -- calls for primitives of untagged types is enabled (excluding + -- concurrent cases, which are handled further below). + + if Is_Type (P_Type) + and then (Has_Components (P_Type) + or else (Extensions_Allowed + and then not Is_Concurrent_Type (P_Type))) and then not Is_Overloadable (P_Name) and then not Is_Type (P_Name) then -- 2.7.4