From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id D56E2385803D; Mon, 16 May 2022 08:43:26 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org D56E2385803D MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-481] [Ada] Fix implementation issues with equality for untagged record types X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: 9a39b25f6f52f6eab159a096551e2576fa0890cd X-Git-Newrev: 909ce3528c800676fbbebe1f9a0047d14378861e Message-Id: <20220516084326.D56E2385803D@sourceware.org> Date: Mon, 16 May 2022 08:43:26 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Mon, 16 May 2022 08:43:26 -0000 https://gcc.gnu.org/g:909ce3528c800676fbbebe1f9a0047d14378861e commit r13-481-g909ce3528c800676fbbebe1f9a0047d14378861e Author: Eric Botcazou Date: Mon Feb 28 15:27:27 2022 +0100 [Ada] Fix implementation issues with equality for untagged record types This moves the implementation of AI12-0101 + AI05-0123 from the expander to the semantic analyzer and completes the implementation of AI12-0413, which are both binding interpretations in Ada 2012, fixing a few bugs in the process and removing a fair amount of duplicated code throughout. gcc/ada/ * einfo-utils.adb (Remove_Entity): Fix couple of oversights. * exp_ch3.adb (Is_User_Defined_Equality): Delete. (User_Defined_Eq): Call Get_User_Defined_Equality. (Make_Eq_Body): Likewise. (Predefined_Primitive_Eq_Body): Call Is_User_Defined_Equality. * exp_ch4.adb (Build_Eq_Call): Call Get_User_Defined_Equality. (Is_Equality): Delete. (User_Defined_Primitive_Equality_Op): Likewise. (Find_Aliased_Equality): Call Is_User_Defined_Equality. (Expand_N_Op_Eq): Call Underlying_Type unconditionally. Do not implement AI12-0101 + AI05-0123 here. (Expand_Set_Membership): Call Resolve_Membership_Equality. * exp_ch6.adb (Expand_Call_Helper): Remove obsolete code. * sem_aux.ads (Is_Record_Or_Limited_Type): Delete. * sem_aux.adb (Is_Record_Or_Limited_Type): Likewise. * sem_ch4.ads (Nondispatching_Call_To_Abstract_Operation): Declare. * sem_ch4.adb (Analyze_Call): Call Call_Abstract_Operation. (Analyze_Membership_Op): Call Resolve_Membership_Equality. (Nondispatching_Call_To_Abstract_Operation): New procedure. (Remove_Abstract_Operations): Call it. * sem_ch6.adb (Check_Untagged_Equality): Remove obsolete error and call Is_User_Defined_Equality. * sem_ch7.adb (Inspect_Untagged_Record_Completion): New procedure implementing AI12-0101 + AI05-0123. (Analyze_Package_Specification): Call it. (Declare_Inherited_Private_Subprograms): Minor tweak. (Uninstall_Declarations): Likewise. * sem_disp.adb (Check_Direct_Call): Adjust to new implementation of Is_User_Defined_Equality. * sem_res.ads (Resolve_Membership_Equality): Declare. * sem_res.adb (Resolve): Replace direct error handling with call to Nondispatching_Call_To_Abstract_Operation (Resolve_Call): Likewise. (Resolve_Equality_Op): Likewise. mplement AI12-0413. (Resolve_Membership_Equality): New procedure. (Resolve_Membership_Op): Call Get_User_Defined_Equality. * sem_util.ads (Get_User_Defined_Eq): Rename into... (Get_User_Defined_Equality): ...this. * sem_util.adb (Get_User_Defined_Eq): Rename into... (Get_User_Defined_Equality): ...this. Call Is_User_Defined_Equality. (Is_User_Defined_Equality): Also check the profile but remove tests on Comes_From_Source and Parent. * sinfo.ads (Generic_Parent_Type): Adjust field description. * uintp.ads (Ubool): Invoke user-defined equality in predicate. Diff: --- gcc/ada/einfo-utils.adb | 2 + gcc/ada/exp_ch3.adb | 93 ++++++++------------------- gcc/ada/exp_ch4.adb | 162 +++++------------------------------------------- gcc/ada/exp_ch6.adb | 10 --- gcc/ada/sem_aux.adb | 9 --- gcc/ada/sem_aux.ads | 3 - gcc/ada/sem_ch4.adb | 66 +++++++++++++------- gcc/ada/sem_ch4.ads | 6 ++ gcc/ada/sem_ch6.adb | 35 +++-------- gcc/ada/sem_ch7.adb | 101 +++++++++++++++++++++++++++--- gcc/ada/sem_disp.adb | 5 +- gcc/ada/sem_res.adb | 100 ++++++++++++++++++++++++------ gcc/ada/sem_res.ads | 3 + gcc/ada/sem_util.adb | 47 ++++++++------ gcc/ada/sem_util.ads | 2 +- gcc/ada/sinfo.ads | 2 +- gcc/ada/uintp.ads | 3 +- 17 files changed, 317 insertions(+), 332 deletions(-) diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 31d261a7ef3..cf61ec7de28 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -2520,11 +2520,13 @@ package body Einfo.Utils is elsif Id = First then Set_First_Entity (Scop, Next); + Set_Prev_Entity (Next, Empty); -- Empty <-- First_Entity -- The eliminated entity was the tail of the entity chain elsif Id = Last then Set_Last_Entity (Scop, Prev); + Set_Next_Entity (Prev, Empty); -- Last_Entity --> Empty -- Otherwise the eliminated entity comes from the middle of the entity -- chain. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index ef53591928b..f2deff74522 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -271,9 +271,6 @@ package body Exp_Ch3 is -- in a case statement, recursively. This latter pattern may occur for the -- initialization procedure of an unchecked union. - function Is_User_Defined_Equality (Prim : Node_Id) return Boolean; - -- Returns true if Prim is a user defined equality function - function Make_Eq_Body (Typ : Entity_Id; Eq_Name : Name_Id) return Node_Id; @@ -4487,7 +4484,6 @@ package body Exp_Ch3 is Comp : Entity_Id; Decl : Node_Id; Op : Entity_Id; - Prim : Elmt_Id; Eq_Op : Entity_Id; function User_Defined_Eq (T : Entity_Id) return Entity_Id; @@ -4506,7 +4502,7 @@ package body Exp_Ch3 is if Present (Op) then return Op; else - return Get_User_Defined_Eq (T); + return Get_User_Defined_Equality (T); end if; end User_Defined_Eq; @@ -4532,23 +4528,14 @@ package body Exp_Ch3 is -- If there is a user-defined equality for the type, we do not create -- the implicit one. - Prim := First_Elmt (Collect_Primitive_Operations (Typ)); - Eq_Op := Empty; - while Present (Prim) loop - if Chars (Node (Prim)) = Name_Op_Eq - and then Comes_From_Source (Node (Prim)) - - -- Don't we also need to check formal types and return type as in - -- User_Defined_Eq above??? - - then - Eq_Op := Node (Prim); + Eq_Op := Get_User_Defined_Equality (Typ); + if Present (Eq_Op) then + if Comes_From_Source (Eq_Op) then Build_Eq := False; - exit; + else + Eq_Op := Empty; end if; - - Next_Elmt (Prim); - end loop; + end if; -- If the type is derived, inherit the operation, if present, from the -- parent type. It may have been declared after the type derivation. If @@ -4557,35 +4544,28 @@ package body Exp_Ch3 is -- flags. Ditto for inequality. if No (Eq_Op) and then Is_Derived_Type (Typ) then - Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ))); - while Present (Prim) loop - if Chars (Node (Prim)) = Name_Op_Eq then - Copy_TSS (Node (Prim), Typ); - Build_Eq := False; + Eq_Op := Get_User_Defined_Equality (Etype (Typ)); + if Present (Eq_Op) then + Copy_TSS (Eq_Op, Typ); + Build_Eq := False; - declare - Op : constant Entity_Id := User_Defined_Eq (Typ); - Eq_Op : constant Entity_Id := Node (Prim); - NE_Op : constant Entity_Id := Next_Entity (Eq_Op); + declare + Op : constant Entity_Id := User_Defined_Eq (Typ); + NE_Op : constant Entity_Id := Next_Entity (Eq_Op); - begin - if Present (Op) then - Set_Alias (Op, Eq_Op); - Set_Is_Abstract_Subprogram - (Op, Is_Abstract_Subprogram (Eq_Op)); + begin + if Present (Op) then + Set_Alias (Op, Eq_Op); + Set_Is_Abstract_Subprogram + (Op, Is_Abstract_Subprogram (Eq_Op)); - if Chars (Next_Entity (Op)) = Name_Op_Ne then - Set_Is_Abstract_Subprogram - (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op)); - end if; + if Chars (Next_Entity (Op)) = Name_Op_Ne then + Set_Is_Abstract_Subprogram + (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op)); end if; - end; - - exit; - end if; - - Next_Elmt (Prim); - end loop; + end if; + end; + end if; end if; -- If not inherited and not user-defined, build body as for a type with @@ -9828,18 +9808,6 @@ package body Exp_Ch3 is return True; end Is_Null_Statement_List; - ------------------------------ - -- Is_User_Defined_Equality -- - ------------------------------ - - function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is - begin - return Chars (Prim) = Name_Op_Eq - and then Etype (First_Formal (Prim)) = - Etype (Next_Formal (First_Formal (Prim))) - and then Base_Type (Etype (Prim)) = Standard_Boolean; - end Is_User_Defined_Equality; - ---------------------------------------- -- Make_Controlling_Function_Wrappers -- ---------------------------------------- @@ -11212,15 +11180,8 @@ package body Exp_Ch3 is Prim := First_Elmt (Primitive_Operations (Tag_Typ)); while Present (Prim) loop - if Chars (Node (Prim)) = Name_Op_Eq + if Is_User_Defined_Equality (Node (Prim)) and then not Is_Internal (Node (Prim)) - - -- The predefined equality primitive must have exactly two - -- formals whose type is this tagged type. - - and then Number_Formals (Node (Prim)) = 2 - and then Etype (First_Formal (Node (Prim))) = Tag_Typ - and then Etype (Last_Formal (Node (Prim))) = Tag_Typ then Eq_Needed := False; Eq_Name := No_Name; @@ -11236,7 +11197,7 @@ package body Exp_Ch3 is Prim := First_Elmt (Primitive_Operations (Tag_Typ)); while Present (Prim) loop - if Chars (Node (Prim)) = Name_Op_Eq + if Is_User_Defined_Equality (Node (Prim)) and then Is_Internal (Node (Prim)) then Eq_Needed := True; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index f827fb037f9..99fac5f8b6b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -425,36 +425,21 @@ package body Exp_Ch4 is Lhs : Node_Id; Rhs : Node_Id) return Node_Id is - Prim : Node_Id; - Prim_E : Elmt_Id; + Eq : constant Entity_Id := Get_User_Defined_Equality (Typ); begin - Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); - while Present (Prim_E) loop - Prim := Node (Prim_E); + if Present (Eq) then + if Is_Abstract_Subprogram (Eq) then + return Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise); - -- Locate primitive equality with the right signature - - if Chars (Prim) = Name_Op_Eq - and then Etype (First_Formal (Prim)) = - Etype (Next_Formal (First_Formal (Prim))) - and then Etype (Prim) = Standard_Boolean - then - if Is_Abstract_Subprogram (Prim) then - return - Make_Raise_Program_Error (Loc, - Reason => PE_Explicit_Raise); - - else - return - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Prim, Loc), - Parameter_Associations => New_List (Lhs, Rhs)); - end if; + else + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Eq, Loc), + Parameter_Associations => New_List (Lhs, Rhs)); end if; - - Next_Elmt (Prim_E); - end loop; + end if; -- If not found, predefined operation will be used @@ -7817,21 +7802,10 @@ package body Exp_Ch4 is -- build and analyze call, adding conversions if the operation is -- inherited. - function Is_Equality (Subp : Entity_Id; - Typ : Entity_Id := Empty) return Boolean; - -- Determine whether arbitrary Entity_Id denotes a function with the - -- right name and profile for an equality op, specifically for the - -- base type Typ if Typ is nonempty. - function Find_Equality (Prims : Elist_Id) return Entity_Id; -- Find a primitive equality function within primitive operation list -- Prims. - function User_Defined_Primitive_Equality_Op - (Typ : Entity_Id) return Entity_Id; - -- Find a user-defined primitive equality function for a given untagged - -- record type, ignoring visibility. Return Empty if no such op found. - function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean; -- Determines whether a type has a subcomponent of an unconstrained -- Unchecked_Union subtype. Typ is a record type. @@ -8080,43 +8054,6 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end Build_Equality_Call; - ----------------- - -- Is_Equality -- - ----------------- - - function Is_Equality (Subp : Entity_Id; - Typ : Entity_Id := Empty) return Boolean is - Formal_1 : Entity_Id; - Formal_2 : Entity_Id; - begin - -- The equality function carries name "=", returns Boolean, and has - -- exactly two formal parameters of an identical type. - - if Ekind (Subp) = E_Function - and then Chars (Subp) = Name_Op_Eq - and then Base_Type (Etype (Subp)) = Standard_Boolean - then - Formal_1 := First_Formal (Subp); - Formal_2 := Empty; - - if Present (Formal_1) then - Formal_2 := Next_Formal (Formal_1); - end if; - - return - Present (Formal_1) - and then Present (Formal_2) - and then No (Next_Formal (Formal_2)) - and then Base_Type (Etype (Formal_1)) = - Base_Type (Etype (Formal_2)) - and then - (not Present (Typ) - or else Implementation_Base_Type (Etype (Formal_1)) = Typ); - end if; - - return False; - end Is_Equality; - ------------------- -- Find_Equality -- ------------------- @@ -8139,7 +8076,7 @@ package body Exp_Ch4 is Candid := Prim; while Present (Candid) loop - if Is_Equality (Candid) then + if Is_User_Defined_Equality (Candid) then return Candid; end if; @@ -8178,43 +8115,6 @@ package body Exp_Ch4 is return Eq_Prim; end Find_Equality; - ---------------------------------------- - -- User_Defined_Primitive_Equality_Op -- - ---------------------------------------- - - function User_Defined_Primitive_Equality_Op - (Typ : Entity_Id) return Entity_Id - is - Enclosing_Scope : constant Entity_Id := Scope (Typ); - E : Entity_Id; - begin - for Private_Entities in Boolean loop - if Private_Entities then - if Ekind (Enclosing_Scope) /= E_Package then - exit; - end if; - E := First_Private_Entity (Enclosing_Scope); - - else - E := First_Entity (Enclosing_Scope); - end if; - - while Present (E) loop - if Is_Equality (E, Typ) then - return E; - end if; - Next_Entity (E); - end loop; - end loop; - - if Is_Derived_Type (Typ) then - return User_Defined_Primitive_Equality_Op - (Implementation_Base_Type (Etype (Typ))); - end if; - - return Empty; - end User_Defined_Primitive_Equality_Op; - ------------------------------------ -- Has_Unconstrained_UU_Component -- ------------------------------------ @@ -8358,14 +8258,7 @@ package body Exp_Ch4 is -- Deal with private types - Typl := A_Typ; - - if Ekind (Typl) = E_Private_Type then - Typl := Underlying_Type (Typl); - - elsif Ekind (Typl) = E_Private_Subtype then - Typl := Underlying_Type (Base_Type (Typl)); - end if; + Typl := Underlying_Type (A_Typ); -- It may happen in error situations that the underlying type is not -- set. The error will be detected later, here we just defend the @@ -8529,15 +8422,6 @@ package body Exp_Ch4 is (Find_Equality (Primitive_Operations (Typl))); end if; - -- See AI12-0101 (which only removes a legality rule) and then - -- AI05-0123 (which then applies in the previously illegal case). - -- AI12-0101 is a binding interpretation. - - elsif Ada_Version >= Ada_2012 - and then Present (User_Defined_Primitive_Equality_Op (Typl)) - then - Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl)); - -- Ada 2005 (AI-216): Program_Error is raised when evaluating the -- predefined equality operator for a type which has a subcomponent -- of an Unchecked_Union type whose nominal subtype is unconstrained. @@ -13132,23 +13016,11 @@ package body Exp_Ch4 is if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt))) or else Nkind (Alt) = N_Range then - Cond := - Make_In (Sloc (Alt), - Left_Opnd => L, - Right_Opnd => R); - else - Cond := - Make_Op_Eq (Sloc (Alt), - Left_Opnd => L, - Right_Opnd => R); - - if Is_Record_Or_Limited_Type (Etype (Alt)) then + Cond := Make_In (Sloc (Alt), Left_Opnd => L, Right_Opnd => R); - -- We reset the Entity in order to use the primitive equality - -- of the type, as per RM 4.5.2 (28.1/4). - - Set_Entity (Cond, Empty); - end if; + else + Cond := Make_Op_Eq (Sloc (Alt), Left_Opnd => L, Right_Opnd => R); + Resolve_Membership_Equality (Cond, Etype (Alt)); end if; return Cond; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3ceb55d51da..db5ec357bea 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4475,16 +4475,6 @@ package body Exp_Ch6 is Set_Entity (Name (Call_Node), Parent_Subp); - -- Move this check to sem??? - - if Is_Abstract_Subprogram (Parent_Subp) - and then not In_Instance - then - Error_Msg_NE - ("cannot call abstract subprogram &!", - Name (Call_Node), Parent_Subp); - end if; - -- Inspect all formals of derived subprogram Subp. Compare parameter -- types with the parent subprogram and check whether an actual may -- need a type conversion to the corresponding formal of the parent diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 88948f73473..ffbfc712b31 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1261,15 +1261,6 @@ package body Sem_Aux is end if; end Is_Limited_View; - ------------------------------- - -- Is_Record_Or_Limited_Type -- - ------------------------------- - - function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean is - begin - return Is_Record_Type (Typ) or else Is_Limited_Type (Typ); - end Is_Record_Or_Limited_Type; - ---------------------- -- Nearest_Ancestor -- ---------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 719fad5bd7b..66cbcfbb97c 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -334,9 +334,6 @@ package Sem_Aux is -- these types). This older routine overlaps with the previous one, this -- should be cleaned up??? - function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean; - -- Return True if Typ requires is a record or limited type. - function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id; -- Given a subtype Typ, this function finds out the nearest ancestor from -- which constraints and predicates are inherited. There is no simple link diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 84b7ce199b1..8fe20772a69 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1253,19 +1253,11 @@ package body Sem_Ch4 is -- If the nonoverloaded interpretation is a call to an abstract -- nondispatching operation, then flag an error and return. - -- Should this be incorporated in Remove_Abstract_Operations (which - -- currently only deals with cases where the name is overloaded)? ??? - if Is_Overloadable (Nam_Ent) and then Is_Abstract_Subprogram (Nam_Ent) and then not Is_Dispatching_Operation (Nam_Ent) then - Set_Etype (N, Any_Type); - - Error_Msg_Sloc := Sloc (Nam_Ent); - Error_Msg_NE - ("cannot call abstract operation& declared#", N, Nam_Ent); - + Nondispatching_Call_To_Abstract_Operation (N, Nam_Ent); return; end if; @@ -3386,18 +3378,11 @@ package body Sem_Ch4 is Check_Fully_Declared (Entity (R), R); elsif Ada_Version >= Ada_2012 and then Find_Interp then - if Nkind (N) = N_In then - Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); - else - Op := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); - end if; + Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); + Resolve_Membership_Equality (Op, Etype (L)); - if Is_Record_Or_Limited_Type (Etype (L)) then - - -- We reset the Entity in order to use the primitive equality - -- of the type, as per RM 4.5.2 (28.1/4). - - Set_Entity (Op, Empty); + if Nkind (N) = N_Not_In then + Op := Make_Op_Not (Loc, Op); end if; Rewrite (N, Op); @@ -7872,6 +7857,42 @@ package body Sem_Ch4 is return Etype (N) /= Any_Type; end Has_Possible_Literal_Aspects; + ----------------------------------------------- + -- Nondispatching_Call_To_Abstract_Operation -- + ----------------------------------------------- + + procedure Nondispatching_Call_To_Abstract_Operation + (N : Node_Id; + Abstract_Op : Entity_Id) + is + Typ : constant Entity_Id := Etype (N); + + begin + -- In an instance body, this is a runtime check, but one we know will + -- fail, so give an appropriate warning. As usual this kind of warning + -- is an error in SPARK mode. + + Error_Msg_Sloc := Sloc (Abstract_Op); + + if In_Instance_Body and then SPARK_Mode /= On then + Error_Msg_NE + ("??cannot call abstract operation& declared#", + N, Abstract_Op); + Error_Msg_N ("\Program_Error [??", N); + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Explicit_Raise)); + Analyze (N); + Set_Etype (N, Typ); + + else + Error_Msg_NE + ("cannot call abstract operation& declared#", + N, Abstract_Op); + Set_Etype (N, Any_Type); + end if; + end Nondispatching_Call_To_Abstract_Operation; + ---------------------------------------------- -- Possible_Type_For_Conditional_Expression -- ---------------------------------------------- @@ -8191,10 +8212,7 @@ package body Sem_Ch4 is -- Removal of abstract operation left no viable candidate - Set_Etype (N, Any_Type); - Error_Msg_Sloc := Sloc (Abstract_Op); - Error_Msg_NE - ("cannot call abstract operation& declared#", N, Abstract_Op); + Nondispatching_Call_To_Abstract_Operation (N, Abstract_Op); -- In Ada 2005, an abstract operation may disable predefined -- operators. Since the context is not yet known, we mark the diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index 870edea0b64..ed2b132aaeb 100644 --- a/gcc/ada/sem_ch4.ads +++ b/gcc/ada/sem_ch4.ads @@ -67,6 +67,12 @@ package Sem_Ch4 is -- The resolution of the construct requires some semantic information -- on the prefix and the indexes. + procedure Nondispatching_Call_To_Abstract_Operation + (N : Node_Id; + Abstract_Op : Entity_Id); + -- Give an error, or a warning and rewrite N to raise Program_Error because + -- it is a nondispatching call to an abstract operation. + function Try_Object_Operation (N : Node_Id; CW_Test_Only : Boolean := False; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index be093d6863f..dbcb2556fe3 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -190,14 +190,12 @@ package body Sem_Ch6 is -- in posting the warning message. procedure Check_Untagged_Equality (Eq_Op : Entity_Id); - -- In Ada 2012, a primitive equality operator on an untagged record type - -- must appear before the type is frozen, and have the same visibility as - -- that of the type. This procedure checks that this rule is met, and - -- otherwise emits an error on the subprogram declaration and a warning - -- on the earlier freeze point if it is easy to locate. In Ada 2012 mode, - -- this routine outputs errors (or warnings if -gnatd.E is set). In earlier - -- versions of Ada, warnings are output if Warn_On_Ada_2012_Incompatibility - -- is set, otherwise the call has no effect. + -- In Ada 2012, a primitive equality operator for an untagged record type + -- must appear before the type is frozen. This procedure checks that this + -- rule is met, and otherwise gives an error on the subprogram declaration + -- and a warning on the earlier freeze point if it is easy to pinpoint. In + -- earlier versions of Ada, the call has not effect, unless compatibility + -- warnings are requested by means of Warn_On_Ada_2012_Incompatibility. procedure Enter_Overloaded_Entity (S : Entity_Id); -- This procedure makes S, a new overloaded entity, into the first visible @@ -9511,12 +9509,12 @@ package body Sem_Ch6 is begin -- This check applies only if we have a subprogram declaration with an - -- untagged record type that is conformant to the predefined op. + -- untagged record type that is conformant to the predefined operator. if Nkind (Decl) /= N_Subprogram_Declaration or else not Is_Record_Type (Typ) or else Is_Tagged_Type (Typ) - or else Etype (Next_Formal (First_Formal (Eq_Op))) /= Typ + or else not Is_User_Defined_Equality (Eq_Op) then return; end if; @@ -9628,22 +9626,7 @@ package body Sem_Ch6 is end if; end if; - -- Here if type is not frozen yet. It is illegal to have a primitive - -- equality declared in the private part if the type is visible - -- (RM 4.5.2(9.8)). - - elsif not In_Same_List (Parent (Typ), Decl) - and then not Is_Limited_Type (Typ) - then - if Ada_Version >= Ada_2012 then - Error_Msg_N - ("equality operator appears too late<<", Eq_Op); - else - Error_Msg_N - ("equality operator appears too late (Ada 2012)?y?", Eq_Op); - end if; - - -- Finally check for AI12-0352: declaration of a user-defined primitive + -- Now check for AI12-0352: the declaration of a user-defined primitive -- equality operation for a record type T is illegal if it occurs after -- a type has been derived from T. diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index e94971f8ede..4ba1d32cf7c 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1313,6 +1313,11 @@ package body Sem_Ch7 is -- Reject completion of an incomplete or private type declarations -- having a known discriminant part by an unchecked union. + procedure Inspect_Untagged_Record_Completion (Decls : List_Id); + -- Find out whether a nonlimited untagged record completion has got a + -- primitive equality operator and, if so, make it so that it will be + -- used as the predefined operator of the private view of the record. + procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id); -- Given the package entity of a generic package instantiation or -- formal package whose corresponding generic is a child unit, installs @@ -1437,7 +1442,7 @@ package body Sem_Ch7 is Decl := First (Decls); while Present (Decl) loop - -- We are looking at an incomplete or private type declaration + -- We are looking for an incomplete or private type declaration -- with a known_discriminant_part whose full view is an -- Unchecked_Union. The seemingly useless check with Is_Type -- prevents cascaded errors when routines defined only for type @@ -1461,6 +1466,79 @@ package body Sem_Ch7 is end loop; end Inspect_Unchecked_Union_Completion; + ---------------------------------------- + -- Inspect_Untagged_Record_Completion -- + ---------------------------------------- + + procedure Inspect_Untagged_Record_Completion (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- We are looking for a full type declaration of an untagged + -- record with a private declaration and primitive operations. + + if Nkind (Decl) in N_Full_Type_Declaration + and then Is_Record_Type (Defining_Identifier (Decl)) + and then not Is_Limited_Type (Defining_Identifier (Decl)) + and then not Is_Tagged_Type (Defining_Identifier (Decl)) + and then Has_Private_Declaration (Defining_Identifier (Decl)) + and then Has_Primitive_Operations (Defining_Identifier (Decl)) + then + declare + Prim_List : constant Elist_Id := + Collect_Primitive_Operations (Defining_Identifier (Decl)); + + Ne_Id : Entity_Id; + Op_Decl : Node_Id; + Op_Id : Entity_Id; + Prim : Elmt_Id; + + begin + Prim := First_Elmt (Prim_List); + while Present (Prim) loop + Op_Id := Node (Prim); + Op_Decl := Declaration_Node (Op_Id); + if Nkind (Op_Decl) in N_Subprogram_Specification then + Op_Decl := Parent (Op_Decl); + end if; + + -- We are looking for an equality operator immediately + -- visible and declared in the private part followed by + -- the synthesized inequality operator. + + if Is_User_Defined_Equality (Op_Id) + and then Is_Immediately_Visible (Op_Id) + and then List_Containing (Op_Decl) = Decls + then + Ne_Id := Next_Entity (Op_Id); + pragma Assert (Ekind (Ne_Id) = E_Function + and then Corresponding_Equality (Ne_Id) = Op_Id); + + -- Move them from the private part of the entity list + -- up to the end of the visible part of the same list. + + Remove_Entity (Op_Id); + Remove_Entity (Ne_Id); + + Link_Entities + (Prev_Entity (First_Private_Entity (Id)), Op_Id); + Link_Entities (Op_Id, Ne_Id); + Link_Entities (Ne_Id, First_Private_Entity (Id)); + exit; + end if; + + Next_Elmt (Prim); + end loop; + end; + end if; + + Next (Decl); + end loop; + end Inspect_Untagged_Record_Completion; + ----------------------------------------- -- Install_Parent_Private_Declarations -- ----------------------------------------- @@ -1718,7 +1796,7 @@ package body Sem_Ch7 is end if; -- Analyze private part if present. The flag In_Private_Part is reset - -- in End_Package_Scope. + -- in Uninstall_Declarations. L := Last_Entity (Id); @@ -1815,6 +1893,14 @@ package body Sem_Ch7 is Inspect_Unchecked_Union_Completion (Priv_Decls); end if; + -- Implement AI12-0101 (which only removes a legality rule) and then + -- AI05-0123 (which directly applies in the previously illegal case) + -- in Ada 2012. Note that AI12-0101 is a binding interpretation. + + if Present (Priv_Decls) and then Ada_Version >= Ada_2012 then + Inspect_Untagged_Record_Completion (Priv_Decls); + end if; + if Ekind (Id) = E_Generic_Package and then Nkind (Orig_Decl) = N_Generic_Package_Declaration and then Present (Priv_Decls) @@ -2172,9 +2258,8 @@ package body Sem_Ch7 is -- a derived scalar type). Further declarations cannot -- include inherited operations of the type. - if Present (Prim_Op) then - exit when Ekind (Prim_Op) not in Overloadable_Kind; - end if; + exit when Present (Prim_Op) + and then not Is_Overloadable (Prim_Op); end loop; end if; end if; @@ -3093,10 +3178,12 @@ package body Sem_Ch7 is if not In_Private_Part (P) then return; - else - Set_In_Private_Part (P, False); end if; + -- Reset the flag now + + Set_In_Private_Part (P, False); + -- Make private entities invisible and exchange full and private -- declarations for private types. Id is now the first private entity -- in the package. diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index cafe2c379f2..2ab14439e94 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -566,7 +566,10 @@ package body Sem_Disp is -- when it is user-defined. if Is_Predefined_Dispatching_Operation (Subp_Entity) - and then not Is_User_Defined_Equality (Subp_Entity) + and then not (Is_User_Defined_Equality (Subp_Entity) + and then Comes_From_Source (Subp_Entity) + and then Nkind (Parent (Subp_Entity)) = + N_Function_Specification) then return; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4306e49ed76..12735daab6d 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3215,11 +3215,11 @@ package body Sem_Res is then Get_First_Interp (N, I, It); while Present (It.Typ) loop - if Present (It.Abstract_Op) and then - Etype (It.Abstract_Op) = Typ + if Present (It.Abstract_Op) + and then Etype (It.Abstract_Op) = Typ then - Error_Msg_NE - ("cannot call abstract subprogram &!", N, It.Abstract_Op); + Nondispatching_Call_To_Abstract_Operation + (N, It.Abstract_Op); return; end if; @@ -7063,24 +7063,19 @@ package body Sem_Res is -- If the subprogram is a primitive operation, check whether or not -- it is a correct dispatching call. - if Is_Overloadable (Nam) - and then Is_Dispatching_Operation (Nam) - then + if Is_Overloadable (Nam) and then Is_Dispatching_Operation (Nam) then Check_Dispatching_Call (N); - elsif Ekind (Nam) /= E_Subprogram_Type - and then Is_Abstract_Subprogram (Nam) - and then not In_Instance - then - Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); + -- If the subprogram is an abstract operation, then flag an error + + elsif Is_Overloadable (Nam) and then Is_Abstract_Subprogram (Nam) then + Nondispatching_Call_To_Abstract_Operation (N, Nam); end if; -- If this is a dispatching call, generate the appropriate reference, -- for better source navigation in GNAT Studio. - if Is_Overloadable (Nam) - and then Present (Controlling_Argument (N)) - then + if Is_Overloadable (Nam) and then Present (Controlling_Argument (N)) then Generate_Reference (Nam, Subp, 'R'); -- Normal case, not a dispatching call: generate a call reference @@ -8918,6 +8913,41 @@ package body Sem_Res is Resolve (L, T); Resolve (R, T); + -- AI12-0413: user-defined primitive equality of an untagged record + -- type hides the predefined equality operator, including within a + -- generic, and if it is declared abstract, results in an illegal + -- instance if the operator is used in the spec, or in the raising + -- of Program_Error if used in the body of an instance. + + if Nkind (N) = N_Op_Eq + and then In_Instance + and then Ada_Version >= Ada_2012 + then + declare + U : constant Entity_Id := Underlying_Type (T); + + Eq : Entity_Id; + + begin + if Present (U) + and then Is_Record_Type (U) + and then not Is_Tagged_Type (U) + then + Eq := Get_User_Defined_Equality (T); + + if Present (Eq) then + if Is_Abstract_Subprogram (Eq) then + Nondispatching_Call_To_Abstract_Operation (N, Eq); + else + Rewrite_Operator_As_Call (N, Eq); + end if; + + return; + end if; + end if; + end; + end if; + -- If the unique type is a class-wide type then it will be expanded -- into a dispatching call to the predefined primitive. Therefore we -- check here for potential violation of such restriction. @@ -8977,8 +9007,8 @@ package body Sem_Res is if Nkind (N) = N_Op_Eq or else Comes_From_Source (Entity (N)) or else Ekind (Entity (N)) = E_Operator - or else Is_Intrinsic_Subprogram - (Corresponding_Equality (Entity (N))) + or else + Is_Intrinsic_Subprogram (Corresponding_Equality (Entity (N))) then Analyze_Dimension (N); Eval_Relational_Op (N); @@ -8986,7 +9016,7 @@ package body Sem_Res is elsif Nkind (N) = N_Op_Ne and then Is_Abstract_Subprogram (Entity (N)) then - Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); + Nondispatching_Call_To_Abstract_Operation (N, Entity (N)); end if; end if; end Resolve_Equality_Op; @@ -9837,6 +9867,38 @@ package body Sem_Res is Eval_Logical_Op (N); end Resolve_Logical_Op; + --------------------------------- + -- Resolve_Membership_Equality -- + --------------------------------- + + procedure Resolve_Membership_Equality (N : Node_Id; Typ : Entity_Id) is + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + -- RM 4.5.2(4.1/3): if the type is limited, then it shall have a visible + -- primitive equality operator. This means that we can use the regular + -- visibility-based resolution and reset Entity in order to trigger it. + + if Is_Limited_Type (Typ) then + Set_Entity (N, Empty); + + -- RM 4.5.2(28.1/3): if the type is a record, then the membership test + -- uses the primitive equality for the type [even if it is not visible]. + -- We only deal with the untagged case here, because the tagged case is + -- handled uniformly in the expander. + + elsif Is_Record_Type (Utyp) and then not Is_Tagged_Type (Utyp) then + declare + Eq_Id : constant Entity_Id := Get_User_Defined_Equality (Typ); + + begin + if Present (Eq_Id) then + Rewrite_Operator_As_Call (N, Eq_Id); + end if; + end; + end if; + end Resolve_Membership_Equality; + --------------------------- -- Resolve_Membership_Op -- --------------------------- @@ -9953,7 +10015,7 @@ package body Sem_Res is -- following warning appears useful for the most common case. if Is_Scalar_Type (Etype (L)) - and then Present (Get_User_Defined_Eq (Etype (L))) + and then Present (Get_User_Defined_Equality (Etype (L))) then Error_Msg_NE ("membership test on& uses predefined equality?", N, Etype (L)); diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index 29a5005d609..4e97b7ac250 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -125,6 +125,9 @@ package Sem_Res is -- own type. For now we assume that the prefix cannot be overloaded and -- the name of the entry plays no role in the resolution. + procedure Resolve_Membership_Equality (N : Node_Id; Typ : Entity_Id); + -- Resolve the equality operator in an individual membership test + function Valid_Conversion (N : Node_Id; Target : Entity_Id; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ea0a55a8e31..1ea9fd93898 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11770,32 +11770,25 @@ package body Sem_Util is return Task_Body_Procedure (Underlying_Type (Root_Type (E))); end Get_Task_Body_Procedure; - ------------------------- - -- Get_User_Defined_Eq -- - ------------------------- + ------------------------------- + -- Get_User_Defined_Equality -- + ------------------------------- - function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is + function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id is Prim : Elmt_Id; - Op : Entity_Id; begin Prim := First_Elmt (Collect_Primitive_Operations (E)); while Present (Prim) loop - Op := Node (Prim); - - if Chars (Op) = Name_Op_Eq - and then Etype (Op) = Standard_Boolean - and then Etype (First_Formal (Op)) = E - and then Etype (Next_Formal (First_Formal (Op))) = E - then - return Op; + if Is_User_Defined_Equality (Node (Prim)) then + return Node (Prim); end if; Next_Elmt (Prim); end loop; return Empty; - end Get_User_Defined_Eq; + end Get_User_Defined_Equality; --------------- -- Get_Views -- @@ -21498,15 +21491,31 @@ package body Sem_Util is ------------------------------ function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is + F1, F2 : Entity_Id; + begin - return Ekind (Id) = E_Function + -- An equality operator is a function that carries the name "=", returns + -- Boolean, and has exactly two formal parameters of an identical type. + + if Ekind (Id) = E_Function and then Chars (Id) = Name_Op_Eq - and then Comes_From_Source (Id) + and then Base_Type (Etype (Id)) = Standard_Boolean + then + F1 := First_Formal (Id); + + if No (F1) then + return False; + end if; - -- Internally generated equalities have a full type declaration - -- as their parent. + F2 := Next_Formal (F1); - and then Nkind (Parent (Id)) = N_Function_Specification; + return Present (F2) + and then No (Next_Formal (F2)) + and then Base_Type (Etype (F1)) = Base_Type (Etype (F2)); + + else + return False; + end if; end Is_User_Defined_Equality; ----------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e5e1d01c905..323f43f94de 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1338,7 +1338,7 @@ package Sem_Util is -- Given an entity for a task type or subtype, retrieves the -- Task_Body_Procedure field from the corresponding task type declaration. - function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id; + function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id; -- For a type entity, return the entity of the primitive equality function -- for the type if it exists, otherwise return Empty. diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index dcfe75e6528..19f761832ac 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2826,7 +2826,7 @@ package Sinfo is -- Defining_Identifier -- Null_Exclusion_Present -- Subtype_Indication - -- Generic_Parent_Type (set for an actual derived type). + -- Generic_Parent_Type (for actual of formal private or derived type) -- Exception_Junk ------------------------------- diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index 05b4e6efcb2..55f5b971754 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -105,7 +105,8 @@ package Uintp is subtype Upos is Valid_Uint with Predicate => Upos >= Uint_1; -- positive subtype Nonzero_Uint is Valid_Uint with Predicate => Nonzero_Uint /= Uint_0; subtype Unegative is Valid_Uint with Predicate => Unegative < Uint_0; - subtype Ubool is Valid_Uint with Predicate => Ubool in Uint_0 | Uint_1; + subtype Ubool is Valid_Uint with + Predicate => Ubool = Uint_0 or else Ubool = Uint_1; subtype Opt_Ubool is Uint with Predicate => No (Opt_Ubool) or else Opt_Ubool in Ubool;