OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c48009e.ada] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C48009E.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
-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
26
-- IS RAISED IF T IS A CONSTRAINED ARRAY TYPE AND:
27
--   1) A NAMED NULL OR NON-NULL BOUND FOR X DOES NOT EQUAL THE
28
--      CORRESPONDING BOUND FOR T;
29
--   2) A BOUND OF T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED IN
30
--      THE DECLARATION OF THE ALLOCATOR'S BASE TYPE; 
31
--   3) A POSITIONAL AGGREGATE DOES NOT HAVE THE NUMBER OF COMPONENTS
32
--      REQUIRED BY T OR BY THE ALLOCATOR'S BASE TYPE. 
33
 
34
 -- RM  01/08/80
35
 -- NL  10/13/81
36
 -- SPS 10/26/82
37
 -- JBG 03/03/83
38
 -- EG  07/05/84
39
 -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
40
 -- KAS 11/14/95 CHANGED FAILURE AT SLIDING ASSIGNMENT TO COMMENT ON LANGUAGE
41
 -- KAS 11/30/95 REINSTRUMENTED CASES TO SELECT LANGUAGE SEMANTICS
42
 -- PWN 05/03/96 Enforced Ada 95 sliding rules
43
 -- PWN 10/24/96 Adjusted expected results for Ada 95.
44
 -- TMB 11/19/96 BACKED OUT CHANGE FOR SLIDING WITH ACCESS TYPES
45
 -- MRM 12/16/96 Removed problem code from withdrawn version of test, and
46
 --              implemented a dereference-index check to ensure Ada95
47
 --              required behavior.
48
 -- PWB.CTA 03/07/97 Restored checks from 1.11 in 2 cases where sliding does
49
 --                  not occur 
50
 WITH REPORT;
51
 
52
 PROCEDURE  C48009E  IS
53
 
54
      USE REPORT ;
55
 
56
 BEGIN
57
 
58
      TEST("C48009E","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
59
                     "THAT CONSTRAINT_ERROR IS RAISED WHEN "          &
60
                     "APPROPRIATE - CONSTRAINED ARRAY TYPES");
61
      DECLARE
62
 
63
           TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
64
           TYPE CA3_2 IS ARRAY(3 .. 2) OF INTEGER;
65
           TYPE SA1_3 IS ARRAY(1 .. 3) OF INTEGER;
66
           TYPE NA1_3 IS ARRAY(1 .. IDENT_INT(3)) OF INTEGER;
67
           SUBTYPE CA2_6 IS UA(2 .. 6);
68
           SUBTYPE CA1_4 IS UA(1 .. 4);
69
           SUBTYPE CA1_6 IS UA(1 .. 6);
70
           SUBTYPE CA4_1 IS UA(4 .. 1);
71
           SUBTYPE CA4_2 IS UA(4 .. 2);
72
 
73
           TYPE A_CA3_2 IS ACCESS CA3_2;
74
           TYPE A_SA1_3 IS ACCESS SA1_3;
75
           TYPE A_NA1_3 IS ACCESS NA1_3;
76
           TYPE A_CA1_5 IS ACCESS UA(1 .. 5);
77
           TYPE A_CA4_2 IS ACCESS CA4_2;
78
 
79
           V_A_CA3_2 : A_CA3_2;
80
           V_A_SA1_3 : A_SA1_3;
81
           V_A_NA1_3 : A_NA1_3;
82
           V_A_CA1_5 : A_CA1_5;
83
 
84
           FUNCTION ALLOC1(X : CA2_6) RETURN A_CA1_5 IS
85
           BEGIN
86
                IF EQUAL(1, 1) THEN
87
                     RETURN NEW CA2_6'(X);
88
                ELSE
89
                     RETURN NULL;
90
                END IF;
91
           END ALLOC1;
92
           FUNCTION ALLOC2(X : CA4_1) RETURN A_CA4_2 IS
93
           BEGIN
94
                IF EQUAL(1, 1) THEN
95
                     RETURN NEW CA4_1'(X);
96
                ELSE
97
                     RETURN NULL;
98
                END IF;
99
           END ALLOC2;
100
 
101
      BEGIN
102
 
103
          BEGIN
104
               V_A_CA3_2 := NEW CA3_2'(IDENT_INT(4) .. IDENT_INT(2)
105
                                       => 5);
106
               FAILED ("NO EXCEPTION RAISED - CASE 1A");
107
          EXCEPTION
108
               WHEN CONSTRAINT_ERROR =>
109
                    NULL;
110
               WHEN OTHERS =>
111
                    FAILED ("WRONG EXCEPTION RAISED - CASE 1A");
112
          END;
113
 
114
           BEGIN
115
                V_A_NA1_3 := NEW NA1_3'(1 .. IDENT_INT(2) => 4);
116
                FAILED ("NO EXCEPTION RAISED - CASE 1B");
117
           EXCEPTION
118
                WHEN CONSTRAINT_ERROR =>
119
                     NULL;
120
                WHEN OTHERS =>
121
                     FAILED ("WRONG EXCEPTION RAISED - CASE 1B");
122
           END;
123
 
124
           BEGIN
125
                -- note that ALLOC1 returns A_CA1_5, so both
126
                -- (1) and (5) are valid index references!
127
                IF ALLOC1((2 .. 6 => 2))(5) /= 2 THEN
128
                     FAILED ("Wrong Value Returned - CASE 2A");
129
                ELSIF ALLOC1((2 .. 6 => 3))(1) /= 3 THEN
130
                     FAILED ("Unlikely Index Case - CASE 2A");
131
                END IF;
132
           EXCEPTION
133
                WHEN OTHERS =>
134
                     FAILED ("EXCEPTION RAISED - CASE 2A");
135
           END;
136
 
137
           BEGIN
138
                IF ALLOC2((4 .. 1 => 3)) = NULL THEN
139
                     FAILED ("IMPOSSIBLE - CASE 2B");
140
                END IF;
141
                COMMENT ("ADA 95 SLIDING ASSIGNMENT");
142
           EXCEPTION
143
                WHEN CONSTRAINT_ERROR =>
144
                     FAILED ("ADA 83 NON-SLIDING ASSIGNMENT");
145
                WHEN OTHERS =>
146
                     FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
147
           END;
148
 
149
           BEGIN
150
                V_A_SA1_3 := NEW SA1_3'(1, 2);
151
                FAILED ("NO EXCEPTION RAISED - CASE 3A");
152
           EXCEPTION
153
                WHEN CONSTRAINT_ERROR =>
154
                     NULL;
155
                WHEN OTHERS =>
156
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
157
           END;
158
 
159
           BEGIN
160
                V_A_SA1_3 := NEW SA1_3'(3, 4, 5, 6);
161
                FAILED ("NO EXCEPTION RAISED - CASE 3B");
162
           EXCEPTION
163
                WHEN CONSTRAINT_ERROR =>
164
                     NULL;
165
                WHEN OTHERS =>
166
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
167
           END;
168
 
169
           BEGIN
170
                V_A_NA1_3 := NEW NA1_3'(1, 2);
171
                FAILED ("NO EXCEPTION RAISED - CASE 3C");
172
           EXCEPTION
173
                WHEN CONSTRAINT_ERROR =>
174
                     NULL;
175
                WHEN OTHERS =>
176
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
177
           END;
178
 
179
           BEGIN -- SATISFIES T BUT NOT BASE TYPE.
180
                V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4);
181
                FAILED ("NO EXCEPTION RAISED - CASE 3D");
182
           EXCEPTION
183
                WHEN CONSTRAINT_ERROR =>
184
                     NULL;
185
                WHEN OTHERS =>
186
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
187
           END;
188
 
189
           BEGIN -- SATISFIES T BUT NOT BASE TYPE.
190
                V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5, 6);
191
                FAILED ("NO EXCEPTION RAISED - CASE 3E");
192
           EXCEPTION
193
                WHEN CONSTRAINT_ERROR =>
194
                     NULL;
195
                WHEN OTHERS =>
196
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3E");
197
           END;
198
 
199
           BEGIN -- SATISFIES BASE TYPE BUT NOT T.
200
                V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4, 5);
201
                FAILED ("NO EXCEPTION RAISED - CASE 3F");
202
           EXCEPTION
203
                WHEN CONSTRAINT_ERROR =>
204
                     NULL;
205
                WHEN OTHERS =>
206
                     FAILED ("WRONG EXCEPTION RAISED - CASE 3F");
207
           END;
208
 
209
          BEGIN -- SATISFIES BASE TYPE BUT NOT T.
210
               V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5);
211
               FAILED ("NO EXCEPTION RAISED - CASE 3G");
212
          EXCEPTION
213
               WHEN CONSTRAINT_ERROR =>
214
                    NULL;
215
               WHEN OTHERS =>
216
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3G");
217
          END;
218
 
219
      END ;
220
 
221
      RESULT ;
222
 
223
 END C48009E ;
224
 

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.