diff mbox series

[Ada] Fix bug in subtype of private type with invariants

Message ID 20210615102051.GA2356@adacore.com
State New
Headers show
Series [Ada] Fix bug in subtype of private type with invariants | expand

Commit Message

Pierre-Marie de Rodat June 15, 2021, 10:20 a.m. UTC
This patch fixes a bug in which the compiler could crash if there is a
subtype of a private type, and the full type has invariants.

Tested on x86_64-pc-linux-gnu, committed on trunk

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 mbox series

Patch

diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
--- 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
--- 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
--- 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
--- 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