This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[PATCH] ada: Initialize OUT access type parameters of an entry call
- From: Samuel Tardieu <sam at rfc1149 dot net>
- To: gcc-patches at gcc dot gnu dot org
- Date: Sat, 1 Dec 2007 14:38:35 +0100
- Subject: [PATCH] ada: Initialize OUT access type parameters of an entry call
- Organisation: RFC1149 (see http://www.rfc1149.net/)
Regtested on i686-pc-linux-gnu.
gcc/ada/
PR ada/21489
* exp_ch9.adb (Build_Simple_Entry_Call): Initialize OUT access type
parameters of an entry call.
gcc/testsuite/
PR ada/21489
* gnat.dg/rm_6_4_1_13.adb: New test.
---
gcc/ada/exp_ch9.adb | 7 ++-
gcc/testsuite/gnat.dg/rm_6_4_1_13.adb | 90 +++++++++++++++++++++++++++++++++
2 files changed, 95 insertions(+), 2 deletions(-)
create mode 100644 gcc/testsuite/gnat.dg/rm_6_4_1_13.adb
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 87fbc12..ed3f242 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -3023,9 +3023,12 @@ package body Exp_Ch9 is
-- We have to make an assignment statement separate for the
-- case of limited type. We cannot assign it unless the
- -- Assignment_OK flag is set first.
+ -- Assignment_OK flag is set first. OUT access type
+ -- parameters are also initialized per RM 6.4.1 (13).
- if Ekind (Formal) /= E_Out_Parameter then
+ if Ekind (Formal) /= E_Out_Parameter
+ or else Is_Access_Type (Etype (Formal))
+ then
N_Var :=
New_Reference_To (Defining_Identifier (N_Node), Loc);
Set_Assignment_OK (N_Var);
diff --git a/gcc/testsuite/gnat.dg/rm_6_4_1_13.adb b/gcc/testsuite/gnat.dg/rm_6_4_1_13.adb
new file mode 100644
index 0000000..2c315b8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/rm_6_4_1_13.adb
@@ -0,0 +1,90 @@
+-- { dg-do run }
+-- { dg-options "-gnatwA" }
+-- RM 6.4.1(13)
+-- RM 9.5.1(3)
+-- RM 9.5.3(8)
+with Ada.Text_IO; use Ada.Text_IO;
+procedure RM_6_4_1_13 is
+ type intp is access all integer;
+ i: aliased integer := 3;
+ x1: intp;
+
+ procedure p1(x: out intp) is
+ begin
+ null;
+ end;
+
+ protected type T1 is
+ entry e1 (x: out intp);
+ procedure p2(x: out intp);
+ end T1;
+
+ protected body T1 is
+
+ entry e1 (x: out intp) when true is
+ begin
+ null;
+ end e1;
+
+ procedure p2(x: out intp) is
+ begin
+ null;
+ end;
+
+ end T1;
+
+ task type T2 is
+ entry e1 (x: out intp);
+ end T2;
+
+ task body T2 is
+ begin
+ loop
+ select
+ accept e1 (x: out intp) do
+ begin
+ null;
+ end;
+ end e1;
+ or
+ terminate;
+ end select;
+ end loop;
+ end T2;
+
+ pt: T1;
+
+ tt: T2;
+
+ procedure doit(x2: intp) is
+
+ procedure Check (S : String) is
+ begin
+ Put (" - " & S & ": ");
+ if X1 = X2 then
+ Put_Line ("PASSED");
+ else
+ Put_Line ("FAILED");
+ raise Program_Error;
+ end if;
+ x1 := x2;
+ end Check;
+
+ begin
+ x1 := x2;
+ p1(x1);
+ Check ("procedure call");
+ pt.p2(x1);
+ Check ("protected procedure call");
+ tt.e1(x1);
+ Check ("task entry call");
+ pt.e1(x1);
+ Check ("protected entry call");
+ end;
+
+begin
+ Put_Line ("Called with null");
+ doit(null);
+ Put_Line ("Called with non-null");
+ doit(i'access);
+end RM_6_4_1_13;
--
1.5.3.6