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,