From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001
From: upstream source tree <ports@midipix.org>
Date: Sun, 15 Mar 2015 20:14:05 -0400
Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified
 gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream
 tarball.

downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.

if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
---
 gcc/testsuite/ada/acats/tests/c3/c380001.a | 128 +++++++++++++++++++++++++++++
 1 file changed, 128 insertions(+)
 create mode 100644 gcc/testsuite/ada/acats/tests/c3/c380001.a

(limited to 'gcc/testsuite/ada/acats/tests/c3/c380001.a')

diff --git a/gcc/testsuite/ada/acats/tests/c3/c380001.a b/gcc/testsuite/ada/acats/tests/c3/c380001.a
new file mode 100644
index 000000000..0ebe4d31c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c3/c380001.a
@@ -0,0 +1,128 @@
+-- C380001.A
+--
+--                             Grant of Unlimited Rights
+--
+--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
+--     rights in the software and documentation contained herein. Unlimited
+--     rights are the same as those granted by the U.S. Government for older
+--     parts of the Ada Conformity Assessment Test Suite, and are defined
+--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
+--     intends to confer upon all recipients unlimited rights equal to those
+--     held by the ACAA. These rights include rights to use, duplicate,
+--     release or disclose the released technical data and computer software
+--     in whole or in part, in any manner and for any purpose whatsoever, and
+--     to have or permit others to do so.
+--
+--                                    DISCLAIMER
+--
+--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+--     DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
+--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
+--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+--     PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+--
+-- OBJECTIVE:
+--    Check that checks are made properly when a per-object expression contains
+--    an attribute whose prefix denotes the current instance of the type.
+--    (Defect Report 8652/0002, as reflected in Technical Corrigendum 1,
+--    RM95 3.8(18/1)).
+--
+-- CHANGE HISTORY:
+--     9 FEB 2001   PHL   Initial version.
+--    29 JUN 2002   RLB   Readied for release.
+--
+--!
+with Ada.Exceptions;
+use Ada.Exceptions;
+with Report;
+use Report;
+procedure C380001 is
+
+    type Negative is range Integer'First .. -1;
+
+    type R1 is
+        record
+            C : Negative := Negative (Ident_Int (R1'Size));
+        end record;
+
+
+    type R2;
+
+    type R3 (D1 : access R2; D2 : Natural) is limited null record;
+
+    type R2 is limited
+        record
+            C : R3 (R2'Access, Ident_Int (-1));
+        end record;
+
+begin
+    Test ("C380001", "Check that checks are made properly when a " &
+                        "per-object expression contains an attribute whose " &
+                        "prefix denotes the current instance of the type");
+    begin
+        declare
+            X : R1;
+        begin
+            Failed
+               ("No exception raised when evaluating a per-object expression " &
+                "containing an attribute - 1");
+        end;
+    exception
+        when Constraint_Error =>
+            null;
+        when E: others =>
+            Failed ("Exception " & Exception_Name (E) &
+                    " raised - " & Exception_Information (E) & " - 1");
+    end;
+
+    declare
+        type A is access R1;
+        X : A;
+    begin
+        X := new R1;
+        Failed ("No exception raised when evaluating a per-object expression " &
+                "containing an attribute - 2");
+    exception
+        when Constraint_Error =>
+            null;
+        when E: others =>
+            Failed ("Exception " & Exception_Name (E) &
+                    " raised - " & Exception_Information (E) & " - 2");
+    end;
+
+    begin
+        declare
+            X : R2;
+        begin
+            Failed
+               ("No exception raised when elaborating a per-object constraint " &
+                "containing an attribute - 3");
+        end;
+    exception
+        when Constraint_Error =>
+            null;
+        when E: others =>
+            Failed ("Exception " & Exception_Name (E) &
+                    " raised - " & Exception_Information (E) & " - 3");
+    end;
+
+    declare
+        type A is access R2;
+        X : A;
+    begin
+        X := new R2;
+        Failed
+           ("No exception raised when evaluating a per-object constraint " &
+            "containing an attribute - 4");
+    exception
+        when Constraint_Error =>
+            null;
+        when E: others =>
+            Failed ("Exception " & Exception_Name (E) &
+                    " raised - " & Exception_Information (E) & " - 4");
+    end;
+
+    Result;
+end C380001;
-- 
cgit v1.2.3