Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cc/cc1220a.ada @ 111:04ced10e8804
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 -- CC1220A.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 -- CHECK THAT A GENERIC UNIT CAN REFER TO AN IMPLICITLY | |
27 -- DECLARED PREDEFINED OPERATOR. | |
28 | |
29 -- HISTORY: | |
30 -- DAT 08/20/81 CREATED ORIGINAL TEST. | |
31 -- SPS 05/03/82 | |
32 -- BCB 08/04/88 MODIFIED HEADER FORMAT AND ADDED CHECKS FOR OTHER | |
33 -- OPERATIONS OF A DISCRETE TYPE. | |
34 -- RJW 03/27/90 REVISED TEST TO CHECK FOR A GENERIC FORMAL | |
35 -- DISCRETE TYPE. | |
36 -- CJJ 10/14/90 ADDED CHECKS FOR RELATIONAL OPERATOR (<, <=, >, >=); | |
37 -- MADE FAILED MESSAGES IN PROCEDURE BODY MORE SPECIFIC. | |
38 | |
39 WITH REPORT; USE REPORT; | |
40 WITH SYSTEM; USE SYSTEM; | |
41 | |
42 PROCEDURE CC1220A IS | |
43 | |
44 BEGIN | |
45 TEST ("CC1220A", "GENERIC UNIT CAN REFER TO IMPLICITLY " & | |
46 "DECLARED OPERATORS"); | |
47 | |
48 | |
49 DECLARE | |
50 | |
51 GENERIC | |
52 TYPE T IS (<>); | |
53 STR : STRING; | |
54 P1 : T := T'FIRST; | |
55 P2 : T := T(T'SUCC (P1)); | |
56 P3 : T := T'(T'PRED (P2)); | |
57 P4 : INTEGER := IDENT_INT(T'WIDTH); | |
58 P5 : BOOLEAN := (P1 < P2) AND (P2 > P3); | |
59 P6: BOOLEAN := (P1 <= P3) AND (P2 >= P1); | |
60 P7 : BOOLEAN := (P3 = P1); | |
61 P8 : T := T'BASE'FIRST; | |
62 P10 : T := T'LAST; | |
63 P11 : INTEGER := T'SIZE; | |
64 P12 : ADDRESS := P10'ADDRESS; | |
65 P13 : INTEGER := T'WIDTH; | |
66 P14 : INTEGER := T'POS(T'LAST); | |
67 P15 : T := T'VAL(1); | |
68 P16 : INTEGER := T'POS(P15); | |
69 P17 : STRING := T'IMAGE(T'BASE'LAST); | |
70 P18 : T := T'VALUE(P17); | |
71 P19 : BOOLEAN := (P15 IN T); | |
72 WITH FUNCTION IDENT (X : T) RETURN T; | |
73 PACKAGE PKG IS | |
74 ARR : ARRAY (1 .. 3) OF T := (P1,P2,P3); | |
75 B1 : BOOLEAN := P7 AND P19; | |
76 B2 : BOOLEAN := P5 AND P6; | |
77 END PKG; | |
78 | |
79 PACKAGE BODY PKG IS | |
80 BEGIN | |
81 IF P1 /= T(T'FIRST) THEN | |
82 FAILED ("IMPROPER VALUE FOR 'FIRST - " & STR); | |
83 END IF; | |
84 | |
85 IF T'SUCC (P1) /= IDENT (P2) OR | |
86 T'PRED (P2) /= IDENT (P1) THEN | |
87 FAILED ("IMPROPER VALUE FOR 'SUCC, PRED - " & STR); | |
88 END IF; | |
89 | |
90 IF P10 /= T(T'LAST) THEN | |
91 FAILED ("IMPROPER VALUE FOR 'LAST - " & STR); | |
92 END IF; | |
93 | |
94 IF NOT EQUAL(P11,T'SIZE) THEN | |
95 FAILED ("IMPROPER VALUE FOR 'SIZE - " & STR); | |
96 END IF; | |
97 | |
98 IF NOT EQUAL(P13,T'WIDTH) THEN | |
99 FAILED ("IMPROPER VALUE FOR 'WIDTH - " & STR); | |
100 END IF; | |
101 | |
102 IF NOT EQUAL (P16, T'POS (P15)) OR | |
103 T'VAL (P16) /= T(IDENT (P15)) THEN | |
104 FAILED ("IMPROPER VALUE FOR 'POS, 'VAL - " & STR); | |
105 END IF; | |
106 | |
107 IF T'VALUE (P17) /= T'BASE'LAST OR | |
108 T'IMAGE (P18) /= T'IMAGE (T'BASE'LAST) THEN | |
109 FAILED ("IMPROPER VALUE FOR 'VALUE, 'IMAGE - " & | |
110 STR); | |
111 END IF; | |
112 END PKG; | |
113 | |
114 BEGIN | |
115 DECLARE | |
116 TYPE CHAR IS ('A', 'B', 'C', 'D', 'E'); | |
117 | |
118 FUNCTION IDENT (C : CHAR) RETURN CHAR IS | |
119 BEGIN | |
120 RETURN CHAR'VAL (IDENT_INT (CHAR'POS (C))); | |
121 END IDENT; | |
122 | |
123 PACKAGE N_CHAR IS NEW PKG (T => CHAR, STR => "CHAR", | |
124 IDENT => IDENT); | |
125 BEGIN | |
126 IF N_CHAR.ARR (1) /= IDENT ('A') OR | |
127 N_CHAR.ARR (2) /= IDENT ('B') OR | |
128 N_CHAR.ARR (3) /= 'A' OR | |
129 N_CHAR.B1 /= TRUE OR | |
130 N_CHAR.B2 /= TRUE THEN | |
131 FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & | |
132 " IN INSTANTIATION OF N_CHAR."); | |
133 END IF; | |
134 END; | |
135 | |
136 DECLARE | |
137 TYPE ENUM IS (JOVIAL, ADA, FORTRAN, BASIC); | |
138 | |
139 FUNCTION IDENT (C : ENUM) RETURN ENUM IS | |
140 BEGIN | |
141 RETURN ENUM'VAL (IDENT_INT (ENUM'POS (C))); | |
142 END IDENT; | |
143 | |
144 PACKAGE N_ENUM IS NEW PKG (T => ENUM, STR => "ENUM", | |
145 IDENT => IDENT); | |
146 | |
147 BEGIN | |
148 IF N_ENUM.ARR (1) /= IDENT (JOVIAL) OR | |
149 N_ENUM.ARR (2) /= IDENT (ADA) OR | |
150 N_ENUM.ARR (3) /= JOVIAL OR | |
151 N_ENUM.B1 /= TRUE OR | |
152 N_ENUM.B2 /= TRUE THEN | |
153 FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & | |
154 " IN INSTANTIATION OF N_ENUM."); | |
155 END IF; | |
156 END; | |
157 | |
158 DECLARE | |
159 | |
160 PACKAGE N_INT IS NEW PKG (T => INTEGER, STR => "INTEGER", | |
161 IDENT => IDENT_INT); | |
162 BEGIN | |
163 IF N_INT.ARR (1) /= IDENT_INT (INTEGER'FIRST) OR | |
164 N_INT.ARR (2) /= IDENT_INT (INTEGER'FIRST + 1) OR | |
165 N_INT.ARR (3) /= INTEGER'FIRST OR | |
166 N_INT.B1 /= TRUE OR | |
167 N_INT.B2 /= TRUE THEN | |
168 FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & | |
169 " IN INSTANTIATION OF N_INT."); | |
170 END IF; | |
171 END; | |
172 END; | |
173 RESULT; | |
174 END CC1220A; |