1-- C47002C.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 THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS
26-- THE OPERANDS OF QUALIFIED EXPRESSIONS.
27-- THIS TEST IS FOR ARRAY, RECORD, AND ACCESS TYPES.
28
29-- RJW 7/23/86
30
31WITH REPORT; USE REPORT;
32PROCEDURE C47002C IS
33
34BEGIN
35
36     TEST( "C47002C", "CHECK THAT VALUES HAVING ARRAY, RECORD, AND " &
37                      "ACCESS TYPES CAN BE WRITTEN AS THE OPERANDS " &
38                      "OF QUALIFIED EXPRESSIONS" );
39
40     DECLARE -- ARRAY TYPES.
41
42          TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
43          SUBTYPE ARR1 IS ARR (1 .. 1);
44          SUBTYPE ARR5 IS ARR (1 .. 5);
45
46          TYPE NARR IS NEW ARR;
47          SUBTYPE NARR2 IS NARR (2 .. 2);
48
49          TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
50               OF INTEGER;
51          SUBTYPE TARR15 IS TARR (1 .. 1, 1 .. 5);
52          SUBTYPE TARR51 IS TARR (1 .. 5, 1 .. 1);
53
54          TYPE NTARR IS NEW TARR;
55          SUBTYPE NTARR26 IS NTARR (2 .. 6, 2 .. 6);
56
57          FUNCTION F (X : ARR) RETURN ARR IS
58          BEGIN
59               RETURN X;
60          END;
61
62          FUNCTION F (X : NARR) RETURN NARR IS
63          BEGIN
64               RETURN X;
65          END;
66
67          FUNCTION F (X : TARR) RETURN TARR IS
68          BEGIN
69               RETURN X;
70          END;
71
72          FUNCTION F (X : NTARR) RETURN NTARR IS
73          BEGIN
74               RETURN X;
75          END;
76
77     BEGIN
78          IF F (ARR1'(OTHERS => 0))'LAST /= 1 THEN
79               FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR1" );
80          END IF;
81
82          IF F (ARR5'(OTHERS => 0))'LAST /= 5 THEN
83               FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR5" );
84          END IF;
85
86          IF F (NARR2'(OTHERS => 0))'FIRST /= 2 OR
87             F (NARR2'(OTHERS => 0))'LAST /= 2 THEN
88               FAILED ( "INCORRECT RESULTS FOR SUBTYPE NARR2" );
89          END IF;
90
91          IF F (TARR15'(OTHERS => (OTHERS => 0)))'LAST /= 1 OR
92             F (TARR15'(OTHERS => (OTHERS => 0)))'LAST (2) /= 5 THEN
93               FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR15" );
94          END IF;
95
96          IF F (TARR51'(OTHERS => (OTHERS => 0)))'LAST /= 5 OR
97             F (TARR51'(OTHERS => (OTHERS => 0)))'LAST (2) /= 1 THEN
98               FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR51" );
99          END IF;
100
101          IF F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST /= 2 OR
102             F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST /= 6 OR
103             F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST (2) /= 2 OR
104             F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST (2) /= 6 THEN
105               FAILED ( "INCORRECT RESULTS FOR SUBTYPE NTARR26" );
106          END IF;
107
108     END;
109
110     DECLARE -- RECORD TYPES.
111
112          TYPE GENDER IS (MALE, FEMALE, NEUTER);
113
114          TYPE MAN IS
115               RECORD
116                    AGE : POSITIVE;
117               END RECORD;
118
119          TYPE WOMAN IS
120               RECORD
121                    AGE : POSITIVE;
122               END RECORD;
123
124          TYPE ANDROID IS NEW MAN;
125
126          FUNCTION F (X: WOMAN) RETURN GENDER IS
127          BEGIN
128               RETURN FEMALE;
129          END F;
130
131          FUNCTION F (X: MAN) RETURN GENDER IS
132          BEGIN
133               RETURN MALE;
134          END F;
135
136          FUNCTION F (X : ANDROID) RETURN GENDER IS
137          BEGIN
138               RETURN NEUTER;
139          END F;
140
141     BEGIN
142          IF F (MAN'(AGE => 23)) /= MALE THEN
143               FAILED ( "INCORRECT RESULTS FOR SUBTYPE MAN" );
144          END IF;
145
146          IF F (WOMAN'(AGE => 38)) /= FEMALE THEN
147               FAILED ( "INCORRECT RESULTS FOR SUBTYPE WOMAN" );
148          END IF;
149
150          IF F (ANDROID'(AGE => 2001)) /= NEUTER THEN
151               FAILED ( "INCORRECT RESULTS FOR TYPE ANDRIOD" );
152          END IF;
153     END;
154
155     DECLARE -- ACCESS TYPES.
156
157          TYPE CODE IS (OLD, BRANDNEW, WRECK);
158
159          TYPE CAR (D : CODE) IS
160               RECORD
161                    NULL;
162               END RECORD;
163
164          TYPE KEY IS ACCESS CAR;
165
166          TYPE KEY_OLD IS ACCESS CAR (OLD);
167          KO : KEY_OLD := NEW CAR'(D => OLD);
168
169          TYPE KEY_WRECK IS ACCESS CAR (WRECK);
170
171          TYPE KEY_CARD IS NEW KEY;
172          KC : KEY_CARD := NEW CAR'(D => BRANDNEW);
173
174          FUNCTION F (X : KEY_OLD) RETURN CODE IS
175          BEGIN
176               RETURN OLD;
177          END F;
178
179          FUNCTION F (X : KEY_WRECK) RETURN CODE IS
180          BEGIN
181               RETURN WRECK;
182          END F;
183
184          FUNCTION F (X : KEY_CARD) RETURN CODE IS
185          BEGIN
186               RETURN BRANDNEW;
187          END F;
188     BEGIN
189          IF KEY_OLD'(KO) /= KO THEN
190               FAILED ( "INCORRECT RESULTS FOR TYPE KEY_OLD - 1" );
191          END IF;
192
193          IF KEY_CARD'(KC) /= KC THEN
194               FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 1" );
195          END IF;
196
197
198          IF F (KEY_OLD'(NULL)) /= OLD THEN
199               FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_OLD - 2" );
200          END IF;
201
202          IF F (KEY_WRECK'(NULL)) /= WRECK THEN
203               FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_WRECK" );
204          END IF;
205
206          IF F (KEY_CARD'(NULL)) /= BRANDNEW THEN
207               FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 2" );
208          END IF;
209     END;
210
211     RESULT;
212END C47002C;
213