This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [PING^2] ada: Add limitations on the acceptable prefixes of 'Old
On 11/05, Robert Dewar wrote:
> the deep check is quite easy to write with our standard traversal
> routines, and this results in a simple rule to state.
Here is an updated 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. If it appears in the default
expression of a parameter specification of a non-library-level subprogram,
check that it doesn't refer to local variables of the enclosing subprogram
for the same reason. Takes care of (2).
The test program will show the following errors:
7. (X : Integer := A'Old)
|
>>> attribute "Old" can only appear within subprogram
16. (X : Integer := Y'Old)
|
>>> attribute "Old" cannot refer to local variable
28. Y := Y'Old;
|
>>> attribute "Old" cannot refer to local variable
34. IL := IL'Old;
|
>>> attribute "Old" cannot refer to local variable
38. Y := Z'Old;
|
>>> attribute "Old" cannot refer to local variable
44. pragma Assert (G (3)'Old = Y);
|
>>> 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.
* 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.
---
gcc/ada/gnat_rm.texi | 3 +-
gcc/ada/sem_attr.adb | 60 ++++++++++++++++++++++++++++++++++
gcc/ada/sem_util.adb | 16 +++++++++
gcc/ada/sem_util.ads | 3 ++
gcc/testsuite/gnat.dg/old_errors.adb | 47 ++++++++++++++++++++++++++
gcc/testsuite/gnat.dg/old_errors.ads | 5 +++
6 files changed, 133 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..58700b5 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3480,6 +3480,66 @@ package body Sem_Attr is
Error_Attr ("attribute % cannot apply to limited objects", P);
end if;
+ -- Check that the current expression does not refer to local
+ -- variables.
+
+ declare
+ Subp : Entity_Id := Current_Subprogram;
+
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Check that N does not contain references to local variables
+ -- 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_Attr
+ ("attribute % cannot refer to local variable", N);
+ end if;
+ return OK;
+ end Process;
+
+ procedure Check_No_Local is new Traverse_Proc;
+
+ 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;
+
------------
-- Output --
------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 1be22cf..897213d 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5374,6 +5374,22 @@ 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 := Parent (N);
+ begin
+ 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 --
--------------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index a14d6a0..866bd7f 100644
--- a/gcc/ada/sem_util.ads
+++ b/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
diff --git a/gcc/testsuite/gnat.dg/old_errors.adb b/gcc/testsuite/gnat.dg/old_errors.adb
new file mode 100644
index 0000000..846c6c6
--- /dev/null
+++ b/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;
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;
--
1.5.5.1.406.g126ce