1-- C52011B.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 DISCRIMINANT 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 7/06/81
47--  RM 6/17/82
48-- RLB 6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION.
49
50WITH REPORT;
51PROCEDURE C52011B IS
52
53     USE REPORT;
54
55     TYPE REC(DISC : INTEGER := -1 ) IS
56          RECORD
57               NULL;
58          END RECORD;
59
60     TYPE REC_NAME IS ACCESS REC;
61     SUBTYPE S1 IS REC_NAME(IDENT_INT(5));
62     SUBTYPE S2 IS REC_NAME(IDENT_INT(3));
63
64     W : REC_NAME := NULL;                    -- E.
65     X1,X2 : S1 := NULL;                      -- E.
66     Y1,Y2 : S2 := NULL;                      -- E.
67
68     W_NONNULL  : REC_NAME := NEW REC(7) ;
69     X1_NONNULL : S1       := NEW REC(IDENT_INT(5));
70     Y1_NONNULL : S2       := NEW REC(IDENT_INT(3));
71
72     TOO_EARLY : BOOLEAN := TRUE;
73
74BEGIN
75
76     TEST ("C52011B", "DISCRIMINANT CONSTRAINTS ON ACCESS SUBTYPE " &
77                      "OBJECTS MUST BE SATISFIED FOR ASSIGNMENT");
78
79     BEGIN
80
81          IF EQUAL(3,3) THEN
82               W_NONNULL := X1;               -- A.
83          END IF;
84          IF W_NONNULL /= X1 THEN
85               FAILED ("ASSIGNMENT FAILED - 1");
86          END IF;
87
88          IF EQUAL(3,3) THEN
89               W := Y1;                       -- A.
90          END IF;
91          IF W /= Y1 THEN
92               FAILED ("ASSIGNMENT FAILED - 2");
93          END IF;
94
95          IF EQUAL(3,3) THEN
96               X1_NONNULL := Y1;              -- A.
97          END IF;
98          IF X1_NONNULL /= Y1 THEN
99               FAILED ("ASSIGNMENT FAILED - 3");
100          END IF;
101
102          IF EQUAL(3,3) THEN
103               Y1_NONNULL := Y2;              -- A.
104          END IF;
105          IF Y1_NONNULL /= Y2 THEN
106               FAILED ("ASSIGNMENT FAILED - 4");
107          END IF;
108
109          X1 := NEW REC(IDENT_INT(5));
110          IF EQUAL(3,3) THEN
111               X2 := X1;                      -- B.
112          END IF;
113          IF X1 /= X2 THEN
114               FAILED ("ASSIGNMENT FAILED - 5");
115          END IF;
116
117          IF EQUAL(3,3) THEN
118               W := X1;                       -- B.
119          END IF;
120          IF W /= X1 THEN
121               FAILED ("ASSIGNMENT FAILED - 6");
122          END IF;
123
124          BEGIN
125               Y1 := X1;                      -- C.
126               IF Y1.DISC /= REPORT.IDENT_INT(3) THEN
127                  FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
128                     "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
129                     "AND CONSTRAINT IS CHANGED");
130               ELSE
131                  FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
132                     "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
133                     "AND CONSTRAINT IS NOT CHANGED");
134               END IF;
135          EXCEPTION
136
137               WHEN CONSTRAINT_ERROR => NULL;
138
139               WHEN OTHERS =>
140                    FAILED ("WRONG EXCEPTION - 1");
141
142          END;
143
144          W := NEW REC(IDENT_INT(3));
145
146          BEGIN
147               X1 := W;                            -- D.
148               IF X1.DISC /= REPORT.IDENT_INT(5) THEN
149                  FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
150                          "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
151                          "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
152                          "AND CONSTRAINT IS CHANGED");
153               ELSE
154                  FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
155                          "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
156                          "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
157                          "AND CONSTRAINT IS NOT CHANGED");
158               END IF;
159          EXCEPTION
160
161               WHEN CONSTRAINT_ERROR =>
162                    NULL ;
163
164               WHEN OTHERS =>
165                    FAILED ("WRONG EXCEPTION - 2");
166
167          END;
168
169     EXCEPTION
170
171          WHEN OTHERS =>
172               FAILED ("EXCEPTION RAISED");
173
174     END;
175
176
177     RESULT;
178
179
180END C52011B;
181