public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-481] [Ada] Fix implementation issues with equality for untagged record types
@ 2022-05-16 8:43 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-16 8:43 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:909ce3528c800676fbbebe1f9a0047d14378861e
commit r13-481-g909ce3528c800676fbbebe1f9a0047d14378861e
Author: Eric Botcazou <ebotcazou@adacore.com>
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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-16 8:43 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-16 8:43 [gcc r13-481] [Ada] Fix implementation issues with equality for untagged record types Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).