sem_attr.adb (Analyze_Attribute, [...]): Add restrictions to the prefix of 'Old.

gcc/ada/
	* sem_attr.adb (Analyze_Attribute, Attribute_Old case): Add
	restrictions to the prefix of 'Old.
	* sem_util.ads, sem_util.adb (In_Parameter_Specification): New.
	* 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.

Co-Authored-By: Robert Dewar <dewar@adacore.com>

From-SVN: r135282

gcc/ada/ChangeLog

@@ -1,3 +1,12 @@
+2008-05-14  Samuel Tardieu  <sam@rfc1149.net>
+            Robert Dewar <dewar@adacore.com>
+
+	* sem_attr.adb (Analyze_Attribute, Attribute_Old case): Add
+	restrictions to the prefix of 'Old.
+	* sem_util.ads, sem_util.adb (In_Parameter_Specification): New.
+	* gnat_rm.texi ('Old): Note that 'Old cannot be applied to local
+	variables.
+
 2008-05-13  Eric Botcazou  <ebotcazou@adacore.com>
 
 	PR ada/24880

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:

gcc/ada/sem_attr.adb

@@ -3480,6 +3480,68 @@ package body Sem_Attr is
             Error_Attr ("attribute % cannot apply to limited objects", P);
          end if;
 
+         --  Check that the expression does not refer to local entities
+
+         Check_Local : declare
+            Subp : Entity_Id := Current_Subprogram;
+
+            function Process (N : Node_Id) return Traverse_Result;
+            --  Check that N does not contain references to local variables
+            --  or other local entities of Subp.
+
+            -------------
+            -- Process --
+            -------------
+
+            function Process (N : Node_Id) return Traverse_Result is
+            begin
+               if Is_Entity_Name (N)
+                 and then not Is_Formal (Entity (N))
+                 and then Enclosing_Subprogram (Entity (N)) = Subp
+               then
+                  Error_Msg_Node_1 := Entity (N);
+                  Error_Attr
+                    ("attribute % cannot refer to local variable&", N);
+               end if;
+
+               return OK;
+            end Process;
+
+            procedure Check_No_Local is new Traverse_Proc;
+
+         --  Start of processing for Check_Local
+
+         begin
+            Check_No_Local (P);
+
+            if In_Parameter_Specification (P) then
+
+               --  We have additional restrictions on using 'Old in parameter
+               --  specifications.
+
+               if Present (Enclosing_Subprogram (Current_Subprogram)) then
+
+                  --  Check that there is no reference to the enclosing
+                  --  subprogram local variables. Otherwise, we might end
+                  --  up being called from the enclosing subprogram and thus
+                  --  using 'Old on a local variable which is not defined
+                  --  at entry time.
+
+                  Subp := Enclosing_Subprogram (Current_Subprogram);
+                  Check_No_Local (P);
+
+               else
+                  --  We must prevent default expression of library-level
+                  --  subprogram from using 'Old, as the subprogram may be
+                  --  used in elaboration code for which there is no enclosing
+                  --  subprogram.
+
+                  Error_Attr
+                    ("attribute % can only appear within subprogram", N);
+               end if;
+            end if;
+         end Check_Local;
+
       ------------
       -- Output --
       ------------

gcc/ada/sem_util.adb

@@ -5374,6 +5374,26 @@ package body Sem_Util is
       return False;
    end In_Package_Body;
 
+   --------------------------------
+   -- In_Parameter_Specification --
+   --------------------------------
+
+   function In_Parameter_Specification (N : Node_Id) return Boolean is
+      PN : Node_Id;
+
+   begin
+      PN := Parent (N);
+      while Present (PN) loop
+         if Nkind (PN) = N_Parameter_Specification then
+            return True;
+         end if;
+
+         PN := Parent (PN);
+      end loop;
+
+      return False;
+   end In_Parameter_Specification;
+
    --------------------------------------
    -- In_Subprogram_Or_Concurrent_Unit --
    --------------------------------------

gcc/ada/sem_util.ads

@@ -590,6 +590,9 @@ package Sem_Util is
    function In_Package_Body return Boolean;
    --  Returns True if current scope is within a package body
 
+   function In_Parameter_Specification (N : Node_Id) return Boolean;
+   --  Returns True if node N belongs to a parameter specification
+
    function In_Subprogram_Or_Concurrent_Unit return Boolean;
    --  Determines if the current scope is within a subprogram compilation
    --  unit (inside a subprogram declaration, subprogram body, or generic

gcc/testsuite/ChangeLog

@@ -1,3 +1,7 @@
+2008-05-14  Samuel Tardieu  <sam@rfc1149.net>
+
+	* gnat.dg/old_errors.ads, gnat.dg/old_errors.adb: New.
+
 2008-05-14  Andreas Krebbel  <krebbel1@de.ibm.com>
 
 	* g++.dg/eh/080513-1.C: New testcase.

gcc/testsuite/gnat.dg/old_errors.adb

@@ -0,0 +1,47 @@
+-- { dg-do compile }
+package body Old_Errors is
+
+   A : Integer;
+
+   function F
+     (X : Integer := A'Old) -- { dg-error "can only appear within subprogram" }
+     return Integer is
+   begin
+      return X;
+   end F;
+
+   procedure P (I : in Integer; O : out Integer; IO : in out Integer) is
+      Y : Integer := 0;
+      function G
+        (X : Integer := Y'Old) -- { dg-error "cannot refer to local variable" }
+        return Integer is
+      begin
+         return X;
+      end G;
+
+      function H (X : Integer := A'Old) return Integer is  -- OK
+      begin
+         return X;
+      end H;
+
+   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;  -- OK
+         end Inner;
+      begin
+         Y := Z'Old; -- { dg-error "cannot refer to local variable" }
+      end;
+      Y := I'Old;   -- OK
+      Y := O'Old;   -- OK
+      Y := IO'Old;  -- OK
+      Y := G;       -- OK, error has been signalled at G declaration
+      pragma Assert (G (3)'Old = Y); -- { dg-error "cannot refer to local variable" }
+   end P;
+
+end Old_Errors;

gcc/testsuite/gnat.dg/old_errors.ads

@@ -0,0 +1,5 @@
+package Old_Errors is
+
+   pragma Elaborate_Body;
+
+end Old_Errors;