public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-1661] [Ada] Plug legality loophole for equality operator of untagged record types
@ 2022-07-13 10:03 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-07-13 10:03 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:05e91ac1f89dc0b4757ac7e8ffaacd65bcdc4794
commit r13-1661-g05e91ac1f89dc0b4757ac7e8ffaacd65bcdc4794
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Sun Jul 3 18:41:56 2022 +0200
[Ada] Plug legality loophole for equality operator of untagged record types
In Ada 2012, the RM 4.5.2(9.8) clause prevents an equality operator for an
untagged record type from being declared after the type is frozen. While
the clause is implemented in GNAT, the implementation has a loophole which
lets subprogram bodies that are not the completion of a declaration pass
the check without being flagged.
gcc/ada/
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Acts_As_Spec
earlier if the body is not the completion of a declaration.
(Check_Untagged_Equality): Deal with subprogram bodies that are
not the completion of a declaration and make sure that they are
not flagged when they cause the freezing of the type themselves.
Give a warning on the freezing point of the type in more cases.
* sem_res.adb (Resolve_Equality_Op): Revert latest change.
Diff:
---
gcc/ada/sem_ch6.adb | 222 +++++++++++++++++++++++++++++++++++++---------------
gcc/ada/sem_res.adb | 9 +--
2 files changed, 162 insertions(+), 69 deletions(-)
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 4d766b9433b..e4af71cef26 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4743,6 +4743,12 @@ package body Sem_Ch6 is
Style.Body_With_No_Spec (N);
end if;
+ -- First set Acts_As_Spec if appropriate
+
+ if Nkind (N) /= N_Subprogram_Body_Stub then
+ Set_Acts_As_Spec (N);
+ end if;
+
New_Overloaded_Entity (Body_Id);
-- A subprogram body should cause freezing of its own declaration,
@@ -4767,7 +4773,6 @@ package body Sem_Ch6 is
end if;
if Nkind (N) /= N_Subprogram_Body_Stub then
- Set_Acts_As_Spec (N);
Generate_Definition (Body_Id);
Generate_Reference
(Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
@@ -9525,15 +9530,85 @@ package body Sem_Ch6 is
-----------------------------
procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
- Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
- Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
- Obj_Decl : Node_Id;
+ Eq_Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
+ Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
+
+ procedure Freezing_Point_Warning (N : Node_Id; S : String);
+ -- Output a warning about the freezing point N of Typ
+
+ function Is_Actual_Of_Instantiation
+ (E : Entity_Id;
+ Inst : Node_Id) return Boolean;
+ -- Return True if E is an actual parameter of instantiation Inst
+
+ -----------------------------------
+ -- Output_Freezing_Point_Warning --
+ -----------------------------------
+
+ procedure Freezing_Point_Warning (N : Node_Id; S : String) is
+ begin
+ Error_Msg_String (1 .. S'Length) := S;
+ Error_Msg_Strlen := S'Length;
+
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_NE ("type& is frozen by ~??", N, Typ);
+ Error_Msg_N
+ ("\an equality operator cannot be declared after this point??",
+ N);
+
+ else
+ Error_Msg_NE ("type& is frozen by ~ (Ada 2012)?y?", N, Typ);
+ Error_Msg_N
+ ("\an equality operator cannot be declared after this point"
+ & " (Ada 2012)?y?", N);
+ end if;
+ end Freezing_Point_Warning;
+
+ --------------------------------
+ -- Is_Actual_Of_Instantiation --
+ --------------------------------
+
+ function Is_Actual_Of_Instantiation
+ (E : Entity_Id;
+ Inst : Node_Id) return Boolean
+ is
+ Assoc : Node_Id;
+
+ begin
+ if Present (Generic_Associations (Inst)) then
+ Assoc := First (Generic_Associations (Inst));
+
+ while Present (Assoc) loop
+ if Present (Explicit_Generic_Actual_Parameter (Assoc))
+ and then
+ Is_Entity_Name (Explicit_Generic_Actual_Parameter (Assoc))
+ and then
+ Entity (Explicit_Generic_Actual_Parameter (Assoc)) = E
+ then
+ return True;
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ return False;
+ end Is_Actual_Of_Instantiation;
+
+ -- Local variable
+
+ Decl : Node_Id;
+
+ -- Start of processing for Check_Untagged_Equality
begin
- -- This check applies only if we have a subprogram declaration with an
- -- untagged record type that is conformant to the predefined operator.
+ -- This check applies only if we have a subprogram declaration or a
+ -- subprogram body that is not a completion, for an untagged record
+ -- type, and that is conformant with the predefined operator.
- if Nkind (Decl) /= N_Subprogram_Declaration
+ if (Nkind (Eq_Decl) /= N_Subprogram_Declaration
+ and then not (Nkind (Eq_Decl) = N_Subprogram_Body
+ and then Acts_As_Spec (Eq_Decl)))
or else not Is_Record_Type (Typ)
or else Is_Tagged_Type (Typ)
or else not Is_User_Defined_Equality (Eq_Op)
@@ -9572,9 +9647,59 @@ package body Sem_Ch6 is
elsif Is_Generic_Actual_Type (Typ) then
return;
- -- Here we have a definite error of declaration after freezing
+ -- Here we may have an error of declaration after freezing, but we
+ -- must make sure not to flag the equality operator itself causing
+ -- the freezing when it is a subprogram body.
else
+ Decl := Next (Declaration_Node (Typ));
+
+ while Present (Decl) and then Decl /= Eq_Decl loop
+
+ -- The declaration of an object of the type
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Etype (Defining_Identifier (Decl)) = Typ
+ then
+ Freezing_Point_Warning (Decl, "declaration");
+ exit;
+
+ -- The instantiation of a generic on the type
+
+ elsif Nkind (Decl) in N_Generic_Instantiation
+ and then Is_Actual_Of_Instantiation (Typ, Decl)
+ then
+ Freezing_Point_Warning (Decl, "instantiation");
+ exit;
+
+ -- A noninstance proper body, body stub or entry body
+
+ elsif Nkind (Decl) in N_Proper_Body
+ | N_Body_Stub
+ | N_Entry_Body
+ and then not Is_Generic_Instance (Defining_Entity (Decl))
+ then
+ Freezing_Point_Warning (Decl, "body");
+ exit;
+
+ -- If we have reached the freeze node and immediately after we
+ -- have the body or generated code for the body, then it is the
+ -- body that caused the freezing and this is legal.
+
+ elsif Nkind (Decl) = N_Freeze_Entity
+ and then Entity (Decl) = Typ
+ and then (Next (Decl) = Eq_Decl
+ or else
+ Sloc (Next (Decl)) = Sloc (Eq_Decl))
+ then
+ return;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- Here we have a definite error of declaration after freezing
+
if Ada_Version >= Ada_2012 then
Error_Msg_NE
("equality operator must be declared before type & is "
@@ -9594,57 +9719,32 @@ package body Sem_Ch6 is
& "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ);
end if;
- -- If we are in the package body, we could just move the
- -- declaration to the package spec, so add a message saying that.
+ -- If we have found no freezing point and the declaration of the
+ -- operator could not be reached from that of the type and we are
+ -- in a package body, this must be because the type is declared
+ -- in the spec of the package. Add a message tailored to this.
- if In_Package_Body (Scope (Typ)) then
+ if No (Decl) and then In_Package_Body (Scope (Typ)) then
if Ada_Version >= Ada_2012 then
- Error_Msg_N
- ("\move declaration to package spec<<", Eq_Op);
- else
- Error_Msg_N
- ("\move declaration to package spec (Ada 2012)?y?", Eq_Op);
- end if;
-
- -- Otherwise try to find the freezing point for better message.
-
- else
- Obj_Decl := Next (Parent (Typ));
- while Present (Obj_Decl) and then Obj_Decl /= Decl loop
- if Nkind (Obj_Decl) = N_Object_Declaration
- and then Etype (Defining_Identifier (Obj_Decl)) = Typ
- then
- -- Freezing point, output warnings
-
- if Ada_Version >= Ada_2012 then
- Error_Msg_NE
- ("type& is frozen by declaration??", Obj_Decl, Typ);
- Error_Msg_N
- ("\an equality operator cannot be declared after "
- & "this point??",
- Obj_Decl);
- else
- Error_Msg_NE
- ("type& is frozen by declaration (Ada 2012)?y?",
- Obj_Decl, Typ);
- Error_Msg_N
- ("\an equality operator cannot be declared after "
- & "this point (Ada 2012)?y?",
- Obj_Decl);
- end if;
-
- exit;
-
- -- If we reach generated code for subprogram declaration
- -- or body, it is the body that froze the type and the
- -- declaration is legal.
-
- elsif Sloc (Obj_Decl) = Sloc (Decl) then
- return;
+ if Nkind (Eq_Decl) = N_Subprogram_Body then
+ Error_Msg_N
+ ("\put declaration in package spec<<", Eq_Op);
+ else
+ Error_Msg_N
+ ("\move declaration to package spec<<", Eq_Op);
end if;
- Next (Obj_Decl);
- end loop;
+ else
+ if Nkind (Eq_Decl) = N_Subprogram_Body then
+ Error_Msg_N
+ ("\put declaration in package spec (Ada 2012)?y?",
+ Eq_Op);
+ else
+ Error_Msg_N
+ ("\move declaration to package spec (Ada 2012)?y?",
+ Eq_Op);
+ end if;
+ end if;
end if;
end if;
@@ -9653,21 +9753,21 @@ package body Sem_Ch6 is
-- a type has been derived from T.
else
- Obj_Decl := Next (Parent (Typ));
+ Decl := Next (Declaration_Node (Typ));
- while Present (Obj_Decl) and then Obj_Decl /= Decl loop
- if Nkind (Obj_Decl) = N_Full_Type_Declaration
- and then Etype (Defining_Identifier (Obj_Decl)) = Typ
+ while Present (Decl) and then Decl /= Eq_Decl loop
+ if Nkind (Decl) = N_Full_Type_Declaration
+ and then Etype (Defining_Identifier (Decl)) = Typ
then
Error_Msg_N
("equality operator cannot appear after derivation", Eq_Op);
Error_Msg_NE
("an equality operator for& cannot be declared after "
& "this point??",
- Obj_Decl, Typ);
+ Decl, Typ);
end if;
- Next (Obj_Decl);
+ Next (Decl);
end loop;
end if;
end Check_Untagged_Equality;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 1412d94198c..44fc955de74 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -8967,14 +8967,7 @@ package body Sem_Res is
then
Eq := Get_User_Defined_Equality (T);
- -- We need to make sure that the instance is not within the
- -- same declarative region as the type, or else that it lies
- -- after the declaration of the user-defined "=" operator.
-
- if Present (Eq)
- and then (not In_Same_Extended_Unit (Eq, N)
- or else Earlier_In_Extended_Unit (Eq, N))
- then
+ if Present (Eq) then
if Is_Abstract_Subprogram (Eq) then
Nondispatching_Call_To_Abstract_Operation (N, Eq);
else
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-07-13 10:03 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-07-13 10:03 [gcc r13-1661] [Ada] Plug legality loophole for equality operator of 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).