1-- C52011A.ADA
2
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7--     unlimited rights in the software and documentation contained herein.
8--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9--     this public release, the Government intends to confer upon all
10--     recipients unlimited rights  equal to those held by the Government.
11--     These rights include rights to use, duplicate, release or disclose the
12--     released technical data and computer software in whole or in part, in
13--     any manner and for any purpose whatsoever, and to have or permit others
14--     to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT 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-- CHECK INDEX CONSTRAINTS FOR ASSIGNMENT OF ACCESS SUBTYPES.
26-- SPECIFICALLY, CHECK THAT:
27
28-- A) ANY ACCESS TYPE VARIABLE AND CONSTRAINED SUBTYPE VARIABLES OF THAT
29-- TYPE MAY BE ASSIGNED TO ONE ANOTHER IF THE VALUE BEING ASSIGNED
30-- IS NULL.
31
32-- B) VARIABLES OF THE SAME CONSTRAINED ACCESS SUBTYPE MAY BE ASSIGNED
33-- TO ONE ANOTHER OR TO VARIABLES OF THE BASE ACCESS TYPE.
34
35-- C) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF NON-NULL OBJECTS
36-- BETWEEN DIFFERENTLY CONSTRAINED ACCESS SUBTYPES.
37
38-- D) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF A NON-NULL OBJECT
39-- OF A BASE ACCESS TYPE VARIABLE TO A VARIABLE OF ONE OF ITS
40-- CONSTRAINED SUBTYPES IF THE CONSTRAINTS ON THE OBJECT DIFFER
41-- FROM THOSE ON THE SUBTYPE.
42
43-- E) NULL CAN BE ASSIGNED TO BASE ACCESS TYPES AND ANY CONSTRAINED
44-- SUBTYPES OF THIS TYPE.
45
46-- ASL 6/29/81
47--  RM 6/17/82
48-- SPS 10/26/82
49-- RLB  6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION.
50
51WITH REPORT;
52PROCEDURE C52011A IS
53
54     USE REPORT;
55
56     TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER;
57     TYPE ARR_NAME IS ACCESS ARR;
58     SUBTYPE S1 IS ARR_NAME(IDENT_INT(1)..IDENT_INT(10));
59     SUBTYPE S2 IS ARR_NAME(IDENT_INT(3)..IDENT_INT(6));
60
61     W : ARR_NAME := NULL;                    -- E.
62     X1,X2 : S1 := NULL;                      -- E.
63     Y1,Y2 : S2 := NULL;                      -- E.
64
65     W_NONNULL  : ARR_NAME := NEW ARR'(3..5=>7) ;
66     X1_NONNULL : S1       := NEW ARR'(IDENT_INT(1)..IDENT_INT(10)=>7);
67     Y1_NONNULL : S2       := NEW ARR'(IDENT_INT(3)..IDENT_INT( 6)=>7);
68
69     TOO_EARLY : BOOLEAN := TRUE;
70
71BEGIN
72
73     TEST ("C52011A", "INDEX CONSTRAINTS ON ACCESS SUBTYPE OBJECTS " &
74                      "MUST BE SATISFIED FOR ASSIGNMENT");
75
76     BEGIN
77
78          IF EQUAL(3,3) THEN
79               W_NONNULL := X1;               -- A.
80          END IF;
81          IF W_NONNULL /= X1 THEN
82               FAILED ("ASSIGNMENT FAILED - 1");
83          END IF;
84
85          IF EQUAL(3,3) THEN
86               X1_NONNULL := X2;              -- A.
87          END IF;
88          IF X1_NONNULL /= X2 THEN
89               FAILED ("ASSIGNMENT FAILED - 2");
90          END IF;
91
92          IF EQUAL(3,3) THEN
93               X1_NONNULL := Y1;              -- A.
94          END IF;
95          IF X1 /= Y1 THEN
96               FAILED ("ASSIGNMENT FAILED - 3");
97          END IF;
98
99          X1 := NEW ARR'(1..IDENT_INT(10) => 5);
100          IF EQUAL(3,3) THEN
101               X2 := X1;                      -- B.
102          END IF;
103          IF X2 /= X1 THEN
104               FAILED ("ASSIGNMENT FAILED - 4");
105          END IF;
106
107          IF EQUAL(3,3) THEN
108               W := X1;                       -- B.
109          END IF;
110          IF W /= X1 THEN
111               FAILED ("ASSIGNMENT FAILED - 5");
112          END IF;
113
114          BEGIN
115               Y1 := X1;                      -- C.
116               IF Y1'FIRST /= REPORT.IDENT_INT(3) THEN
117                  FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
118                     "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
119                     "AND CONSTRAINT IS CHANGED");
120               ELSE
121                  FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
122                     "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
123                     "AND CONSTRAINT IS NOT CHANGED");
124               END IF;
125          EXCEPTION
126
127               WHEN CONSTRAINT_ERROR => NULL;
128
129               WHEN OTHERS =>
130                    FAILED ("WRONG EXCEPTION - 1");
131
132          END;
133
134          W := NEW ARR'(IDENT_INT(3)..IDENT_INT(6) => 3);
135
136          BEGIN
137               X1 := W;                            -- D.
138               IF X1'FIRST /= REPORT.IDENT_INT(1) THEN
139                  FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
140                          "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
141                          "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
142                          "AND CONSTRAINT IS CHANGED");
143               ELSE
144                  FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
145                          "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
146                          "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
147                          "AND CONSTRAINT IS NOT CHANGED");
148               END IF;
149          EXCEPTION
150
151               WHEN CONSTRAINT_ERROR =>
152                    NULL ;
153
154               WHEN OTHERS =>
155                    FAILED ("WRONG EXCEPTION - 2");
156
157          END;
158
159     EXCEPTION
160
161          WHEN OTHERS =>
162               FAILED ("EXCEPTION RAISED");
163
164     END;
165
166
167     RESULT;
168
169
170END C52011A;
171