OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c48009b.ada] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn 
-- C48009B.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 AN UNCONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN
27 
-- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN
28 
-- X:
29 
--   1) DOES NOT SATISFY THE RANGE CONSTRAINT FOR THE CORRESPONDING
30 
--      DISCRIMINANT OF T.
31 
--   2) DOES NOT EQUAL THE DISCRIMINANT VALUE SPECIFIED IN THE
32 
--      DECLARATION OF THE ALLOCATOR'S BASE TYPE.
33 
--   3) A DISCRIMINANT VALUE IS COMPATIBLE WITH A DISCRIMINANT'S SUBTYPE
34 
--      BUT DOES NOT PROVIDE A COMPATIBLE INDEX OR DISCRIMINANT
35 
--      CONSTRAINT FOR A SUBCOMPONENT DEPENDENT ON THE DISCRIMINANT.
36 
 
37 
-- RM  01/08/80
38 
-- NL  10/13/81
39 
-- SPS 10/26/82
40 
-- JBG 03/02/83
41 
-- EG  07/05/84
42 
 
43 
WITH REPORT;
44 
 
45 
PROCEDURE  C48009B  IS
46 
 
47 
     USE REPORT;
48 
 
49 
BEGIN
50 
 
51 
     TEST( "C48009B" , "FOR ALLOCATORS OF THE FORM 'NEW T '(X)', " &
52 
                       "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
53 
                       "APPROPRIATE - UNCONSTRAINED RECORD AND " &
54 
                       "PRIVATE TYPES");
55 
 
56 
     DECLARE
57 
 
58 
          SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7);
59 
          SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10);
60 
          SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9);
61 
 
62 
          TYPE REC (A : I2_9) IS
63 
               RECORD
64 
                    NULL;
65 
               END RECORD;
66 
 
67 
          TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER;
68 
 
69 
          TYPE T_REC (C : I1_10) IS
70 
               RECORD
71 
                    D : REC(C);
72 
               END RECORD;
73 
 
74 
          TYPE T_ARR (C : I1_10) IS
75 
               RECORD
76 
                    D : ARR(2..C);
77 
                    E : ARR(C..9);
78 
               END RECORD;
79 
 
80 
          TYPE T_REC_REC (A : I1_10) IS
81 
               RECORD
82 
                    B : T_REC(A);
83 
               END RECORD;
84 
 
85 
          TYPE T_REC_ARR (A : I1_10) IS
86 
               RECORD
87 
                    B : T_ARR(A);
88 
               END RECORD;
89 
 
90 
          TYPE  TB (  A : I1_7 )  IS
91 
               RECORD
92 
                    R : INTEGER;
93 
               END RECORD;
94 
 
95 
          TYPE A_T_REC_REC IS ACCESS T_REC_REC;
96 
          TYPE A_T_REC_ARR IS ACCESS T_REC_ARR;
97 
          TYPE ATB IS ACCESS TB;
98 
          TYPE ACTB IS ACCESS TB(3);
99 
 
100 
          VA_T_REC_REC : A_T_REC_REC;
101 
          VA_T_REC_ARR : A_T_REC_ARR;
102 
          VB  : ATB;
103 
          VCB : ACTB;
104 
 
105 
          PACKAGE  P  IS
106 
               TYPE  PRIV( A : I1_10 )  IS PRIVATE;
107 
               CONS_PRIV : CONSTANT PRIV;
108 
          PRIVATE
109 
               TYPE  PRIV( A : I1_10 )  IS
110 
                    RECORD
111 
                         R : INTEGER;
112 
                    END RECORD;
113 
               CONS_PRIV : CONSTANT PRIV := (2, 3);
114 
          END P;
115 
 
116 
          USE P;
117 
 
118 
          TYPE  A_PRIV  IS  ACCESS P.PRIV;
119 
          TYPE  A_CPRIV IS  ACCESS P.PRIV (3);
120 
 
121 
          VP  : A_PRIV;
122 
          VCP : A_CPRIV;
123 
 
124 
          FUNCTION ALLOC1(X : P.PRIV) RETURN A_CPRIV IS
125 
          BEGIN
126 
               IF EQUAL(1, 1) THEN
127 
                    RETURN NEW P.PRIV'(X);
128 
               ELSE
129 
                    RETURN NULL;
130 
               END IF;
131 
          END ALLOC1;
132 
          FUNCTION ALLOC2(X : TB) RETURN ACTB IS
133 
          BEGIN
134 
               IF EQUAL(1, 1) THEN
135 
                    RETURN NEW TB'(X);
136 
               ELSE
137 
                    RETURN NULL;
138 
               END IF;
139 
          END ALLOC2;
140 
 
141 
     BEGIN
142 
 
143 
          BEGIN     -- B1
144 
               VB  :=  NEW TB'(A => IDENT_INT(0), R => 1);
145 
               FAILED ("NO EXCEPTION RAISED - CASE 1A");
146 
          EXCEPTION
147 
               WHEN  CONSTRAINT_ERROR  =>  NULL;
148 
               WHEN  OTHERS            =>
149 
                    FAILED( "WRONG EXCEPTION RAISED - CASE 1A" );
150 
          END;
151 
 
152 
          BEGIN
153 
               VB  :=  NEW TB'(A => 8, R => 1);
154 
               FAILED ("NO EXCEPTION RAISED - CASE 1B");
155 
          EXCEPTION
156 
               WHEN  CONSTRAINT_ERROR  =>  NULL;
157 
               WHEN  OTHERS            =>
158 
                    FAILED( "WRONG EXCEPTION RAISED - CASE 1B");
159 
          END; -- B1
160 
 
161 
          BEGIN     -- B2
162 
               VCB := NEW TB'(2, 3);
163 
               FAILED ("NO EXCEPTION RAISED - CASE 2A");
164 
          EXCEPTION
165 
               WHEN CONSTRAINT_ERROR => NULL;
166 
               WHEN OTHERS =>
167 
                    FAILED ("WRONG EXCEPTION RAISED - CASE 2A");
168 
          END;
169 
 
170 
          BEGIN
171 
               IF ALLOC2((IDENT_INT(4), 3)) = NULL THEN
172 
                    FAILED ("IMPOSSIBLE - CASE 2B");
173 
               END IF;
174 
               FAILED ("NO EXCEPTION RAISED - CASE 2B");
175 
          EXCEPTION
176 
               WHEN CONSTRAINT_ERROR => NULL;
177 
               WHEN OTHERS =>
178 
                    FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
179 
          END;
180 
 
181 
          BEGIN
182 
 
183 
               IF ALLOC1(CONS_PRIV) = NULL THEN
184 
                    FAILED ("IMPOSSIBLE - CASE 2C");
185 
               END IF;
186 
               FAILED ("NO EXCEPTION RAISED - CASE 2C");
187 
 
188 
          EXCEPTION
189 
 
190 
               WHEN CONSTRAINT_ERROR => NULL;
191 
               WHEN OTHERS =>
192 
                    FAILED ("WRONG EXCEPTION RAISED - CASE 2C");
193 
 
194 
          END; -- B2
195 
 
196 
          BEGIN     -- B3
197 
 
198 
               VA_T_REC_REC := NEW T_REC_REC'(1, (1, (A => 1)));
199 
               FAILED ("NO EXCEPTION RAISED - CASE 3A");
200 
 
201 
          EXCEPTION
202 
 
203 
               WHEN CONSTRAINT_ERROR => NULL;
204 
               WHEN OTHERS =>
205 
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
206 
 
207 
          END;
208 
 
209 
          BEGIN
210 
 
211 
               VA_T_REC_REC := NEW T_REC_REC'(10,
212 
                                             (10, (A => 10)));
213 
               FAILED ("NO EXCEPTION RAISED - CASE 3B");
214 
 
215 
          EXCEPTION
216 
 
217 
               WHEN CONSTRAINT_ERROR => NULL;
218 
               WHEN OTHERS =>
219 
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
220 
 
221 
          END;
222 
 
223 
          BEGIN
224 
 
225 
               VA_T_REC_ARR := NEW T_REC_ARR'(1, (1, (OTHERS => 1),
226 
                                                     (OTHERS => 2)));
227 
               FAILED ("NO EXCEPTION RAISED - CASE 3C");
228 
 
229 
          EXCEPTION
230 
 
231 
               WHEN CONSTRAINT_ERROR => NULL;
232 
               WHEN OTHERS =>
233 
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
234 
 
235 
          END;
236 
 
237 
          BEGIN
238 
 
239 
               VA_T_REC_ARR := NEW T_REC_ARR'(10, (10, (OTHERS => 1),
240 
                                                       (OTHERS => 2)));
241 
               FAILED ("NO EXCEPTION RAISED - CASE 3D");
242 
 
243 
          EXCEPTION
244 
 
245 
               WHEN CONSTRAINT_ERROR => NULL;
246 
               WHEN OTHERS =>
247 
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
248 
 
249 
          END;
250 
 
251 
     END;
252 
 
253 
     RESULT;
254 
 
255 
END C48009B;

powered by: WebSVN 2.1.0

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