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.
Tested on x86_64-pc-linux-gnu, committed on trunk
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 --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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);
