public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-1450] [Ada] Fix bug in subtype of private type with invariants
@ 2021-06-15 10:20 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-06-15 10:20 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:a5db70e78af095a3d8e4744f21059448056fa47b
commit r12-1450-ga5db70e78af095a3d8e4744f21059448056fa47b
Author: Bob Duff <duff@adacore.com>
Date: Sat Feb 13 16:43:22 2021 -0500
[Ada] Fix bug in subtype of private type with invariants
gcc/ada/
* sem_util.adb (Propagate_Invariant_Attributes): Call
Set_Has_Own_Invariants on the base type, because these are
Base_Type_Only. The problem is that the base type of a type is
indeed a base type when Set_Base_Type is called, but then the
type is mutated into a subtype in rare cases.
* atree.ads, atree.adb (Is_Entity): Export. Correct subtype of
parameter in body.
* gen_il-gen.adb: Improve getters so that "Pre => ..." can refer
to the value of the field. Put Warnings (Off) on some with
clauses that are not currently used, but might be used by such
Pre's.
Diff:
---
gcc/ada/atree.adb | 6 +-----
gcc/ada/atree.ads | 4 ++++
gcc/ada/gen_il-gen.adb | 44 +++++++++++++++++++++++++++++++-------------
gcc/ada/sem_util.adb | 6 ++++--
4 files changed, 40 insertions(+), 20 deletions(-)
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 608819bd1ad..541655c466f 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -139,10 +139,6 @@ package body Atree is
-- Local Subprograms --
-----------------------
- function Is_Entity (N : Node_Or_Entity_Id) return Boolean;
- pragma Inline (Is_Entity);
- -- Returns True if N is an entity
-
function Allocate_New_Node (Kind : Node_Kind) return Node_Id;
pragma Inline (Allocate_New_Node);
-- Allocate a new node or first part of a node extension. Initialize the
@@ -1435,7 +1431,7 @@ package body Atree is
-- Is_Entity --
---------------
- function Is_Entity (N : Node_Id) return Boolean is
+ function Is_Entity (N : Node_Or_Entity_Id) return Boolean is
begin
return Nkind (N) in N_Entity;
end Is_Entity;
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index e2d3492e32f..c814c80cefa 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -222,6 +222,10 @@ package Atree is
-- Called to unlock node modifications when assertions are enabled; if
-- assertions are not enabled calling this subprogram has no effect.
+ function Is_Entity (N : Node_Or_Entity_Id) return Boolean;
+ pragma Inline (Is_Entity);
+ -- Returns True if N is an entity
+
function New_Node
(New_Node_Kind : Node_Kind;
New_Sloc : Source_Ptr) return Node_Id;
diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb
index 5b2a17bca33..70557296a03 100644
--- a/gcc/ada/gen_il-gen.adb
+++ b/gcc/ada/gen_il-gen.adb
@@ -1508,20 +1508,31 @@ package body Gen_IL.Gen is
end Put_Getter_Decl;
procedure Put_Getter_Body (S : in out Sink'Class; F : Field_Enum) is
+ Rec : Field_Info renames Field_Table (F).all;
begin
+ -- Note that we store the result in a local constant below, so that
+ -- the "Pre => ..." can refer to it. The constant is called Val so
+ -- that it has the same name as the formal of the setter, so the
+ -- "Pre => ..." can refer to it by the same name in both getter
+ -- and setter.
+
Put_Getter_Spec (S, F);
Put (S, " is\n");
+ Indent (S, 3);
+ Put (S, "Val : constant \1 := \2 (\3, \4);\n",
+ Get_Set_Id_Image (Rec.Field_Type),
+ Low_Level_Getter (Rec.Field_Type),
+ Node_To_Fetch_From (F),
+ Image (Rec.Offset));
+ Outdent (S, 3);
Put (S, "begin\n");
Indent (S, 3);
- if Field_Table (F).Pre.all /= "" then
- Put (S, "pragma Assert (\1);\n", Field_Table (F).Pre.all);
+ if Rec.Pre.all /= "" then
+ Put (S, "pragma Assert (\1);\n", Rec.Pre.all);
end if;
- Put (S, "return \1 (\2, \3);\n",
- Low_Level_Getter (Field_Table (F).Field_Type),
- Node_To_Fetch_From (F),
- Image (Field_Table (F).Offset));
+ Put (S, "return Val;\n");
Outdent (S, 3);
Put (S, "end \1;\n\n", Image (F));
end Put_Getter_Body;
@@ -1529,7 +1540,7 @@ package body Gen_IL.Gen is
procedure Put_Setter_Spec (S : in out Sink'Class; F : Field_Enum) is
Rec : Field_Info renames Field_Table (F).all;
Default : constant String :=
- (if Field_Table (F).Field_Type = Flag then " := True" else "");
+ (if Rec.Field_Type = Flag then " := True" else "");
begin
Put (S, "procedure Set_\1\n", Image (F));
Indent (S, 2);
@@ -1550,11 +1561,13 @@ package body Gen_IL.Gen is
end Put_Setter_Decl;
procedure Put_Setter_Body (S : in out Sink'Class; F : Field_Enum) is
+ Rec : Field_Info renames Field_Table (F).all;
+
-- If Type_Only was specified in the call to Create_Semantic_Field,
-- then we assert that the node is a base (etc) type.
Type_Only_Assertion : constant String :=
- (case Field_Table (F).Type_Only is
+ (case Rec.Type_Only is
when No_Type_Only => "",
when Base_Type_Only => "Is_Base_Type (N)",
-- ????It seems like we should call Is_Implementation_Base_Type or
@@ -1570,8 +1583,8 @@ package body Gen_IL.Gen is
Put (S, "begin\n");
Indent (S, 3);
- if Field_Table (F).Pre.all /= "" then
- Put (S, "pragma Assert (\1);\n", Field_Table (F).Pre.all);
+ if Rec.Pre.all /= "" then
+ Put (S, "pragma Assert (\1);\n", Rec.Pre.all);
end if;
if Type_Only_Assertion /= "" then
@@ -1580,7 +1593,7 @@ package body Gen_IL.Gen is
Put (S, "\1 (N, \2, Val);\n",
Low_Level_Setter (F),
- Image (Field_Table (F).Offset));
+ Image (Rec.Offset));
Outdent (S, 3);
Put (S, "end Set_\1;\n\n", Image (F));
end Put_Setter_Body;
@@ -2034,9 +2047,11 @@ package body Gen_IL.Gen is
begin
Put (S, "with Seinfo; use Seinfo;\n");
- Put (S, "pragma Warnings (Off); -- ????\n");
+ Put (S, "pragma Warnings (Off);\n");
+ -- With's included in case they are needed; so we don't have to keep
+ -- switching back and forth.
Put (S, "with Output; use Output;\n");
- Put (S, "pragma Warnings (On); -- ????\n");
+ Put (S, "pragma Warnings (On);\n");
Put (S, "\npackage Sinfo.Nodes is\n\n");
Indent (S, 3);
@@ -2061,6 +2076,9 @@ package body Gen_IL.Gen is
Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;\n");
Put (B, "with Nlists; use Nlists;\n");
+ Put (B, "pragma Warnings (Off);\n");
+ Put (B, "with Einfo.Utils; use Einfo.Utils;\n");
+ Put (B, "pragma Warnings (On);\n");
Put (B, "\npackage body Sinfo.Nodes is\n\n");
Indent (B, 3);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 73a7bd1b20e..01690f3a35e 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -26215,7 +26215,9 @@ package body Sem_Util is
Part_IP := Partial_Invariant_Procedure (From_Typ);
-- The setting of the attributes is intentionally conservative. This
- -- prevents accidental clobbering of enabled attributes.
+ -- prevents accidental clobbering of enabled attributes. We need to
+ -- call Base_Type twice, because it is sometimes not set to an actual
+ -- base type.
if Has_Inheritable_Invariants (From_Typ) then
Set_Has_Inheritable_Invariants (Typ);
@@ -26226,7 +26228,7 @@ package body Sem_Util is
end if;
if Has_Own_Invariants (From_Typ) then
- Set_Has_Own_Invariants (Base_Type (Typ));
+ Set_Has_Own_Invariants (Base_Type (Base_Type (Typ)));
end if;
if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-06-15 10:20 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-06-15 10:20 [gcc r12-1450] [Ada] Fix bug in subtype of private type with invariants 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).