[gcc r12-2064] [Ada] Tbuild cleanup

[gcc r12-2064] [Ada] Tbuild cleanup

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:82a794419a00ea98b68d69b64363ae6746710de9

commit r12-2064-g82a794419a00ea98b68d69b64363ae6746710de9
Author: Bob Duff <duff@adacore.com>
Date:   Sat May 8 11:39:52 2021 -0400

    [Ada] Tbuild cleanup
    
    gcc/ada/
    
            * tbuild.adb (Convert_To): Add assert, along with a comment.
            (Make_DT_Access): Remove this function, which is not used.  It
            was incorrect anyway (the call to New_Occurrence_Of should not
            be there).
            (Unchecked_Convert_To): Add assert.  The previous version's test
            for unchecked conversion to the same type was redundant and
            could never be true, because the previous 'if' already checked
            for ANY expression of the same type. Remove that, and replace
            with a test for unchecked conversion to a related type.
            Otherwise, we somethings get things like
            "finalize(some_type!(some_type!(x)))" in the generated code,
            where x is already of type some_type, but we're converting it to
            the private type and then to the full type or vice versa (so the
            types aren't equal, so the previous 'if' doesn't catch it).
            Avoid updating the Parent. This is not necessary; the Parent
            will be updated if/when the node is attached to the tree.
            * tbuild.ads: Fix comments. No need to say "this is safe" when
            we just explained that a few lines earlier.  Remove
            Make_DT_Access.
            * sinfo.ads: Add comments.
            * exp_ch7.adb (Make_Finalize_Address_Stmts): Minor comment fix.
            * gen_il-gen.adb, gen_il-gen.ads, gen_il-gen-gen_nodes.adb,
            gen_il-internals.ads: Implement a feature where you can put:
            Nmake_Assert => "expr" where expr is a boolean expression in a
            call to Create_Concrete_Node_Type. It is added in a pragma
            Assert in the Nmake.Make_... function for that type.

Diff:
---
 gcc/ada/exp_ch7.adb              |  2 +-
 gcc/ada/gen_il-gen-gen_nodes.adb | 10 +++++--
 gcc/ada/gen_il-gen.adb           | 40 +++++++++++++++++----------
 gcc/ada/gen_il-gen.ads           | 18 +++++++-----
 gcc/ada/gen_il-internals.ads     |  2 ++
 gcc/ada/sinfo.ads                |  7 +++--
 gcc/ada/tbuild.adb               | 59 +++++++++++-----------------------------
 gcc/ada/tbuild.ads               | 31 ++++++++-------------
 8 files changed, 79 insertions(+), 90 deletions(-)

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 4c1e16d9e32..b0374a39d4c 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -9344,7 +9344,7 @@ package body Exp_Ch7 is
             Dope_Id : Entity_Id;
 
          begin
-            --  Ensure that Ptr_Typ a thin pointer, generate:
+            --  Ensure that Ptr_Typ is a thin pointer; generate:
             --    for Ptr_Typ'Size use System.Address'Size;
 
             Append_To (Decls,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index ef7dfa4c190..2427a1e8e89 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -31,7 +31,8 @@ procedure Gen_IL.Gen.Gen_Nodes is
       renames Create_Abstract_Node_Type;
    procedure Cc -- Short for "ConCrete"
      (T : Concrete_Node; Parent : Abstract_Type;
-      Fields : Field_Sequence := No_Fields)
+      Fields : Field_Sequence := No_Fields;
+      Nmake_Assert : String := "")
       renames Create_Concrete_Node_Type;
 
    function Sy -- Short for "Syntactic"
@@ -562,7 +563,12 @@ begin -- Gen_IL.Gen.Gen_Nodes
        (Sy (Subtype_Mark, Node_Id, Default_Empty),
         Sy (Expression, Node_Id, Default_Empty),
         Sm (Kill_Range_Check, Flag),
-        Sm (No_Truncation, Flag)));
+        Sm (No_Truncation, Flag)),
+       Nmake_Assert => "True or else Nkind (Expression) /= N_Unchecked_Type_Conversion");
+--       Nmake_Assert => "Nkind (Expression) /= N_Unchecked_Type_Conversion");
+   --  Assert that we don't have unchecked conversions of unchecked
+   --  conversions; if Expression might be an unchecked conversion,
+   --  then Tbuild.Unchecked_Convert_To should be used.
 
    Cc (N_Subtype_Indication, N_Has_Etype,
        (Sy (Subtype_Mark, Node_Id, Default_Empty),
diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb
index 0f3698ea33b..94f7c9cb2d8 100644
--- a/gcc/ada/gen_il-gen.adb
+++ b/gcc/ada/gen_il-gen.adb
@@ -47,9 +47,10 @@ package body Gen_IL.Gen is
    All_Entities : constant Type_Vector := To_Vector (Entity_Kind, Length => 1);
 
    procedure Create_Type
-     (T      : Node_Or_Entity_Type;
-      Parent : Opt_Abstract_Type;
-      Fields : Field_Sequence);
+     (T            : Node_Or_Entity_Type;
+      Parent       : Opt_Abstract_Type;
+      Fields       : Field_Sequence;
+      Nmake_Assert : String);
    --  Called by the Create_..._Type procedures exported by this package to
    --  create an entry in the Types_Table.
 
@@ -107,9 +108,10 @@ package body Gen_IL.Gen is
    -----------------
 
    procedure Create_Type
-     (T      : Node_Or_Entity_Type;
-      Parent : Opt_Abstract_Type;
-      Fields : Field_Sequence)
+     (T            : Node_Or_Entity_Type;
+      Parent       : Opt_Abstract_Type;
+      Fields       : Field_Sequence;
+      Nmake_Assert : String)
    is
    begin
       Check_Type (T);
@@ -132,7 +134,8 @@ package body Gen_IL.Gen is
         new Type_Info'
           (Is_Union => False, Parent => Parent,
            Children | Concrete_Descendants => Type_Vectors.Empty_Vector,
-           First | Last | Fields => <>); -- filled in later
+           First | Last | Fields => <>, -- filled in later
+           Nmake_Assert => new String'(Nmake_Assert));
 
       if Parent /= No_Type then
          Append (Type_Table (Parent).Children, T);
@@ -215,7 +218,7 @@ package body Gen_IL.Gen is
      (T      : Abstract_Node;
       Fields : Field_Sequence := No_Fields) is
    begin
-      Create_Type (T, Parent => No_Type, Fields => Fields);
+      Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => "");
    end Create_Root_Node_Type;
 
    -------------------------------
@@ -227,7 +230,7 @@ package body Gen_IL.Gen is
       Fields : Field_Sequence := No_Fields)
    is
    begin
-      Create_Type (T, Parent, Fields);
+      Create_Type (T, Parent, Fields, Nmake_Assert => "");
    end Create_Abstract_Node_Type;
 
    -------------------------------
@@ -236,10 +239,11 @@ package body Gen_IL.Gen is
 
    procedure Create_Concrete_Node_Type
      (T      : Concrete_Node; Parent : Abstract_Type;
-      Fields : Field_Sequence := No_Fields)
+      Fields : Field_Sequence := No_Fields;
+      Nmake_Assert : String := "")
    is
    begin
-      Create_Type (T, Parent, Fields);
+      Create_Type (T, Parent, Fields, Nmake_Assert);
    end Create_Concrete_Node_Type;
 
    -----------------------------
@@ -250,7 +254,7 @@ package body Gen_IL.Gen is
      (T      : Abstract_Entity;
       Fields : Field_Sequence := No_Fields) is
    begin
-      Create_Type (T, Parent => No_Type, Fields => Fields);
+      Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => "");
    end Create_Root_Entity_Type;
 
    ---------------------------------
@@ -262,7 +266,7 @@ package body Gen_IL.Gen is
       Fields : Field_Sequence := No_Fields)
    is
    begin
-      Create_Type (T, Parent, Fields);
+      Create_Type (T, Parent, Fields, Nmake_Assert => "");
    end Create_Abstract_Entity_Type;
 
    ---------------------------------
@@ -274,7 +278,7 @@ package body Gen_IL.Gen is
       Fields : Field_Sequence := No_Fields)
    is
    begin
-      Create_Type (T, Parent, Fields);
+      Create_Type (T, Parent, Fields, Nmake_Assert => "");
    end Create_Concrete_Entity_Type;
 
    ------------------
@@ -352,7 +356,7 @@ package body Gen_IL.Gen is
               Image (Field);
          end if;
 
-         if Pre /= Field_Table (Field).Pre.all then
+         if Pre_Set /= Field_Table (Field).Pre_Set.all then
             raise Illegal with
               "mismatched extra setter-only preconditions for " &
               Image (Field);
@@ -2561,6 +2565,11 @@ package body Gen_IL.Gen is
                   end;
                end if;
 
+               if Type_Table (T).Nmake_Assert.all /= "" then
+                  Put (S, "pragma Assert (" &
+                           Type_Table (T).Nmake_Assert.all & ");" & LF);
+               end if;
+
                Put (S, "return N;" & LF);
                Decrease_Indent (S, 3);
 
@@ -2628,6 +2637,7 @@ package body Gen_IL.Gen is
          Increase_Indent (B, 3);
 
          Put (B, "--  This package is automatically generated." & LF & LF);
+         Put (B, "pragma Style_Checks (""M200"");" & LF);
 
          Put_Make_Bodies (B, Node_Kind);
 
diff --git a/gcc/ada/gen_il-gen.ads b/gcc/ada/gen_il-gen.ads
index 34ce2d6081e..1d24ebf1092 100644
--- a/gcc/ada/gen_il-gen.ads
+++ b/gcc/ada/gen_il-gen.ads
@@ -102,9 +102,12 @@ package Gen_IL.Gen is
 
    procedure Create_Concrete_Node_Type
      (T : Concrete_Node; Parent : Abstract_Type;
-      Fields : Field_Sequence := No_Fields);
+      Fields : Field_Sequence := No_Fields;
+      Nmake_Assert : String := "");
    --  Create a concrete node type. Every node is an instance of a concrete
-   --  node type.
+   --  node type. Nmake_Assert is an assertion to put in the Make_... function
+   --  in the generated Nmake package. It should be a String that represents a
+   --  Boolean expression.
 
    procedure Create_Root_Entity_Type
      (T : Abstract_Entity;
@@ -151,13 +154,14 @@ package Gen_IL.Gen is
    --  only for syntactic fields. Flag fields of syntactic nodes always have a
    --  default value, which is False unless specified as Default_True. Pre is
    --  an additional precondition for the field getter and setter, in addition
-   --  to the precondition that asserts that the type has that field. Pre_Get
-   --  and Pre_Set are similar to Pre, but for the getter or setter only,
-   --  respectively.
+   --  to the precondition that asserts that the type has that field. It should
+   --  be a String that represents a Boolean expression. Pre_Get and Pre_Set
+   --  are similar to Pre, but for the getter or setter only, respectively.
    --
    --  If multiple calls to these occur for the same Field but different types,
-   --  the Field_Type and Pre must match. Default_Value should match for
-   --  syntactic fields. See the declaration of Type_Only_Enum for Type_Only.
+   --  the Field_Type, Pre, Pre_Get, and Pre_Set must match. Default_Value
+   --  should match for syntactic fields. See the declaration of Type_Only_Enum
+   --  for Type_Only.
    --
    --  (The matching Default_Value requirement is a simplification from the
    --  earlier hand-written version.)
diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads
index 9c5779bd2d8..b8911ec3c0a 100644
--- a/gcc/ada/gen_il-internals.ads
+++ b/gcc/ada/gen_il-internals.ads
@@ -104,6 +104,8 @@ package Gen_IL.Internals is
             --  includes two or more types.
 
             Fields : Field_Vector;
+
+            Nmake_Assert : String_Access; -- only for concrete node types
       end case;
    end record;
 
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 8f23f7dfe1a..f6c5e0dcc59 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -8420,8 +8420,11 @@ package Sinfo is
       --  An unchecked type conversion node represents the semantic action
       --  corresponding to a call to an instantiation of Unchecked_Conversion.
       --  It is generated as a result of actual use of Unchecked_Conversion
-      --  and also the expander generates unchecked type conversion nodes
-      --  directly for expansion of complex semantic actions.
+      --  and also by the expander.
+
+      --  Unchecked type conversion nodes should normally be created by calling
+      --  Tbuild.Unchecked_Convert_To, rather than by directly calling
+      --  Nmake.Make_Unchecked_Type_Conversion.
 
       --  Note: an unchecked type conversion is a variable as far as the
       --  semantics are concerned, which is convenient for the expander.
diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
index 4c53cdb4338..e7186444365 100644
--- a/gcc/ada/tbuild.adb
+++ b/gcc/ada/tbuild.adb
@@ -29,14 +29,12 @@ with Csets;          use Csets;
 with Einfo;          use Einfo;
 with Einfo.Entities; use Einfo.Entities;
 with Einfo.Utils;    use Einfo.Utils;
-with Elists;         use Elists;
 with Lib;            use Lib;
 with Nlists;         use Nlists;
 with Nmake;          use Nmake;
 with Opt;            use Opt;
 with Restrict;       use Restrict;
 with Rident;         use Rident;
-with Sem_Aux;        use Sem_Aux;
 with Sinfo.Utils;    use Sinfo.Utils;
 with Sem_Util;       use Sem_Util;
 with Snames;         use Snames;
@@ -117,6 +115,7 @@ package body Tbuild is
    ----------------
 
    function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
+      pragma Assert (Is_Type (Typ));
       Result : Node_Id;
 
    begin
@@ -185,32 +184,6 @@ package body Tbuild is
       return N;
    end Make_Byte_Aligned_Attribute_Reference;
 
-   --------------------
-   -- Make_DT_Access --
-   --------------------
-
-   function Make_DT_Access
-     (Loc : Source_Ptr;
-      Rec : Node_Id;
-      Typ : Entity_Id) return Node_Id
-   is
-      Full_Type : Entity_Id := Typ;
-
-   begin
-      if Is_Private_Type (Typ) then
-         Full_Type := Underlying_Type (Typ);
-      end if;
-
-      return
-        Unchecked_Convert_To (
-          New_Occurrence_Of
-            (Etype (Node (First_Elmt (Access_Disp_Table (Full_Type)))), Loc),
-          Make_Selected_Component (Loc,
-            Prefix => New_Copy (Rec),
-            Selector_Name =>
-              New_Occurrence_Of (First_Tag_Component (Full_Type), Loc)));
-   end Make_DT_Access;
-
    ------------------------
    -- Make_Float_Literal --
    ------------------------
@@ -906,26 +879,34 @@ package body Tbuild is
      (Typ  : Entity_Id;
       Expr : Node_Id) return Node_Id
    is
+      pragma Assert (Ekind (Typ) in E_Void | Type_Kind);
+      --  We don't really want to allow E_Void here, but existing code passes
+      --  it.
+
       Loc         : constant Source_Ptr := Sloc (Expr);
       Result      : Node_Id;
-      Expr_Parent : Node_Id;
 
    begin
       --  If the expression is already of the correct type, then nothing
-      --  to do, except for relocating the node in case this is required.
+      --  to do, except for relocating the node
 
       if Present (Etype (Expr))
-        and then (Base_Type (Etype (Expr)) = Typ
-                   or else Etype (Expr) = Typ)
+        and then (Base_Type (Etype (Expr)) = Typ or else Etype (Expr) = Typ)
       then
          return Relocate_Node (Expr);
 
-      --  Case where the expression is itself an unchecked conversion to
-      --  the same type, and we can thus eliminate the outer conversion.
+      --  Case where the expression is already an unchecked conversion. We
+      --  replace the type being converted to, to avoid creating an unchecked
+      --  conversion of an unchecked conversion. Extra unchecked conversions
+      --  make the .dg output less readable. We can't do this in cases
+      --  involving bitfields, because the sizes might not match. The
+      --  Is_Composite_Type checks avoid such cases.
 
       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
-        and then Entity (Subtype_Mark (Expr)) = Typ
+        and then Is_Composite_Type (Etype (Expr))
+        and then Is_Composite_Type (Typ)
       then
+         Set_Subtype_Mark (Expr, New_Occurrence_Of (Typ, Loc));
          Result := Relocate_Node (Expr);
 
       elsif Nkind (Expr) = N_Null
@@ -938,18 +919,10 @@ package body Tbuild is
       --  All other cases
 
       else
-         --  Capture the parent of the expression before relocating it and
-         --  creating the conversion, so the conversion's parent can be set
-         --  to the original parent below.
-
-         Expr_Parent := Parent (Expr);
-
          Result :=
            Make_Unchecked_Type_Conversion (Loc,
              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
              Expression   => Relocate_Node (Expr));
-
-         Set_Parent (Result, Expr_Parent);
       end if;
 
       Set_Etype (Result, Typ);
diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads
index 07cd7a7a676..f2f9809eb73 100644
--- a/gcc/ada/tbuild.ads
+++ b/gcc/ada/tbuild.ads
@@ -41,19 +41,16 @@ package Tbuild is
    --  except that it will be analyzed and resolved with checks off.
 
    function Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
-   --  Returns an expression that represents the result of a checked convert
-   --  of expression Exp to type T. If the base type of Exp is T, then no
-   --  conversion is required, and Exp is returned unchanged. Otherwise an
-   --  N_Type_Conversion node is constructed to convert the expression.
-   --  If an N_Type_Conversion node is required, Relocate_Node is used on
-   --  Exp. This means that it is safe to replace a node by a Convert_To
-   --  of itself to some other type.
+   --  Returns an expression that is a type conversion of expression Expr to
+   --  type Typ. If the type of Expr is Typ, then no conversion is required.
+   --  Otherwise an N_Type_Conversion node is constructed to convert the
+   --  expression. Relocate_Node is applied to Expr, so that it is safe to
+   --  replace a node by a Convert_To of itself to some other type.
 
    procedure Convert_To_And_Rewrite (Typ : Entity_Id; Expr : Node_Id);
    pragma Inline (Convert_To_And_Rewrite);
    --  Like the function, except that there is an extra step of calling
    --  Rewrite on the Expr node and replacing it with the converted result.
-   --  As noted above, this is safe, because Relocate_Node is called.
 
    procedure Discard_Node (N : Node_Or_Entity_Id);
    pragma Inline (Discard_Node);
@@ -78,11 +75,6 @@ package Tbuild is
    --  Must_Be_Byte_Aligned is set in the attribute reference node. The
    --  Attribute_Name must be Name_Address or Name_Unrestricted_Access.
 
-   function Make_DT_Access
-     (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id;
-   --  Create an access to the Dispatch Table by using the Tag field of a
-   --  tagged record : Acc_Dt (Rec.tag).all
-
    function Make_Float_Literal
      (Loc         : Source_Ptr;
       Radix       : Uint;
@@ -319,13 +311,12 @@ package Tbuild is
    function New_Occurrence_Of
      (Def_Id : Entity_Id;
       Loc    : Source_Ptr) return Node_Id;
-   --  New_Occurrence_Of creates an N_Identifier node which is an occurrence
-   --  of the defining identifier which is passed as its argument. The Entity
-   --  and Etype of the result are set from the given defining identifier as
-   --  follows: Entity is simply a copy of Def_Id. Etype is a copy of Def_Id
-   --  for types, and a copy of the Etype of Def_Id for other entities. Note
-   --  that Is_Static_Expression is set if this call creates an occurrence of
-   --  an enumeration literal.
+   --  New_Occurrence_Of creates an N_Identifier node that is an occurrence of
+   --  the defining identifier Def_Id. The Entity and Etype of the result are
+   --  set from the given defining identifier as follows: Entity is a copy of
+   --  Def_Id. Etype is a copy of Def_Id for types, and a copy of the Etype of
+   --  Def_Id for other entities. Note that Is_Static_Expression is set if this
+   --  call creates an occurrence of an enumeration literal.
 
    function New_Suffixed_Name
      (Related_Id : Name_Id;