Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c34005c.ada @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- C34005C.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 -- OBJECTIVE:
26 -- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
27 -- NON-LIMITED, NON-DISCRETE TYPE:
28 -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
29 -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
30 -- CONSTRAINED.
31 -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
32 -- IMPOSED ON THE DERIVED SUBTYPE.
33
34 -- HISTORY:
35 -- JRK 9/10/86 CREATED ORIGINAL TEST.
36
37 WITH REPORT; USE REPORT;
38
39 PROCEDURE C34005C IS
40
41 SUBTYPE COMPONENT IS FLOAT;
42
43 PACKAGE PKG IS
44
45 FIRST : CONSTANT := 0;
46 LAST : CONSTANT := 100;
47
48 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
49
50 TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
51
52 FUNCTION CREATE ( F, L : INDEX;
53 C : COMPONENT;
54 DUMMY : PARENT -- TO RESOLVE OVERLOADING.
55 ) RETURN PARENT;
56
57 END PKG;
58
59 USE PKG;
60
61 TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
62
63 SUBTYPE SUBPARENT IS PARENT (5 .. 7);
64
65 TYPE S IS NEW SUBPARENT;
66
67 X : T := (OTHERS => 2.0);
68 Y : S := (OTHERS => 2.0);
69
70 PACKAGE BODY PKG IS
71
72 FUNCTION CREATE
73 ( F, L : INDEX;
74 C : COMPONENT;
75 DUMMY : PARENT
76 ) RETURN PARENT
77 IS
78 A : PARENT (F .. L);
79 B : COMPONENT := C;
80 BEGIN
81 FOR I IN F .. L LOOP
82 A (I) := B;
83 B := B + 1.0;
84 END LOOP;
85 RETURN A;
86 END CREATE;
87
88 END PKG;
89
90 BEGIN
91 TEST ("C34005C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
92 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
93 "WHEN THE DERIVED TYPE DEFINITION IS " &
94 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
95 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
96 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
97 "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
98 "TYPE IS A NON-LIMITED, NON-DISCRETE TYPE");
99
100 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
101
102 BEGIN
103 IF CREATE (2, 3, 4.0, X) /= (4.0, 5.0) OR
104 CREATE (2, 3, 4.0, Y) /= (4.0, 5.0) THEN
105 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
106 "SUBTYPE");
107 END IF;
108 EXCEPTION
109 WHEN CONSTRAINT_ERROR =>
110 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
111 WHEN OTHERS =>
112 FAILED ("CALL TO CREATE RAISED EXCEPTION");
113 END;
114
115 IF X & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) OR
116 Y & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) THEN
117 FAILED ("INCORRECT &");
118 END IF;
119
120 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
121
122 IF T'FIRST /= 5 OR T'LAST /= 7 OR
123 S'FIRST /= 5 OR S'LAST /= 7 THEN
124 FAILED ("INCORRECT 'FIRST OR 'LAST");
125 END IF;
126
127 BEGIN
128 X := (1.0, 2.0, 3.0);
129 Y := (1.0, 2.0, 3.0);
130 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
131 FAILED ("INCORRECT CONVERSION TO PARENT");
132 END IF;
133 EXCEPTION
134 WHEN OTHERS =>
135 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
136 END;
137
138 BEGIN
139 X := (1.0, 2.0);
140 FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (1.0, 2.0)");
141 IF X = (1.0, 2.0) THEN -- USE X.
142 COMMENT ("X ALTERED -- X := (1.0, 2.0)");
143 END IF;
144 EXCEPTION
145 WHEN CONSTRAINT_ERROR =>
146 NULL;
147 WHEN OTHERS =>
148 FAILED ("WRONG EXCEPTION RAISED -- X := (1.0, 2.0)");
149 END;
150
151 BEGIN
152 X := (1.0, 2.0, 3.0, 4.0);
153 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
154 "X := (1.0, 2.0, 3.0, 4.0)");
155 IF X = (1.0, 2.0, 3.0, 4.0) THEN -- USE X.
156 COMMENT ("X ALTERED -- X := (1.0, 2.0, 3.0, 4.0)");
157 END IF;
158 EXCEPTION
159 WHEN CONSTRAINT_ERROR =>
160 NULL;
161 WHEN OTHERS =>
162 FAILED ("WRONG EXCEPTION RAISED -- " &
163 "X := (1.0, 2.0, 3.0, 4.0)");
164 END;
165
166 BEGIN
167 Y := (1.0, 2.0);
168 FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (1.0, 2.0)");
169 IF Y = (1.0, 2.0) THEN -- USE Y.
170 COMMENT ("Y ALTERED -- Y := (1.0, 2.0)");
171 END IF;
172 EXCEPTION
173 WHEN CONSTRAINT_ERROR =>
174 NULL;
175 WHEN OTHERS =>
176 FAILED ("WRONG EXCEPTION RAISED -- Y := (1.0, 2.0)");
177 END;
178
179 BEGIN
180 Y := (1.0, 2.0, 3.0, 4.0);
181 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
182 "Y := (1.0, 2.0, 3.0, 4.0)");
183 IF Y = (1.0, 2.0, 3.0, 4.0) THEN -- USE Y.
184 COMMENT ("Y ALTERED -- Y := (1.0, 2.0, 3.0, 4.0)");
185 END IF;
186 EXCEPTION
187 WHEN CONSTRAINT_ERROR =>
188 NULL;
189 WHEN OTHERS =>
190 FAILED ("WRONG EXCEPTION RAISED -- " &
191 "Y := (1.0, 2.0, 3.0, 4.0)");
192 END;
193
194 RESULT;
195 END C34005C;