[gcc r13-883] [Ada] Missing discriminant checks when accessing variant field

[gcc r13-883] [Ada] Missing discriminant checks when accessing variant field

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:eb1091dd34ee60aa96a513c09ef1d70f40a6a38f

commit r13-883-geb1091dd34ee60aa96a513c09ef1d70f40a6a38f
Author: Steve Baird <baird@adacore.com>
Date:   Fri Apr 29 14:55:38 2022 -0700

    [Ada] Missing discriminant checks when accessing variant field
    
    In some cases, the compiler would incorrectly fail to generate
    discriminant checks when accessing fields declared in a variant part.
    Correct some such cases; detect the remaining cases and flag them as
    unsupported. The formerly-problematic cases that are now handled
    correctly involve component references occurring in a predicate
    expression (e.g., the expression of a Dynamic_Predicate aspect
    specification) for a type declaration (not for a subtype declaration).
    The cases which are now flagged as unsupported involve expression
    functions declared before the discriminated type in question has been
    frozen.
    
    gcc/ada/
    
            * exp_ch3.ads: Replace visible Build_Discr_Checking_Funcs (which
            did not need to be visible - it was not referenced outside this
            package) with Build_Or_Copy_Discr_Checking_Funcs.
            * exp_ch3.adb: Refactor existing code into 3 procedures -
            Build_Discr_Checking_Funcs, Copy_Discr_Checking_Funcs, and
            Build_Or_Copy_Discr_Checking_Funcs. This refactoring is intended
            to be semantics-preserving.
            * exp_ch4.adb (Expand_N_Selected_Component): Detect case where a
            call should be generated to the Discriminant_Checking_Func for
            the component in question, but that subprogram does not yet
            exist.
            * sem_ch13.adb (Freeze_Entity_Checks): Immediately before
            calling Build_Predicate_Function, add a call to
            Exp_Ch3.Build_Or_Copy_Discr_Checking_Funcs in order to ensure
            that Discriminant_Checking_Func attributes are already set when
            Build_Predicate_Function is called.
            * sem_ch6.adb (Analyze_Expression_Function): If the expression
            of a static expression function has been transformed into an
            N_Raise_xxx_Error node, then we need to copy the original
            expression in order to check the requirement that the expression
            must be a potentially static expression. We also want to set
            aside a copy the untransformed expression for later use in
            checking calls to the expression function via
            Inline_Static_Function_Call.  So introduce a new function,
            Make_Expr_Copy, for use in these situations.
            * sem_res.adb (Preanalyze_And_Resolve): When analyzing certain
            expressions (e.g., a default parameter expression in a
            subprogram declaration) we want to suppress checks. However, we
            do not want to suppress checks for the expression of an
            expression function.

Diff:
---
 gcc/ada/exp_ch3.adb  | 88 ++++++++++++++++++++++++++++++++--------------------
 gcc/ada/exp_ch3.ads  | 13 +++++---
 gcc/ada/exp_ch4.adb  | 11 +++++++
 gcc/ada/sem_ch13.adb | 11 ++++++-
 gcc/ada/sem_ch6.adb  | 68 +++++++++++++++++++++++-----------------
 gcc/ada/sem_res.adb  |  6 +++-
 6 files changed, 128 insertions(+), 69 deletions(-)

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 87a84b4d858..03ff9258926 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -106,6 +106,13 @@ package body Exp_Ch3 is
    --  types with discriminants. Otherwise new identifiers are created,
    --  with the source names of the discriminants.
 
+   procedure Build_Discr_Checking_Funcs (N : Node_Id);
+   --  For each variant component, builds a function which checks whether
+   --  the component name is consistent with the current discriminants
+   --  and sets the component's Dcheck_Function attribute to refer to it.
+   --  N is the full type declaration node; the discriminant checking
+   --  functions are inserted after this node.
+
    function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id;
    --  This function builds a static aggregate that can serve as the initial
    --  value for an array type whose bounds are static, and whose component
@@ -152,6 +159,12 @@ package body Exp_Ch3 is
    --  needed after an initialization. Typ is the component type, and Proc_Id
    --  the initialization procedure for the enclosing composite type.
 
+   procedure Copy_Discr_Checking_Funcs (N : Node_Id);
+   --  For a derived untagged type, copy the attributes that were set
+   --  for the components of the parent type onto the components of the
+   --  derived type. No new subprograms are constructed.
+   --  N is the full type declaration node, as for Build_Discr_Checking_Funcs.
+
    procedure Expand_Freeze_Array_Type (N : Node_Id);
    --  Freeze an array type. Deals with building the initialization procedure,
    --  creating the packed array type for a packed array and also with the
@@ -1219,6 +1232,25 @@ package body Exp_Ch3 is
       end if;
    end Build_Discr_Checking_Funcs;
 
+   ----------------------------------------
+   -- Build_Or_Copy_Discr_Checking_Funcs --
+   ----------------------------------------
+
+   procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id) is
+      Typ : constant Entity_Id := Defining_Identifier (N);
+   begin
+      if Is_Unchecked_Union (Typ) or else not Has_Discriminants (Typ) then
+         null;
+      elsif not Is_Derived_Type (Typ)
+        or else Has_New_Non_Standard_Rep (Typ)
+        or else Is_Tagged_Type (Typ)
+      then
+         Build_Discr_Checking_Funcs (N);
+      else
+         Copy_Discr_Checking_Funcs (N);
+      end if;
+   end Build_Or_Copy_Discr_Checking_Funcs;
+
    --------------------------------
    -- Build_Discriminant_Formals --
    --------------------------------
@@ -4842,6 +4874,27 @@ package body Exp_Ch3 is
       end if;
    end Clean_Task_Names;
 
+   -------------------------------
+   -- Copy_Discr_Checking_Funcs --
+   -------------------------------
+
+   procedure Copy_Discr_Checking_Funcs (N : Node_Id) is
+      Typ      : constant Entity_Id := Defining_Identifier (N);
+      Comp     : Entity_Id := First_Component (Typ);
+      Old_Comp : Entity_Id := First_Component
+                                (Base_Type (Underlying_Type (Etype (Typ))));
+   begin
+      while Present (Comp) loop
+         if Chars (Comp) = Chars (Old_Comp) then
+            Set_Discriminant_Checking_Func
+              (Comp, Discriminant_Checking_Func (Old_Comp));
+         end if;
+
+         Next_Component (Old_Comp);
+         Next_Component (Comp);
+      end loop;
+   end Copy_Discr_Checking_Funcs;
+
    ----------------------------------------
    -- Ensure_Activation_Chain_And_Master --
    ----------------------------------------
@@ -5527,40 +5580,7 @@ package body Exp_Ch3 is
       --  we copy explicitly the discriminant checking functions from the
       --  parent into the components of the derived type.
 
-      if not Is_Derived_Type (Typ)
-        or else Has_New_Non_Standard_Rep (Typ)
-        or else Is_Tagged_Type (Typ)
-      then
-         Build_Discr_Checking_Funcs (Typ_Decl);
-
-      elsif Is_Derived_Type (Typ)
-        and then not Is_Tagged_Type (Typ)
-
-        --  If we have a derived Unchecked_Union, we do not inherit the
-        --  discriminant checking functions from the parent type since the
-        --  discriminants are non existent.
-
-        and then not Is_Unchecked_Union (Typ)
-        and then Has_Discriminants (Typ)
-      then
-         declare
-            Old_Comp : Entity_Id;
-
-         begin
-            Old_Comp :=
-              First_Component (Base_Type (Underlying_Type (Etype (Typ))));
-            Comp := First_Component (Typ);
-            while Present (Comp) loop
-               if Chars (Comp) = Chars (Old_Comp) then
-                  Set_Discriminant_Checking_Func
-                    (Comp, Discriminant_Checking_Func (Old_Comp));
-               end if;
-
-               Next_Component (Old_Comp);
-               Next_Component (Comp);
-            end loop;
-         end;
-      end if;
+      Build_Or_Copy_Discr_Checking_Funcs (Typ_Decl);
 
       if Is_Derived_Type (Typ)
         and then Is_Limited_Type (Typ)
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 23fecfd3cb9..ca8a5507674 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -56,10 +56,15 @@ package Exp_Ch3 is
    --  checks on the relevant aspects. The wrapper body could be simplified to
    --  a null body when expansion is disabled ???
 
-   procedure Build_Discr_Checking_Funcs (N : Node_Id);
-   --  Builds function which checks whether the component name is consistent
-   --  with the current discriminants. N is the full type declaration node,
-   --  and the discriminant checking functions are inserted after this node.
+   procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id);
+   --  For each variant component, builds a function that checks whether
+   --  the component name is consistent with the current discriminants
+   --  and sets the component's Dcheck_Function attribute to refer to it.
+   --  N is the full type declaration node; the discriminant checking
+   --  functions are inserted after this node.
+   --  In the case of a derived untagged type, copy the attributes that were
+   --  set for the components of the parent type onto the components of the
+   --  derived type; no new subprograms are constructed in this case.
 
    function Build_Initialization_Call
      (Loc                 : Source_Ptr;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 3b4d521dfae..140789a3f17 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -46,6 +46,7 @@ with Exp_Tss;        use Exp_Tss;
 with Exp_Util;       use Exp_Util;
 with Freeze;         use Freeze;
 with Inline;         use Inline;
+with Lib;            use Lib;
 with Namet;          use Namet;
 with Nlists;         use Nlists;
 with Nmake;          use Nmake;
@@ -11008,6 +11009,16 @@ package body Exp_Ch4 is
          --  actually performed.
 
          else
+            if (not Is_Unchecked_Union
+                     (Implementation_Base_Type (Etype (Prefix (N)))))
+              and then not Is_Predefined_Unit (Get_Source_Unit (N))
+            then
+               Error_Msg_N
+                 ("sorry - unable to generate discriminant check for" &
+                    " reference to variant component &",
+                  Selector_Name (N));
+            end if;
+
             Set_Do_Discriminant_Check (N, False);
          end if;
       end if;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index fdc767e803b..57ff450ebc8 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -33,6 +33,7 @@ with Einfo.Entities; use Einfo.Entities;
 with Einfo.Utils;    use Einfo.Utils;
 with Elists;         use Elists;
 with Errout;         use Errout;
+with Exp_Ch3;        use Exp_Ch3;
 with Exp_Disp;       use Exp_Disp;
 with Exp_Tss;        use Exp_Tss;
 with Exp_Util;       use Exp_Util;
@@ -13138,12 +13139,20 @@ package body Sem_Ch13 is
             end if;
          end;
 
+         --  Before we build a predicate function, ensure that discriminant
+         --  checking functions are available. The predicate function might
+         --  need to call these functions if the predicate references
+         --  any components declared in a variant part.
+         if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then
+            Build_Or_Copy_Discr_Checking_Funcs (Parent (E));
+         end if;
+
          Build_Predicate_Function (E, N);
       end if;
 
       --  If type has delayed aspects, this is where we do the preanalysis at
       --  the freeze point, as part of the consistent visibility check. Note
-      --  that this must be done after calling Build_Predicate_Functions or
+      --  that this must be done after calling Build_Predicate_Function or
       --  Build_Invariant_Procedure since these subprograms fix occurrences of
       --  the subtype name in the saved expression so that they will not cause
       --  trouble in the preanalysis.
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 8ca29746e43..5a3692cc914 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -570,42 +570,52 @@ package body Sem_Ch6 is
          --  RM in 4.9(3.2/5-3.4/5) and we flag an error.
 
          if Is_Static_Function (Def_Id) then
-            if not Is_Static_Expression (Expr) then
-               declare
-                  Exp_Copy : constant Node_Id := New_Copy_Tree (Expr);
-               begin
-                  Set_Checking_Potentially_Static_Expression (True);
+            declare
+               --  If a potentially static expr like "Parameter / 0"
+               --  is transformed into "(raise Constraint_Error)", then we
+               --  need to copy the Original_Node.
+               function Make_Expr_Copy return Node_Id is
+                 (New_Copy_Tree (if Expr in N_Raise_xxx_Error_Id
+                                 then Original_Node (Expr)
+                                 else Expr));
+            begin
+               if not Is_Static_Expression (Expr) then
+                  declare
+                     Exp_Copy : constant Node_Id := Make_Expr_Copy;
+                  begin
+                     Set_Checking_Potentially_Static_Expression (True);
 
-                  Preanalyze_Formal_Expression (Exp_Copy, Typ);
+                     Preanalyze_Formal_Expression (Exp_Copy, Typ);
 
-                  if not Is_Static_Expression (Exp_Copy) then
-                     Error_Msg_N
-                       ("static expression function requires "
-                          & "potentially static expression", Expr);
-                  end if;
+                     if not Is_Static_Expression (Exp_Copy) then
+                        Error_Msg_N
+                          ("static expression function requires "
+                             & "potentially static expression", Expr);
+                     end if;
 
-                  Set_Checking_Potentially_Static_Expression (False);
-               end;
-            end if;
+                     Set_Checking_Potentially_Static_Expression (False);
+                  end;
+               end if;
 
-            --  We also make an additional copy of the expression and
-            --  replace the expression of the expression function with
-            --  this copy, because the currently present expression is
-            --  now associated with the body created for the static
-            --  expression function, which will later be analyzed and
-            --  possibly rewritten, and we need to have the separate
-            --  unanalyzed copy available for use with later static
-            --  calls.
+               --  We also make an additional copy of the expression and
+               --  replace the expression of the expression function with
+               --  this copy, because the currently present expression is
+               --  now associated with the body created for the static
+               --  expression function, which will later be analyzed and
+               --  possibly rewritten, and we need to have the separate
+               --  unanalyzed copy available for use with later static
+               --  calls.
 
-            Set_Expression
-              (Original_Node (Subprogram_Spec (Def_Id)),
-               New_Copy_Tree (Expr));
+               Set_Expression
+                 (Original_Node (Subprogram_Spec (Def_Id)),
+                  Make_Expr_Copy);
 
-            --  Mark static expression functions as inlined, to ensure
-            --  that even calls with nonstatic actuals will be inlined.
+               --  Mark static expression functions as inlined, to ensure
+               --  that even calls with nonstatic actuals will be inlined.
 
-            Set_Has_Pragma_Inline (Def_Id);
-            Set_Is_Inlined (Def_Id);
+               Set_Has_Pragma_Inline (Def_Id);
+               Set_Is_Inlined (Def_Id);
+            end;
          end if;
       end if;
 
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 4ffb64c5ec7..ad6d4674f24 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -2060,7 +2060,11 @@ package body Sem_Res is
       --  case of Ada 2012 constructs such as quantified expressions, which are
       --  expanded in two separate steps.
 
-      if GNATprove_Mode then
+      --  We also do not want to suppress checks if we are not dealing
+      --  with a default expression. One such case that is known to reach
+      --  this point is the expression of an expression function.
+
+      if GNATprove_Mode or Nkind (Parent (N)) = N_Simple_Return_Statement then
          Analyze_And_Resolve (N, T);
       else
          Analyze_And_Resolve (N, T, Suppress => All_Checks);