From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id D6EB3384000A; Tue, 15 Jun 2021 10:20:40 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org D6EB3384000A 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 r12-1450] [Ada] Fix bug in subtype of private type with invariants X-Act-Checkin: gcc X-Git-Author: Bob Duff X-Git-Refname: refs/heads/master X-Git-Oldrev: ed17bbe3c3ac0a5afd866030d88dce3f6d5a2730 X-Git-Newrev: a5db70e78af095a3d8e4744f21059448056fa47b Message-Id: <20210615102040.D6EB3384000A@sourceware.org> Date: Tue, 15 Jun 2021 10:20:40 +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: Tue, 15 Jun 2021 10:20:40 -0000 https://gcc.gnu.org/g:a5db70e78af095a3d8e4744f21059448056fa47b commit r12-1450-ga5db70e78af095a3d8e4744f21059448056fa47b Author: Bob Duff 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