A new pragma Unevaluated_Use_Of_Old (Error | Warn | Allow) is
implemented which controls the processing of attributes Old and
Loop_Entry. If either of these attributes is used in a potentially
unevaluated expression e.g. the then or else parts of an if
expression), then normally this usage is considered illegal if
the prefix of the attribute is other than an entity name. The
language requires this behavior for Old, and GNAT copies the
same rule for Loop_Entry.
Although the rule avoids this possibility, it is sometimes
too restrictive. The pragma Unevaluated_Use_Of_Old can be
used to modify this behavior. If the argument is ERROR, then an
error is given (this is the default RM behavior). If the argument is
WARN then the usage is allowed as legal but with a warning
that an exception might be raised. If the argument is ALLOW
then the usage is allowed as legal without generating a warning.
This pragma may appear as a configuration pragma, or in a declarative
part or package specification. In the latter case it applies to
uses up to the end of the corresponding statement sequence or
sequence of package declarations.
The following is compiled with -gnatc -gnatwW -gnatld7 -gnatj60
1. package UnevalOld is
2. K : Character;
3. procedure U (A : String; C : Boolean) -- ERROR
4. with Post => (if C then A(1)'Old = K else True);
|
>>> prefix of attribute "Old" that is potentially
unevaluated must denote an entity
5. procedure V (A : String; C : Boolean)
6. with Post => A(1)'Old = K;
7.
8. package U1 is
9. pragma Unevaluated_Use_Of_Old (Warn); -- WARNING
10. procedure P1 (A : String; C : Boolean)
11. with Post => (if C then A(1)'Old = K else True);
|
>>> warning: prefix of attribute "Old" appears in
potentially unevaluated context, exception may
be raised
12. end U1;
13.
14. package U2 is
15. pragma Unevaluated_Use_Of_Old (Allow); -- OK
16. procedure P2 (A : String; C : Boolean)
17. with Post => (if C then A(1)'Old = K else True);
18. end U2;
19. end;
If the same compilation is carried out with a gnat.adc file that
contains the pragma:
pragma Unevaluated_Use_Of_Old (Allow);
Then the output omits the first error:
1. package UnevalOld is
2. K : Character;
3. procedure U (A : String; C : Boolean) -- ERROR
4. with Post => (if C then A(1)'Old = K else True);
5. procedure V (A : String; C : Boolean)
6. with Post => A(1)'Old = K;
7.
8. package U1 is
9. pragma Unevaluated_Use_Of_Old (Warn); -- WARNING
10. procedure P1 (A : String; C : Boolean)
11. with Post => (if C then A(1)'Old = K else True);
|
>>> warning: prefix of attribute "Old" appears in
potentially unevaluated context, exception may
be raised
12. end U1;
13.
14. package U2 is
15. pragma Unevaluated_Use_Of_Old (Allow); -- OK
16. procedure P2 (A : String; C : Boolean)
17. with Post => (if C then A(1)'Old = K else True);
18. end U2;
19. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-29 Robert Dewar <de...@adacore.com>
* gnat_rm.texi: Document pragma Unevaluated_Use_Of_Old.
* opt.adb: Handle Uneval_Old.
* opt.ads (Uneval_Old, Uneval_Old_Config): New variables.
* par-prag.adb: Add dummy entry for pragma Unevaluated_Use_Of_Old.
* sem.ads (Save_Uneval_Old): New field in Scope_Stack_Entry.
* sem_attr.adb (Uneval_Old_Msg): New procedure.
* sem_ch8.adb (Push_Scope): Save Uneval_Old.
(Pop_Scope): Restore Uneval_Old.
* sem_prag.adb (Analyze_Pragma, case Unevaluated_Use_Of_Old):
Implemented.
* snames.ads-tmpl: Add entries for pragma Unevaluated_Use_Of_Old
Add entries for Name_Warn, Name_Allow.
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 213156)
+++ gnat_rm.texi (working copy)
@@ -270,6 +270,7 @@
* Pragma Type_Invariant::
* Pragma Type_Invariant_Class::
* Pragma Unchecked_Union::
+* Pragma Unevaluated_Use_Of_Old::
* Pragma Unimplemented_Unit::
* Pragma Universal_Aliasing ::
* Pragma Universal_Data::
@@ -1119,6 +1120,7 @@
* Pragma Type_Invariant::
* Pragma Type_Invariant_Class::
* Pragma Unchecked_Union::
+* Pragma Unevaluated_Use_Of_Old::
* Pragma Unimplemented_Unit::
* Pragma Universal_Aliasing ::
* Pragma Universal_Data::
@@ -7242,6 +7244,59 @@
version in all language modes (Ada 83, Ada 95, and Ada 2005). For full
details, consult the Ada 2012 Reference Manual, section B.3.3.
+@node Pragma Unevaluated_Use_Of_Old
+@unnumberedsec Pragma Unevaluated_Use_Of_Old
+@cindex Attribute Old
+@cindex Attribute Loop_Entry
+@cindex Unevaluated_Use_Of_Old
+@findex Unevaluated_Use_Of_Old
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
+@end smallexample
+
+@noindent
+This pragma controls the processing of attributes Old and Loop_Entry.
+If either of these attributes is used in a potentially unevaluated
+expression (e.g. the then or else parts of an if expression), then
+normally this usage is considered illegal if the prefix of the attribute
+is other than an entity name. The language requires this
+behavior for Old, and GNAT copies the same rule for Loop_Entry.
+
+The reason for this rule is that otherwise, we can have a situation
+where we save the Old value, and this results in an exception, even
+though we might not evaluate the attribute. Consider this example:
+
+@smallexample @c ada
+package UnevalOld is
+ K : Character;
+ procedure U (A : String; C : Boolean) -- ERROR
+ with Post => (if C then A(1)'Old = K else True);
+end;
+@end smallexample
+
+@noindent
+If procedure U is called with a string with a lower bound of 2, and
+C false, then an exception would be raised trying to evaluate A(1)
+on entry even though the value would not be actually used.
+
+Although the rule guarantees against this possibility, it is sometimes
+too restrictive. For example if we know that the string has a lower
+bound of 1, then we will never raise an exception.
+The pragma @code{Unevaluated_Use_Of_Old} can be
+used to modify this behavior. If the argument is @code{Error} then an
+error is given (this is the default RM behavior). If the argument is
+@code{Warn} then the usage is allowed as legal but with a warning
+that an exception might be raised. If the argument is @code{Allow}
+then the usage is allowed as legal without generating a warning.
+
+This pragma may appear as a configuration pragma, or in a declarative
+part or package specification. In the latter case it applies to
+uses up to the end of the corresponding statement sequence or
+sequence of package declarations.
+
@node Pragma Unimplemented_Unit
@unnumberedsec Pragma Unimplemented_Unit
@findex Unimplemented_Unit
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 213159)
+++ sem_prag.adb (working copy)
@@ -21182,6 +21182,30 @@
Ada_2005_Pragma;
Process_Suppress_Unsuppress (False);
+ ----------------------------
+ -- Unevaluated_Use_Of_Old --
+ ----------------------------
+
+ -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
+
+ when Pragma_Unevaluated_Use_Of_Old =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
+
+ -- Suppress/Unsuppress can appear as a configuration pragma, or in
+ -- a declarative part or a package spec.
+
+ if not Is_Configuration_Pragma then
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ end if;
+
+ -- Store proper setting of Uneval_Old
+
+ Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
+ Uneval_Old := Fold_Upper (Name_Buffer (1));
+
-------------------
-- Use_VADS_Size --
-------------------
@@ -25442,6 +25466,7 @@
Pragma_Unreferenced_Objects => -1,
Pragma_Unreserve_All_Interrupts => -1,
Pragma_Unsuppress => 0,
+ Pragma_Unevaluated_Use_Of_Old => 0,
Pragma_Use_VADS_Size => -1,
Pragma_Validity_Checks => -1,
Pragma_Volatile => 0,
Index: sem.ads
===================================================================
--- sem.ads (revision 213156)
+++ sem.ads (working copy)
@@ -486,6 +486,9 @@
Save_SPARK_Mode_Pragma : Node_Id;
-- Setting of SPARK_Mode_Pragma on entry to restore on exit
+ Save_Uneval_Old : Character;
+ -- Setting of Uneval_Old on entry to restore on exit
+
Is_Transient : Boolean;
-- Marks transient scopes (see Exp_Ch7 body for details)
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 213159)
+++ sem_attr.adb (working copy)
@@ -409,6 +409,12 @@
-- node is rewritten with an integer literal of the given value which
-- is marked as static.
+ procedure Uneval_Old_Msg;
+ -- Called when Loop_Entry or Old is used in a potentially unevaluated
+ -- expression. Generates appropriate message or warning depending on
+ -- the setting of Opt.Uneval_Old. The caller has put the Name_Id of
+ -- the attribute in Error_Msg_Name_1 prior to the call.
+
procedure Unexpected_Argument (En : Node_Id);
-- Signal unexpected attribute argument (En is the argument)
@@ -2264,6 +2270,31 @@
Set_Is_Static_Expression (N, True);
end Standard_Attribute;
+ --------------------
+ -- Uneval_Old_Msg --
+ --------------------
+
+ procedure Uneval_Old_Msg is
+ begin
+ case Uneval_Old is
+ when 'E' =>
+ Error_Attr_P
+ ("prefix of attribute % that is potentially "
+ & "unevaluated must denote an entity");
+
+ when 'W' =>
+ Error_Attr_P
+ ("??prefix of attribute % appears in potentially "
+ & "unevaluated context, exception may be raised");
+
+ when 'A' =>
+ null;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Uneval_Old_Msg;
+
-------------------------
-- Unexpected Argument --
-------------------------
@@ -4108,9 +4139,7 @@
& "outer loop must denote an entity");
elsif Is_Potentially_Unevaluated (P) then
- Error_Attr_P
- ("prefix of attribute % that is potentially "
- & "unevaluated must denote an entity");
+ Uneval_Old_Msg;
end if;
-- Finally, if the Loop_Entry attribute appears within a pragma
@@ -4751,9 +4780,7 @@
and then Is_Potentially_Unevaluated (N)
and then not Is_Entity_Name (P)
then
- Error_Attr_P
- ("prefix of attribute % that is potentially unevaluated must "
- & "denote an entity");
+ Uneval_Old_Msg;
end if;
-- The attribute appears within a pre/postcondition, but refers to
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 213156)
+++ par-prag.adb (working copy)
@@ -1337,6 +1337,7 @@
Pragma_Type_Invariant |
Pragma_Type_Invariant_Class |
Pragma_Unchecked_Union |
+ Pragma_Unevaluated_Use_Of_Old |
Pragma_Unimplemented_Unit |
Pragma_Universal_Aliasing |
Pragma_Universal_Data |
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 213156)
+++ sem_ch8.adb (working copy)
@@ -7533,6 +7533,7 @@
Default_Pool := SST.Save_Default_Storage_Pool;
SPARK_Mode := SST.Save_SPARK_Mode;
SPARK_Mode_Pragma := SST.Save_SPARK_Mode_Pragma;
+ Uneval_Old := SST.Save_Uneval_Old;
if Debug_Flag_W then
Write_Str ("<-- exiting scope: ");
@@ -7605,6 +7606,7 @@
SST.Save_Default_Storage_Pool := Default_Pool;
SST.Save_SPARK_Mode := SPARK_Mode;
SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma;
+ SST.Save_Uneval_Old := Uneval_Old;
if Scope_Stack.Last > Scope_Stack.First then
SST.Component_Alignment_Default := Scope_Stack.Table
Index: opt.adb
===================================================================
--- opt.adb (revision 213156)
+++ opt.adb (working copy)
@@ -65,6 +65,7 @@
Short_Descriptors_Config := Short_Descriptors;
SPARK_Mode_Config := SPARK_Mode;
SPARK_Mode_Pragma_Config := SPARK_Mode_Pragma;
+ Uneval_Old_Config := Uneval_Old;
Use_VADS_Size_Config := Use_VADS_Size;
Warnings_As_Errors_Count_Config := Warnings_As_Errors_Count;
@@ -103,6 +104,7 @@
Short_Descriptors := Save.Short_Descriptors;
SPARK_Mode := Save.SPARK_Mode;
SPARK_Mode_Pragma := Save.SPARK_Mode_Pragma;
+ Uneval_Old := Save.Uneval_Old;
Use_VADS_Size := Save.Use_VADS_Size;
Warnings_As_Errors_Count := Save.Warnings_As_Errors_Count;
@@ -142,6 +144,7 @@
Save.Short_Descriptors := Short_Descriptors;
Save.SPARK_Mode := SPARK_Mode;
Save.SPARK_Mode_Pragma := SPARK_Mode_Pragma;
+ Save.Uneval_Old := Uneval_Old;
Save.Use_VADS_Size := Use_VADS_Size;
Save.Warnings_As_Errors_Count := Warnings_As_Errors_Count;
end Save_Opt_Config_Switches;
@@ -171,6 +174,7 @@
External_Name_Imp_Casing := Lowercase;
Optimize_Alignment := 'O';
Persistent_BSS_Mode := False;
+ Uneval_Old := 'E';
Use_VADS_Size := False;
Optimize_Alignment_Local := True;
@@ -217,6 +221,7 @@
Persistent_BSS_Mode := Persistent_BSS_Mode_Config;
SPARK_Mode := SPARK_Mode_Config;
SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config;
+ Uneval_Old := Uneval_Old_Config;
Use_VADS_Size := Use_VADS_Size_Config;
Warnings_As_Errors_Count := Warnings_As_Errors_Count_Config;
Index: opt.ads
===================================================================
--- opt.ads (revision 213156)
+++ opt.ads (working copy)
@@ -1487,6 +1487,11 @@
-- file for the compiler. Indicates that while preprocessing sources,
-- symbols that are not defined have the value FALSE.
+ Uneval_Old : Character := 'E';
+ -- GNAT
+ -- Set to 'E'/'W'/'A' for use of Error/Warn/Allow in a valid pragma
+ -- Unevaluated_Use_Of_Old.
+
Unique_Error_Tag : Boolean := Tag_Errors;
-- GNAT
-- Indicates if error messages are to be prefixed by the string error:
@@ -1952,6 +1957,10 @@
-- If a SPARK_Mode pragma appeared in the configuration pragmas (setting
-- SPARK_Mode_Config appropriately), then this points to the N_Pragma node.
+ Uneval_Old_Config : Character;
+ -- GNAT
+ -- The setting of Uneval_Old from configuration pragmas
+
Use_VADS_Size_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that controls the use of
@@ -2122,6 +2131,7 @@
Short_Descriptors : Boolean;
SPARK_Mode : SPARK_Mode_Type;
SPARK_Mode_Pragma : Node_Id;
+ Uneval_Old : Character;
Use_VADS_Size : Boolean;
Warnings_As_Errors_Count : Natural;
end record;
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 213156)
+++ snames.ads-tmpl (working copy)
@@ -442,6 +442,7 @@
Name_Suppress : constant Name_Id := N + $;
Name_Suppress_Exception_Locations : constant Name_Id := N + $; -- GNAT
Name_Task_Dispatching_Policy : constant Name_Id := N + $;
+ Name_Unevaluated_Use_Of_Old : constant Name_Id := N + $; -- GNAT
Name_Universal_Data : constant Name_Id := N + $; -- AAMP
Name_Unsuppress : constant Name_Id := N + $; -- Ada 05
Name_Use_VADS_Size : constant Name_Id := N + $; -- GNAT
@@ -687,6 +688,7 @@
-- Other special names used in processing pragmas
+ Name_Allow : constant Name_Id := N + $;
Name_Amount : constant Name_Id := N + $;
Name_As_Is : constant Name_Id := N + $;
Name_Assertion : constant Name_Id := N + $;
@@ -811,6 +813,7 @@
Name_Vector : constant Name_Id := N + $;
Name_VMS : constant Name_Id := N + $;
Name_Vtable_Ptr : constant Name_Id := N + $;
+ Name_Warn : constant Name_Id := N + $;
Name_Working_Storage : constant Name_Id := N + $;
-- Names of recognized attributes. The entries with the comment "Ada 83"
@@ -1791,6 +1794,7 @@
Pragma_Suppress,
Pragma_Suppress_Exception_Locations,
Pragma_Task_Dispatching_Policy,
+ Pragma_Unevaluated_Use_Of_Old,
Pragma_Universal_Data,
Pragma_Unsuppress,
Pragma_Use_VADS_Size,
