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

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@138389 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1900013..d79fd14 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2008-07-31  Arnaud Charlet  <charlet@adacore.com>
+
+       * gnat.dg/missing_acc_check.adb: New test.
+
 2008-07-31  Richard Guenther  <rguenther@suse.de>
 
        * gcc.dg/uninit-1-O0.c: New testcase.

diff --git a/gcc/testsuite/gnat.dg/missing_acc_check.adb b/gcc/testsuite/gnat.dg/missing_acc_check.adb
new file mode 100644 (file)
index 0000000..1c2d9cf
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/missing_acc_check.adb
@@ -0,0 +1,39 @@
+--  { dg-do run }
+
+procedure Missing_Acc_Check is
+   
+   Test_Failed : Exception;
+   
+   type Int_Access is access all Integer;
+   
+   Save : Int_Access := null;
+   
+   type Int_Rec is record
+      Int : aliased Integer;
+   end record;
+   
+   type Ltd_Rec (IR_Acc : access Int_Rec) is limited null record;
+   
+   function Pass_Rec (IR_Acc : access Int_Rec) return Int_Access is
+   begin
+      return IR_Acc.Int'Access;  -- Accessibility check here
+   end Pass_Rec;
+   
+   procedure Proc is
+      IR : aliased Int_Rec;
+      LR : Ltd_Rec (IR'Access);
+   begin
+      Save := Pass_Rec (LR.IR_Acc);  -- Must raise Program_Error;
+
+      if Save /= null then
+         raise Test_Failed;
+      end if;
+   
+   exception
+      when Program_Error =>
+         null;
+   end Proc;
+
+begin
+   Proc;
+end Missing_Acc_Check;