1-- C380001.A
2--
3--                             Grant of Unlimited Rights
4--
5--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
6--     rights in the software and documentation contained herein. Unlimited
7--     rights are the same as those granted by the U.S. Government for older
8--     parts of the Ada Conformity Assessment Test Suite, and are defined
9--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10--     intends to confer upon all recipients unlimited rights equal to those
11--     held by the ACAA. These rights include rights to use, duplicate,
12--     release or disclose the released technical data and computer software
13--     in whole or in part, in any manner and for any purpose whatsoever, and
14--     to have or permit others to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25--
26-- OBJECTIVE:
27--    Check that checks are made properly when a per-object expression contains
28--    an attribute whose prefix denotes the current instance of the type.
29--    (Defect Report 8652/0002, as reflected in Technical Corrigendum 1,
30--    RM95 3.8(18/1)).
31--
32-- CHANGE HISTORY:
33--     9 FEB 2001   PHL   Initial version.
34--    29 JUN 2002   RLB   Readied for release.
35--
36--!
37with Ada.Exceptions;
38use Ada.Exceptions;
39with Report;
40use Report;
41procedure C380001 is
42
43    type Negative is range Integer'First .. -1;
44
45    type R1 is
46        record
47            C : Negative := Negative (Ident_Int (R1'Size));
48        end record;
49
50
51    type R2;
52
53    type R3 (D1 : access R2; D2 : Natural) is limited null record;
54
55    type R2 is limited
56        record
57            C : R3 (R2'Access, Ident_Int (-1));
58        end record;
59
60begin
61    Test ("C380001", "Check that checks are made properly when a " &
62                        "per-object expression contains an attribute whose " &
63                        "prefix denotes the current instance of the type");
64    begin
65        declare
66            X : R1;
67        begin
68            Failed
69               ("No exception raised when evaluating a per-object expression " &
70                "containing an attribute - 1");
71        end;
72    exception
73        when Constraint_Error =>
74            null;
75        when E: others =>
76            Failed ("Exception " & Exception_Name (E) &
77                    " raised - " & Exception_Information (E) & " - 1");
78    end;
79
80    declare
81        type A is access R1;
82        X : A;
83    begin
84        X := new R1;
85        Failed ("No exception raised when evaluating a per-object expression " &
86                "containing an attribute - 2");
87    exception
88        when Constraint_Error =>
89            null;
90        when E: others =>
91            Failed ("Exception " & Exception_Name (E) &
92                    " raised - " & Exception_Information (E) & " - 2");
93    end;
94
95    begin
96        declare
97            X : R2;
98        begin
99            Failed
100               ("No exception raised when elaborating a per-object constraint " &
101                "containing an attribute - 3");
102        end;
103    exception
104        when Constraint_Error =>
105            null;
106        when E: others =>
107            Failed ("Exception " & Exception_Name (E) &
108                    " raised - " & Exception_Information (E) & " - 3");
109    end;
110
111    declare
112        type A is access R2;
113        X : A;
114    begin
115        X := new R2;
116        Failed
117           ("No exception raised when evaluating a per-object constraint " &
118            "containing an attribute - 4");
119    exception
120        when Constraint_Error =>
121            null;
122        when E: others =>
123            Failed ("Exception " & Exception_Name (E) &
124                    " raised - " & Exception_Information (E) & " - 4");
125    end;
126
127    Result;
128end C380001;
129