From eaa2f8c7e6ae12642905df0e518d58b724bccf5f Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 14 May 2008 07:07:24 +0000 Subject: [PATCH] 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 From-SVN: r135282 --- gcc/ada/ChangeLog | 9 ++++ gcc/ada/gnat_rm.texi | 3 +- gcc/ada/sem_attr.adb | 62 ++++++++++++++++++++++++++++ gcc/ada/sem_util.adb | 20 +++++++++ gcc/ada/sem_util.ads | 3 ++ gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/old_errors.adb | 47 +++++++++++++++++++++ gcc/testsuite/gnat.dg/old_errors.ads | 5 +++ 8 files changed, 152 insertions(+), 1 deletion(-) 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/ChangeLog b/gcc/ada/ChangeLog index cffae3bc3a7..b473b8e6fc2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2008-05-14 Samuel Tardieu + Robert Dewar + + * 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 PR ada/24880 diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index f8d5939b708..c048581d662 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 7550d90655d..6a7846eacba 100644 --- a/gcc/ada/sem_attr.adb +++ b/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 -- ------------ diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1be22cf7df0..c335417d1b7 100644 --- a/gcc/ada/sem_util.adb +++ b/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 -- -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a14d6a0149f..866bd7f98a5 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/ChangeLog b/gcc/testsuite/ChangeLog index ff7b73d74df..05a2d2569a0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2008-05-14 Samuel Tardieu + + * gnat.dg/old_errors.ads, gnat.dg/old_errors.adb: New. + 2008-05-14 Andreas Krebbel * g++.dg/eh/080513-1.C: New testcase. diff --git a/gcc/testsuite/gnat.dg/old_errors.adb b/gcc/testsuite/gnat.dg/old_errors.adb new file mode 100644 index 00000000000..846c6c61f25 --- /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 00000000000..84717ff0639 --- /dev/null +++ b/gcc/testsuite/gnat.dg/old_errors.ads @@ -0,0 +1,5 @@ +package Old_Errors is + + pragma Elaborate_Body; + +end Old_Errors; -- 2.30.2