Previously, an attempt to declare a variant record type was rejected if
restriction No_Implicit_Conditionals was active, since the resulting
generated equality and initialization routines contained implicit tests.
Now such declarations are allowed, but these routines are not generated
if the restriction is active. Furthermore, if the restriction is active,
then any attempt to do a comparison of variant records, or to default
initialize such a record, will be considered a violation. The following
test is compiled with -gnatl -gnatj65 in the presence of a gnat.adc
file containing pragma Restrictions (No_Implicit_Conditionals).
1. package NICDisc is
2. type Enum is (One, Two, Three, Four);
3. type Variant (En : Enum) is record
4. E : Enum := En;
5. case En is
6. when One =>
7. I : Integer := 0;
8. when Two =>
9. B : Boolean := True;
10. I2 : Integer;
11. when Three | Four =>
12. null;
13. end case;
14. end record;
15. end NICDisc;
1. with NICDisc; use NICDisc;
2. package NICDiscr is
3. W : Variant (Two);
|
>>> violation of restriction "No_Implicit_Conditionals"
at gnat.adc:1, initialization of variant record
tests discriminants
4. X : Variant := (One, Two, 23);
5. Y : Variant := (Two, Two, True, 24);
6. M : Boolean := X = Y;
|
>>> violation of restriction "No_Implicit_Conditionals"
at gnat.adc:1, comparison of variant records tests
discriminants
7. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-06-11 Robert Dewar <de...@adacore.com>
* exp_ch3.adb (Build_Record_Init_Proc): Don't build for variant
record type if restriction No_Implicit_Conditionals is active.
(Expand_N_Object_Declaration): Don't allow default initialization
for variant record type if restriction No_Implicit_Condition is active.
(Build_Variant_Record_Equality): Don't build for variant
record type if restriction No_Implicit_Conditionals is active.
* exp_ch4.adb (Expand_N_Op_Eq): Error if variant records with
No_Implicit_Conditionals.
* sem_aux.ads, sem_aux.adb (Has_Variant_Part): New function.
Index: sem_aux.adb
===================================================================
--- sem_aux.adb (revision 211445)
+++ sem_aux.adb (working copy)
@@ -666,6 +666,51 @@
end if;
end Has_Unconstrained_Elements;
+ ----------------------
+ -- Has_Variant_Part --
+ ----------------------
+
+ function Has_Variant_Part (Typ : Entity_Id) return Boolean is
+ FSTyp : Entity_Id;
+ Decl : Node_Id;
+ TDef : Node_Id;
+ CList : Node_Id;
+
+ begin
+ if not Is_Type (Typ) then
+ return False;
+ end if;
+
+ FSTyp := First_Subtype (Typ);
+
+ if not Has_Discriminants (FSTyp) then
+ return False;
+ end if;
+
+ -- Proceed with cautious checks here, return False if tree is not
+ -- as expected (may be caused by prior errors).
+
+ Decl := Declaration_Node (FSTyp);
+
+ if Nkind (Decl) /= N_Full_Type_Declaration then
+ return False;
+ end if;
+
+ TDef := Type_Definition (Decl);
+
+ if Nkind (TDef) /= N_Record_Definition then
+ return False;
+ end if;
+
+ CList := Component_List (TDef);
+
+ if Nkind (CList) /= N_Component_List then
+ return False;
+ else
+ return Present (Variant_Part (CList));
+ end if;
+ end Has_Variant_Part;
+
---------------------
-- In_Generic_Body --
---------------------
Index: sem_aux.ads
===================================================================
--- sem_aux.ads (revision 211445)
+++ sem_aux.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -255,6 +255,10 @@
-- True if T has discriminants and is unconstrained, or is an array type
-- whose element type Has_Unconstrained_Elements.
+ function Has_Variant_Part (Typ : Entity_Id) return Boolean;
+ -- Return True if the first subtype of Typ is a discriminated record type
+ -- which has a variant part. False otherwise.
+
function In_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 211445)
+++ exp_ch4.adb (working copy)
@@ -6674,6 +6674,8 @@
R_Exp : Node_Id := Relocate_Node (Rhs);
begin
+ -- Adjust operands if necessary to comparison type
+
if Base_Type (Op_Type) /= Base_Type (A_Typ)
and then not Is_Class_Wide_Type (A_Typ)
then
@@ -6771,8 +6773,7 @@
-- formal is that of the discriminant, with added suffix,
-- see Exp_Ch3.Build_Record_Equality for details.
- if Is_Unchecked_Union
- (Scope (Entity (Selector_Name (Lhs))))
+ if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
then
Discr :=
First_Discriminant
@@ -7074,6 +7075,25 @@
Typl := Base_Type (Typl);
+ -- Equality between variant records results in a call to a routine
+ -- that has conditional tests of the discriminant value(s), and hence
+ -- violates the No_Implicit_Conditionals restriction.
+
+ if Has_Variant_Part (Typl) then
+ declare
+ Msg : Boolean;
+
+ begin
+ Check_Restriction (Msg, No_Implicit_Conditionals, N);
+
+ if Msg then
+ Error_Msg_N
+ ("\comparison of variant records tests discriminants", N);
+ return;
+ end if;
+ end;
+ end if;
+
-- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
-- means we no longer have a comparison operation, we are all done.
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 211445)
+++ exp_ch3.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -3484,6 +3484,18 @@
Rec_Type := Underlying_Type (Rec_Type);
end if;
+ -- If we have a variant record with restriction No_Implicit_Conditionals
+ -- in effect, then we skip building the procedure. This is safe because
+ -- if we can see the restriction, so can any caller, calls to initialize
+ -- such records are not allowed for variant records if this restriction
+ -- is active.
+
+ if Has_Variant_Part (Rec_Type)
+ and then Restriction_Active (No_Implicit_Conditionals)
+ then
+ return;
+ end if;
+
-- If there are discriminants, build the discriminant map to replace
-- discriminants by their discriminals in complex bound expressions.
-- These only arise for the corresponding records of synchronized types.
@@ -4316,6 +4328,16 @@
Pspecs : constant List_Id := New_List;
begin
+ -- If we have a variant record with restriction No_Implicit_Conditionals
+ -- in effect, then we skip building the procedure. This is safe because
+ -- if we can see the restriction, so can any caller, calls to equality
+ -- test routines are not allowed for variant records if this restriction
+ -- is active.
+
+ if Restriction_Active (No_Implicit_Conditionals) then
+ return;
+ end if;
+
-- Derived Unchecked_Union types no longer inherit the equality function
-- of their parent.
@@ -4431,11 +4453,8 @@
else
Append_To (Stmts,
- Make_Eq_If (Typ,
- Discriminant_Specifications (Def)));
-
- Append_List_To (Stmts,
- Make_Eq_Case (Typ, Comps));
+ Make_Eq_If (Typ, Discriminant_Specifications (Def)));
+ Append_List_To (Stmts, Make_Eq_Case (Typ, Comps));
end if;
Append_To (Stmts,
@@ -4838,6 +4857,7 @@
Def_Id : constant Entity_Id := Defining_Identifier (N);
Expr : constant Node_Id := Expression (N);
Loc : constant Source_Ptr := Sloc (N);
+ Obj_Def : constant Node_Id := Object_Definition (N);
Typ : constant Entity_Id := Etype (Def_Id);
Base_Typ : constant Entity_Id := Base_Type (Typ);
Expr_Q : Node_Id;
@@ -4999,7 +5019,7 @@
and then Is_Entity_Name (Expr_Q)
and then Ekind (Entity (Expr_Q)) = E_Variable
and then OK_To_Rename (Entity (Expr_Q))
- and then Is_Entity_Name (Object_Definition (N));
+ and then Is_Entity_Name (Obj_Def);
end Rewrite_As_Renaming;
-- Start of processing for Expand_N_Object_Declaration
@@ -5065,6 +5085,26 @@
if No (Expr) then
+ -- If we have a type with a variant part, the initialization proc
+ -- will contain implicit tests of the discriminant values, which
+ -- counts as a violation of the restriction No_Implicit_Conditionals.
+
+ if Has_Variant_Part (Typ) then
+ declare
+ Msg : Boolean;
+
+ begin
+ Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def);
+
+ if Msg then
+ Error_Msg_N
+ ("\initialization of variant record tests discriminants",
+ Obj_Def);
+ return;
+ end if;
+ end;
+ end if;
+
-- For the default initialization case, if we have a private type
-- with invariants, and invariant checks are enabled, then insert an
-- invariant check after the object declaration. Note that it is OK
@@ -5305,9 +5345,9 @@
-- then we've done it already and must not do it again.
and then not
- (Nkind (Object_Definition (N)) = N_Identifier
+ (Nkind (Obj_Def) = N_Identifier
and then
- Present (Equivalent_Type (Entity (Object_Definition (N)))))
+ Present (Equivalent_Type (Entity (Obj_Def))))
then
pragma Assert (Is_Class_Wide_Type (Typ));
@@ -5416,7 +5456,7 @@
Expand_Subtype_From_Expr
(N => N,
Unc_Type => Typ,
- Subtype_Indic => Object_Definition (N),
+ Subtype_Indic => Obj_Def,
Exp => Expr_N);
if not Is_Interface (Etype (Expr_N)) then
@@ -5427,7 +5467,7 @@
else
New_Expr :=
- Unchecked_Convert_To (Etype (Object_Definition (N)),
+ Unchecked_Convert_To (Etype (Obj_Def),
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RTE (RE_Tag_Ptr),
Make_Attribute_Reference (Loc,
@@ -5442,8 +5482,7 @@
Make_Object_Declaration (Loc,
Defining_Identifier => Obj_Id,
Object_Definition =>
- New_Occurrence_Of
- (Etype (Object_Definition (N)), Loc),
+ New_Occurrence_Of (Etype (Obj_Def), Loc),
Expression => New_Expr));
-- Rename limited type object since they cannot be copied
@@ -5455,11 +5494,10 @@
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Obj_Id,
Subtype_Mark =>
- New_Occurrence_Of
- (Etype (Object_Definition (N)), Loc),
+ New_Occurrence_Of (Etype (Obj_Def), Loc),
Name =>
Unchecked_Convert_To
- (Etype (Object_Definition (N)), New_Expr)));
+ (Etype (Obj_Def), New_Expr)));
end if;
-- Dynamically reference the tag associated with the
@@ -5744,7 +5782,7 @@
Rewrite (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Defining_Identifier (N),
- Subtype_Mark => Object_Definition (N),
+ Subtype_Mark => Obj_Def,
Name => Expr_Q));
-- We do not analyze this renaming declaration, because all its
@@ -5778,7 +5816,7 @@
end if;
if Nkind (N) = N_Object_Declaration
- and then Nkind (Object_Definition (N)) = N_Access_Definition
+ and then Nkind (Obj_Def) = N_Access_Definition
and then not Is_Local_Anonymous_Access (Etype (Def_Id))
then
-- An Ada 2012 stand-alone object of an anonymous access type
@@ -5810,12 +5848,14 @@
Level_Expr := Dynamic_Accessibility_Level (Expr);
end if;
- Level_Decl := Make_Object_Declaration (Loc,
- Defining_Identifier => Level,
- Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
- Expression => Level_Expr,
- Constant_Present => Constant_Present (N),
- Has_Init_Expression => True);
+ Level_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Level,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression => Level_Expr,
+ Constant_Present => Constant_Present (N),
+ Has_Init_Expression => True);
Insert_Action_After (Init_After, Level_Decl);
@@ -8641,6 +8681,7 @@
if Chars (Discr) = External_Name (Node (Elm)) then
return Node (Elm);
end if;
+
Next_Elmt (Elm);
end loop;
@@ -8676,14 +8717,12 @@
end if;
Alt_List := New_List;
-
while Present (Variant) loop
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
Statements =>
Make_Eq_Case (E, Component_List (Variant), Discrs)));
-
Next_Non_Pragma (Variant);
end loop;
@@ -8785,7 +8824,7 @@
else
return
Make_Implicit_If_Statement (E,
- Condition => Cond,
+ Condition => Cond,
Then_Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
@@ -8793,9 +8832,9 @@
end if;
end Make_Eq_If;
- --------------------
- -- Make_Neq_Body --
- --------------------
+ -------------------
+ -- Make_Neq_Body --
+ -------------------
function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is
