[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 --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 608819bd1adc38cd8ea0acf5f2840799c75ceb42..541655c466fd178347e98879f0fe491b012ac760 100644 (file)
--- 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 e2d3492e32f7fcebb9a30f8c96bbc90950624c66..c814c80cefa6a88f27adfe0f1032360f514f4c53 100644 (file)
--- 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 5b2a17bca3397e6d581fa8367af51bbea077e5eb..70557296a0327173708bf1d9d053bd0cd3d9b0a3 100644 (file)
--- 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 73a7bd1b20ebed6ff52d495619c1a304e40a8acb..01690f3a35e7f9774a77d17fc1447d6289e2e343 100644 (file)
--- 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