[PATCH] ada: Add limitations on the acceptable prefixes of 'Old

[Samuel Tardieu]

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- Taking 'Old on a out parameter is not considered an error, only a
    warning, saying that the value is read before being initialized.

 3- It is possible to take 'Old on a function, introducing the risk
    of having side effects. Moreover, it means that if F is a function,
    "F'Old = F'Old" is not guaranteed to return True as F will be called
    twice. In fact, it is possible to have any expression before 'Old.
    As 'Old is likely to be used in pragma Assert or pre/post conditions,
    this may increase the risk of side-effects depending on the current
    compilation mode (with or without assertions and checks).

 4- It is possible to have 'Old present in a formal default expression.
    This exposes some strange behaviour:

       Y : Integer := 0;
       function F (X : Integer := Y'Old) return Integer is
       begin
          return X;
       end F;
       function G return Integer is
       begin
          Y := 3;
          return F;
       end G;

     Calling G will return 0, while one may expect it to return 3.
     Y'Old is captured on entry in the subprogram where the call to
     F takes place, that is when entering G.

     Also, declaring
       Z : constant Integer := F;
     is impossible at the top-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.

This patch, which is expected to be applied after "[PATCH v3] ada: Allow
'Old attribute to be deeper in a subprogram" (which expands the capabilities
of 'Old), introduces the following constraints:

  - The prefix of 'Old must be an object, to avoid the risk of having side
    effects. Takes care of (3).

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

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

  - The prefix of 'Old cannot be an out mode parameter. Takes care of (2).

As those new constraints are related and lead to a few lines of localized
code in Sem_Attr, I send them at once. The test program will show the
following errors:

     3.    function F (X : Integer := Y'Old) return Integer is
                                       |
        >>> attribute "Old" cannot appear in a default expression

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

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

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

    21.    Y := O'Old;
                 |
        >>> attribute "Old" cannot refer to "out" mode parameter

    23.    Y := F'Old;
                 |
        >>> prefix of attribute "Old" must be an object

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.

    gcc/testsuite/
	* gnat.dg/old_errors.adb: New.
---
 gcc/ada/sem_attr.adb                 |   31 +++++++++++++++++++++++++++++++
 gcc/testsuite/gnat.dg/old_errors.adb |   24 ++++++++++++++++++++++++
 2 files changed, 55 insertions(+), 0 deletions(-)
 create mode 100644 gcc/testsuite/gnat.dg/old_errors.adb

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 19d636b..e5fe518 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3480,6 +3480,37 @@ package body Sem_Attr is
             Error_Attr ("attribute % cannot apply to limited objects", P);
          end if;
 
+         if not Is_Entity_Name (P)
+           or else Ekind (Entity (P)) not in Object_Kind
+         then
+            Error_Attr ("prefix of attribute % must be an object", N);
+         end if;
+
+         declare
+            Id : constant Entity_Id   := Entity (P);
+            PN : Node_Id;
+         begin
+            if Ekind (Id) = E_Out_Parameter then
+               Error_Attr
+                 ("attribute % cannot refer to OUT mode parameter", N);
+            end if;
+
+            if not Is_Formal (Id)
+              and then Current_Subprogram = Enclosing_Subprogram (Id)
+            then
+               Error_Attr ("attribute % cannot refer to local variable", N);
+            end if;
+
+            PN := Parent (P);
+            while Present (PN) loop
+               if Nkind (PN) = N_Parameter_Specification then
+                  Error_Attr
+                    ("attribute % cannot appear in a default expression", N);
+               end if;
+               PN := Parent (PN);
+            end loop;
+         end;
+
       ------------
       -- 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..f8933da
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/old_errors.adb
@@ -0,0 +1,24 @@
+procedure Old_Errors (I : in Integer; O : out Integer; IO : in out Integer) is
+   Y : Integer := 0;
+   function F (X : Integer := Y'Old) return Integer is -- { dg-error "default expression" }
+   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; -- { dg-error "mode parameter" }
+   Y := IO'Old;
+   Y := F'Old; -- { dg-error "must be an object" }
+end Old_Errors;
-- 
1.5.5.144.g3e42