* gnat.dg/invalid1.adb: New test.

From-SVN: r173831

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d0fa8a66149ee352e050e9afac9f3ae132b7956d..841c72d8d2952cdf4881dc49afc6eebb928f89b2 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2011-05-17  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gnat.dg/invalid1.adb: New test.
+
 2011-05-16  Uros Bizjak  <ubizjak@gmail.com>
 
        * gcc.target/i386/avx-vzeroupper-16.c: Update scan-assembler-times

diff --git a/gcc/testsuite/gnat.dg/invalid1.adb b/gcc/testsuite/gnat.dg/invalid1.adb
new file mode 100644 (file)
index 0000000..ff9b34a
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/invalid1.adb
@@ -0,0 +1,49 @@
+-- { dg-do run }
+-- { dg-options "-gnatws -gnatVa" }
+
+pragma Initialize_Scalars;
+
+procedure Invalid1 is
+
+  X : Boolean;
+  A : Boolean := False;
+
+  procedure Uninit (B : out Boolean) is
+  begin
+    if A then
+      B := True;
+      raise Program_Error;
+    end if;
+  end;
+
+begin
+
+  -- first, check that initialize_scalars is enabled
+  begin
+    if X then
+      A := False;
+    end if;
+    raise Program_Error;
+  exception
+    when Constraint_Error => null;
+  end;
+
+  -- second, check if copyback of an invalid value raises constraint error
+  begin
+    Uninit (A);
+    if A then
+      -- we expect constraint error in the 'if' above according to gnat ug:
+      -- ....
+      -- call.  Note that there is no specific option to test `out'
+      -- parameters, but any reference within the subprogram will be tested
+      -- in the usual manner, and if an invalid value is copied back, any
+      -- reference to it will be subject to validity checking.
+      -- ...
+      raise Program_Error;
+    end if;
+    raise Program_Error;
+  exception
+    when Constraint_Error => null;
+  end;
+
+end;