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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c6/] [c64106a.ada] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- C64106A.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 UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY
26
--   FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS.
27
--   SUBTESTS ARE:
28
--        (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS.
29
--        (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS.
30
--        (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS.
31
--        (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS.
32
 
33
-- DAS  1/15/81
34
-- JBG  5/16/83
35
-- CPP  5/22/84
36
 
37
WITH REPORT;
38
PROCEDURE C64106A IS
39
 
40
     USE REPORT;
41
 
42
BEGIN
43
     TEST ("C64106A", "CHECK USE OF ACTUAL CONSTRAINTS BY " &
44
                      "UNCONSTRAINED FORMAL PARAMETERS");
45
 
46
     DECLARE  -- (A)
47
 
48
          PACKAGE PKG IS
49
 
50
              SUBTYPE INT IS INTEGER RANGE 0..100;
51
 
52
              TYPE RECTYPE (CONSTRAINT : INT := 80) IS
53
                    RECORD
54
                         INTFIELD  : INTEGER;
55
                         STRFIELD  : STRING (1..CONSTRAINT);
56
                    END RECORD;
57
 
58
               REC1  : RECTYPE   := (10,10,"0123456789");
59
               REC2  : RECTYPE   := (17,7,"C64106A..........");
60
               REC3  : RECTYPE   := (1,1,"A");
61
               REC4  : RECTYPE;  -- 80
62
 
63
               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
64
                                       REC2 : OUT RECTYPE;
65
                                       REC3 : IN OUT RECTYPE);
66
 
67
               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
68
          END PKG;
69
 
70
          PACKAGE BODY PKG IS
71
 
72
               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
73
                                       REC2 : OUT RECTYPE;
74
                                       REC3 : IN OUT RECTYPE) IS
75
               BEGIN
76
                    IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
77
                         FAILED ("RECORD TYPE IN PARAMETER DID " &
78
                                 "NOT USE CONSTRAINT OF ACTUAL");
79
                    END IF;
80
                    IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
81
                         FAILED ("RECORD TYPE OUT PARAMETER DID " &
82
                                 "NOT USE CONSTRAINT OF ACTUAL");
83
                    END IF;
84
                    IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
85
                         FAILED ("RECORD TYPE IN OUT PARAMETER DID " &
86
                                 "NOT USE CONSTRAINT OF ACTUAL");
87
                    END IF;
88
                    REC2 := PKG.REC2;
89
               END CHK_RECTYPE1;
90
 
91
               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
92
               BEGIN
93
                    IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
94
                         FAILED ("RECORD TYPE OUT PARAMETER DID " &
95
                                 "NOT USE CONSTRAINT OF " &
96
                                 "UNINITIALIZED ACTUAL");
97
                    END IF;
98
                    REC := (10,10,"9876543210");
99
               END CHK_RECTYPE2;
100
          END PKG;
101
 
102
     BEGIN  -- (A)
103
 
104
          PKG.CHK_RECTYPE1 (PKG.REC1, PKG.REC2, PKG.REC3);
105
          PKG.CHK_RECTYPE2 (PKG.REC4);
106
 
107
     END;   -- (A)
108
 
109
     ---------------------------------------------
110
 
111
B :  DECLARE  -- (B)
112
 
113
          PACKAGE PKG IS
114
 
115
               SUBTYPE INT IS INTEGER RANGE 0..100;
116
 
117
               TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE;
118
 
119
 
120
               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
121
                                       REC2 : OUT RECTYPE;
122
                                       REC3 : IN OUT RECTYPE);
123
 
124
               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
125
 
126
          PRIVATE
127
               TYPE RECTYPE (CONSTRAINT : INT := 80) IS
128
                    RECORD
129
                         INTFIELD  : INTEGER;
130
                         STRFIELD  : STRING (1..CONSTRAINT);
131
                    END RECORD;
132
          END PKG;
133
 
134
          REC1  : PKG.RECTYPE(10);
135
          REC2  : PKG.RECTYPE(17);
136
          REC3  : PKG.RECTYPE(1);
137
          REC4  : PKG.RECTYPE(10);
138
 
139
          PACKAGE BODY PKG IS
140
 
141
               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
142
                                       REC2 : OUT RECTYPE;
143
                                       REC3 : IN OUT RECTYPE) IS
144
               BEGIN
145
                    IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
146
                         FAILED ("PRIVATE TYPE IN PARAMETER DID " &
147
                                 "NOT USE CONSTRAINT OF ACTUAL");
148
                    END IF;
149
                    IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
150
                         FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
151
                                 "NOT USE CONSTRAINT OF ACTUAL");
152
                    END IF;
153
                    IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
154
                         FAILED ("PRIVATE TYPE IN OUT PARAMETER DID " &
155
                                 "NOT USE CONSTRAINT OF ACTUAL");
156
                    END IF;
157
                    REC2 := B.REC2;
158
               END CHK_RECTYPE1;
159
 
160
               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
161
               BEGIN
162
                    IF (REC.CONSTRAINT /= IDENT_INT(10)) THEN
163
                         FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
164
                                 "NOT USE CONSTRAINT OF " &
165
                                 "UNINITIALIZED ACTUAL");
166
                    END IF;
167
                    REC := (10,10,"9876543210");
168
               END CHK_RECTYPE2;
169
 
170
          BEGIN
171
               REC1 := (10,10,"0123456789");
172
               REC2 := (17,7,"C64106A..........");
173
               REC3 := (1,1,"A");
174
 
175
          END PKG;
176
 
177
     BEGIN  -- (B)
178
 
179
          PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
180
          PKG.CHK_RECTYPE2 (REC4);
181
 
182
     END B;  -- (B)
183
 
184
     ---------------------------------------------
185
 
186
C :  DECLARE  -- (C)
187
 
188
          PACKAGE PKG IS
189
 
190
               SUBTYPE INT IS INTEGER RANGE 0..100;
191
 
192
               TYPE RECTYPE (CONSTRAINT : INT := 80) IS
193
                    LIMITED PRIVATE;
194
 
195
               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
196
                                       REC2 : OUT RECTYPE;
197
                                       REC3 : IN OUT RECTYPE);
198
 
199
               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
200
 
201
          PRIVATE
202
               TYPE RECTYPE (CONSTRAINT : INT := 80) IS
203
                    RECORD
204
                         INTFIELD  : INTEGER;
205
                         STRFIELD  : STRING (1..CONSTRAINT);
206
                    END RECORD;
207
          END PKG;
208
 
209
          REC1  : PKG.RECTYPE;     -- 10   
210
          REC2  : PKG.RECTYPE;     -- 17
211
          REC3  : PKG.RECTYPE;     --  1
212
          REC4  : PKG.RECTYPE;     -- 80
213
 
214
          PACKAGE BODY PKG IS
215
 
216
               PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
217
                                       REC2 : OUT RECTYPE;
218
                                       REC3 : IN OUT RECTYPE) IS
219
               BEGIN
220
                    IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
221
                         FAILED ("LIMITED PRIVATE TYPE IN PARAMETER " &
222
                                 "DID NOT USE CONSTRAINT OF " &
223
                                 "ACTUAL");
224
                    END IF;
225
                    IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
226
                         FAILED ("LIMITED PRIVATE TYPE OUT PARAMETER " &
227
                                 "DID NOT USE CONSTRAINT OF " &
228
                                 "ACTUAL");
229
                    END IF;
230
                    IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
231
                         FAILED ("LIMITED PRIVATE TYPE IN OUT " &
232
                                 "PARAMETER DID NOT USE " &
233
                                 "CONSTRAINT OF ACTUAL");
234
                    END IF;
235
                    REC2 := C.REC2;
236
               END CHK_RECTYPE1;
237
 
238
               PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
239
               BEGIN
240
                    IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
241
                         FAILED ("LIMITED PRIVATE TYPE OUT " &
242
                                 "PARAMETER DID NOT USE " &
243
                                 "CONSTRAINT OF UNINITIALIZED ACTUAL");
244
                    END IF;
245
                    REC := (10,10,"9876543210");
246
               END CHK_RECTYPE2;
247
 
248
          BEGIN
249
               REC1 := (10,10,"0123456789");
250
               REC2 := (17,7,"C64106A..........");
251
               REC3 := (1,1,"A");
252
          END PKG;
253
 
254
     BEGIN  -- (C)
255
 
256
          PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
257
          PKG.CHK_RECTYPE2 (REC4);
258
 
259
     END C;   -- (C)
260
 
261
     ---------------------------------------------
262
 
263
D :  DECLARE  -- (D)
264
 
265
          TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF
266
               CHARACTER;
267
 
268
          A1, A2, A3  : ATYPE(-1..1, 4..5)  := (('A','B'),
269
                                                ('C','D'),
270
                                                ('E','F'));
271
 
272
          A4  : ATYPE(-1..1, 4..5);
273
 
274
          CA1 : CONSTANT ATYPE(8..9, -7..INTEGER'FIRST) :=
275
                              (8..9 => (-7..INTEGER'FIRST => 'A'));
276
 
277
          S1  : STRING(1..INTEGER'FIRST) := "";
278
          S2  : STRING(-5..-7) := "";
279
          S3  : STRING(1..0) := "";
280
 
281
          PROCEDURE CHK_ARRAY1 (A1 : IN ATYPE := CA1;  A2 : OUT ATYPE;
282
                                A3 : IN OUT ATYPE) IS
283
          BEGIN
284
               IF ((A1'FIRST(1) /= IDENT_INT(-1)) OR
285
                   (A1'LAST(1)  /= IDENT_INT(1)) OR
286
                   (A1'FIRST(2) /= IDENT_INT(4)) OR
287
                   (A1'LAST(2)  /= IDENT_INT(5))) THEN
288
                    FAILED ("ARRAY TYPE IN PARAMETER DID NOT " &
289
                            "USE CONSTRAINTS OF ACTUAL");
290
               END IF;
291
               IF ((A2'FIRST(1) /= IDENT_INT(-1)) OR
292
                   (A2'LAST(1)  /= IDENT_INT(1)) OR
293
                   (A2'FIRST(2) /= IDENT_INT(4)) OR
294
                   (A2'LAST(2)  /= IDENT_INT(5))) THEN
295
                    FAILED ("ARRAY TYPE OUT PARAMETER DID NOT USE" &
296
                            "CONSTRAINTS OF ACTUAL");
297
               END IF;
298
               IF ((A3'FIRST(1) /= IDENT_INT(-1)) OR
299
                   (A3'LAST(1)  /= IDENT_INT(1)) OR
300
                   (A3'FIRST(2) /= IDENT_INT(4)) OR
301
                   (A3'LAST(2)  /= IDENT_INT(5))) THEN
302
                    FAILED ("ARRAY TYPE IN OUT PARAMETER DID NOT " &
303
                            "USE CONSTRAINTS OF ACTUAL");
304
               END IF;
305
               A2 := D.A2;
306
          END CHK_ARRAY1;
307
 
308
          PROCEDURE CHK_ARRAY2 (A4 : OUT ATYPE) IS
309
          BEGIN
310
               IF ((A4'FIRST(1) /= IDENT_INT(-1)) OR
311
                   (A4'LAST(1)  /= IDENT_INT(1)) OR
312
                   (A4'FIRST(2) /= IDENT_INT(4)) OR
313
                   (A4'LAST(2)  /= IDENT_INT(5))) THEN
314
                    FAILED ("ARRAY TYPE OUT PARAMETER DID NOT " &
315
                            "USE CONSTRAINTS OF UNINITIALIZED " &
316
                            "ACTUAL");
317
               END IF;
318
               A4 := A2;
319
          END CHK_ARRAY2;
320
 
321
          PROCEDURE CHK_STRING (S1 : IN STRING;
322
                                S2 : IN OUT STRING;
323
                                S3 : OUT STRING) IS
324
          BEGIN
325
               IF ((S1'FIRST /= IDENT_INT(1)) OR
326
                   (S1'LAST  /= IDENT_INT(INTEGER'FIRST))) THEN
327
                    FAILED ("STRING TYPE IN PARAMETER DID NOT " &
328
                            "USE CONSTRAINTS OF ACTUAL NULL " &
329
                            "STRING");
330
               END IF;
331
               IF ((S2'FIRST /= IDENT_INT(-5)) OR
332
                   (S2'LAST  /= IDENT_INT(-7))) THEN
333
                    FAILED ("STRING TYPE IN OUT PARAMETER DID NOT " &
334
                            "USE CONSTRAINTS OF ACTUAL NULL STRING");
335
               END IF;
336
               IF ((S3'FIRST /= IDENT_INT(1)) OR
337
                   (S3'LAST  /= IDENT_INT(0))) THEN
338
                    FAILED ("STRING TYPE OUT PARAMETER DID NOT " &
339
                            "USE CONSTRAINTS OF ACTUAL NULL STRING");
340
               END IF;
341
               S3 := "";
342
          END CHK_STRING;
343
 
344
     BEGIN  -- (D)
345
          CHK_ARRAY1 (A1, A2, A3);
346
          CHK_ARRAY2 (A4);
347
          CHK_STRING (S1, S2, S3);
348
     END D;  -- (D)
349
 
350
     RESULT;
351
END C64106A;

powered by: WebSVN 2.1.0

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