Re: [PING^2] ada: Add limitations on the acceptable prefixes of 'Old

[Samuel Tardieu <sam at rfc1149 dot net>]

On  7/05, Samuel Tardieu wrote:

| Yes, the updated patch I'm testing right now forbids using 'Old in this
| context only if "r" is not enclosed within another subprogram. And this
| doesn't require changing the doc :)

Here is an updated proposed patch:


The current implementation of the 'Old attribute has several problems:

 1- Using 'Old on a local variable will cause a copy to be made at the
    beginning of the subprogram declarative region, that is *before*
    the declaration and initialization of the variable being captured. The
    following example will crash GNAT:

       procedure C is
          X : Integer := 0;
       begin
          X := X'Old;
       end C;

 2- It is possible to have 'Old present in a formal default expression
    of a library-level subprogram. It means that declaring

       function F (X : Integer := Y'Old) return Integer;
       Z : constant Integer := F;

     is impossible at library level as there is no subprogram to capture
     the value of Y into. The error message saying that 'Old can only be
     used in a subprogram is unclear here as it points onto Z, and is
     suppressed if Z declaration is removed.

This patch introduces the following constraints:

  - The prefix of 'Old cannot be a local variable of the current subprogram.
    Takes care of (1).

  - The prefix of 'Old cannot appear in the default expression of a parameter
    specification of a library-level subprogram. Takes care of (2).

The test program will show the following errors:

     6.      (X : Integer := A'Old)
                              |
        >>> attribute "Old" can only appear within subprogram

    19.       Y := Y'Old;
                    |
        >>> attribute "Old" cannot refer to local variable

    25.             IL := IL'Old;
                            |
        >>> attribute "Old" cannot refer to local variable

    29.          Y := Z'Old;
                       |
        >>> attribute "Old" cannot refer to local variable

Regtested on i686-pc-linux-gnu.

Ok for trunk?

    gcc/ada/
	* sem_attr.adb (Analyze_Attribute, Attribute_Old case): Add
	restrictions to the prefix of 'Old.
	* gnat_rm.texi ('Old): Note that 'Old cannot be applied to local
	variables.

    gcc/testsuite/
	* gnat.dg/old_errors.ads, gnat.dg/old_errors.adb: New.
---

 gcc/ada/gnat_rm.texi                 |    3 ++-
 gcc/ada/sem_attr.adb                 |   24 +++++++++++++++++++++++
 gcc/testsuite/gnat.dg/old_errors.adb |   36 ++++++++++++++++++++++++++++++++++
 gcc/testsuite/gnat.dg/old_errors.ads |    5 +++++
 4 files changed, 67 insertions(+), 1 deletions(-)
 create mode 100644 gcc/testsuite/gnat.dg/old_errors.adb
 create mode 100644 gcc/testsuite/gnat.dg/old_errors.ads


diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index f8d5939..c048581 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -5774,7 +5774,8 @@ you can refer to Arg1.Field'Old which yields the value of
 Arg1.Field on entry. The implementation simply involves generating
 an object declaration which captures the value on entry. Any
 prefix is allowed except one of a limited type (since limited
-types cannot be copied to capture their values).
+types cannot be copied to capture their values) or a local variable
+(since it does not exist at subprogram entry time).
 
 The following example shows the use of 'Old to implement
 a test of a postcondition:
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 7550d90..ef40d57 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3480,6 +3480,30 @@ package body Sem_Attr is
             Error_Attr ("attribute % cannot apply to limited objects", P);
          end if;
 
+         if Is_Entity_Name (P)
+           and then not Is_Formal (Entity (P))
+           and then Current_Subprogram = Enclosing_Subprogram (Entity (P))
+         then
+            Error_Attr ("attribute % cannot refer to local variable", N);
+         end if;
+
+         --  We need to check that we are not in the default expression
+         --  of the formal parameter of a library-level subprogram.
+
+         if No (Enclosing_Subprogram (Current_Subprogram)) then
+            declare
+               PN : Node_Id := Parent (P);
+            begin
+               while Present (PN) loop
+                  if Nkind (PN) = N_Parameter_Specification then
+                     Error_Attr
+                       ("attribute % can only appear within subprogram", N);
+                  end if;
+                  PN := Parent (PN);
+               end loop;
+            end;
+         end if;
+
       ------------
       -- Output --
       ------------
diff --git a/gcc/testsuite/gnat.dg/old_errors.adb b/gcc/testsuite/gnat.dg/old_errors.adb
new file mode 100644
index 0000000..da22f47
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/old_errors.adb
@@ -0,0 +1,36 @@
+package body Old_Errors is
+
+   A : Integer;
+
+   function F
+     (X : Integer := A'Old) -- { dg-error "within subprogram" }
+     return Integer is
+   begin
+      return 0;
+   end F;
+
+   procedure P(I : in Integer; O : out Integer; IO : in out Integer) is
+      Y : Integer := 0;
+      function F (X : Integer := Y'Old) return Integer is
+      begin
+         return 0;
+      end F;
+   begin
+      Y := Y'Old; -- { dg-error "cannot refer to local variable" }
+      declare
+         Z : Integer := 0;
+         procedure Inner is
+            IL : Integer := 0;
+         begin
+            IL := IL'Old; -- { dg-error "cannot refer to local variable" }
+            Z  := Z'Old;
+         end Inner;
+      begin
+         Y := Z'Old; -- { dg-error "cannot refer to local variable" }
+      end;
+      Y := I'Old;
+      Y := O'Old;
+      Y := IO'Old;
+   end P;
+
+end Old_Errors;
diff --git a/gcc/testsuite/gnat.dg/old_errors.ads b/gcc/testsuite/gnat.dg/old_errors.ads
new file mode 100644
index 0000000..84717ff
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/old_errors.ads
@@ -0,0 +1,5 @@
+package Old_Errors is
+
+   pragma Elaborate_Body;
+
+end Old_Errors;