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/] [c4/] [c48009g.ada] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- C48009G.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 ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT
27
--     CONSTRAINT_ERROR IS RAISED IF T IS A CONSTRAINED ACCESS
28
--     TYPE AND THE OBJECT DESIGNATED BY X DOES NOT HAVE DISCRIMINANTS
29
--     OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING VALUES FOR T.
30
 
31
-- HISTORY:
32
--     EG  08/30/84  CREATED ORIGINAL TEST.
33
--     JET 01/05/87  UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT
34
--                   OPTIMIZATION.
35
 
36
WITH REPORT;
37
 
38
PROCEDURE C48009G IS
39
 
40
     USE REPORT;
41
 
42
     GENERIC
43
          TYPE G_TYPE IS PRIVATE;
44
     FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN;
45
 
46
     FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN IS
47
     BEGIN
48
          IF (IDENT_INT(3) = 3) AND (X = Y) THEN
49
               RETURN TRUE;
50
          ELSE
51
               RETURN FALSE;
52
          END IF;
53
     END EQUAL_G;
54
 
55
BEGIN
56
 
57
     TEST("C48009G","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
58
                    "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
59
                    "APPROPRIATE - CONSTRAINED ACCESS TYPE");
60
 
61
     DECLARE
62
 
63
          TYPE INT IS RANGE 1 .. 5;
64
 
65
          TYPE UR(A : INT) IS
66
               RECORD
67
                    B : INTEGER;
68
               END RECORD;
69
          TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER;
70
 
71
          PACKAGE P IS
72
               TYPE UP(A, B : INT) IS PRIVATE;
73
               TYPE UL(A, B : INT) IS LIMITED PRIVATE;
74
               CONS_UP : CONSTANT UP;
75
          PRIVATE
76
               TYPE UP(A, B : INT) IS
77
                    RECORD
78
                         C : INTEGER;
79
                    END RECORD;
80
               TYPE UL(A, B : INT) IS
81
                    RECORD
82
                         C : INTEGER;
83
                    END RECORD;
84
               CONS_UP : CONSTANT UP := (2, 2, (IDENT_INT(3)));
85
          END P;
86
 
87
          TYPE A_UR IS ACCESS UR;
88
          TYPE A_UA IS ACCESS UA;
89
          TYPE A_UP IS ACCESS P.UP;
90
          TYPE A_UL IS ACCESS P.UL;
91
 
92
          SUBTYPE CA_UR IS A_UR(2);
93
          SUBTYPE CA_UA IS A_UA(2 .. 3);
94
          SUBTYPE CA_UP IS A_UP(3, 2);
95
          SUBTYPE CA_UL IS A_UL(2, 4);
96
 
97
          TYPE A_CA_UR IS ACCESS CA_UR;
98
          TYPE A_CA_UA IS ACCESS CA_UA;
99
          TYPE A_CA_UP IS ACCESS CA_UP;
100
          TYPE A_CA_UL IS ACCESS CA_UL;
101
 
102
          V_A_CA_UR : A_CA_UR;
103
          V_A_CA_UA : A_CA_UA;
104
          V_A_CA_UP : A_CA_UP;
105
          V_A_CA_UL : A_CA_UL;
106
 
107
          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UR);
108
          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UA);
109
          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UP);
110
          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UL);
111
 
112
     BEGIN
113
 
114
          BEGIN
115
               V_A_CA_UR := NEW CA_UR'(NEW UR'(1,(IDENT_INT(2))));
116
 
117
               IF EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
118
                    FAILED ("NO EXCEPTION RAISED - UR");
119
               END IF;
120
 
121
          EXCEPTION
122
               WHEN CONSTRAINT_ERROR =>
123
                    NULL;
124
               WHEN OTHERS =>
125
                    FAILED ("WRONG EXCEPTION RAISED - UR");
126
          END;
127
 
128
          BEGIN
129
               V_A_CA_UA := NEW CA_UA'(NEW UA'(1 => 2,
130
                                               2 => IDENT_INT(3)));
131
 
132
               IF EQUAL (V_A_CA_UA, V_A_CA_UA) THEN
133
                    FAILED ("NO EXCEPTION RAISED - UA");
134
               END IF;
135
 
136
          EXCEPTION
137
               WHEN CONSTRAINT_ERROR =>
138
                    NULL;
139
               WHEN OTHERS =>
140
                    FAILED ("WRONG EXCEPTION RAISED - UA");
141
          END;
142
 
143
          BEGIN
144
               V_A_CA_UP := NEW CA_UP'(NEW P.UP'(P.CONS_UP));
145
 
146
               IF EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
147
                    FAILED ("NO EXCEPTION RAISED - UP");
148
               END IF;
149
 
150
          EXCEPTION
151
               WHEN CONSTRAINT_ERROR =>
152
                    NULL;
153
               WHEN OTHERS =>
154
                    FAILED ("WRONG EXCEPTION RAISED - UP");
155
          END;
156
 
157
          BEGIN
158
               V_A_CA_UR := NEW CA_UR'(NULL);
159
 
160
               IF NOT EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
161
                    COMMENT ("NO EXCEPTION RAISED - UR");
162
               END IF;
163
 
164
          EXCEPTION
165
               WHEN OTHERS =>
166
                    FAILED ("EXCEPTION RAISED - UR");
167
          END;
168
 
169
          BEGIN
170
               V_A_CA_UA := NEW CA_UA'(NULL);
171
 
172
               IF NOT EQUAL (V_A_CA_UA, V_A_CA_UA) THEN
173
                    COMMENT ("NO EXCEPTION RAISED - UA");
174
               END IF;
175
 
176
          EXCEPTION
177
               WHEN OTHERS =>
178
                    FAILED ("EXCEPTION RAISED - UA");
179
          END;
180
 
181
          BEGIN
182
               V_A_CA_UP := NEW CA_UP'(NULL);
183
 
184
               IF NOT EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
185
                    COMMENT ("NO EXCEPTION RAISED - UP");
186
               END IF;
187
 
188
          EXCEPTION
189
               WHEN OTHERS =>
190
                    FAILED ("EXCEPTION RAISED - UP");
191
          END;
192
 
193
          BEGIN
194
               V_A_CA_UL := NEW CA_UL'(NULL);
195
 
196
               IF NOT EQUAL (V_A_CA_UL, V_A_CA_UL) THEN
197
                    COMMENT ("NO EXCEPTION RAISED - UL");
198
               END IF;
199
 
200
          EXCEPTION
201
               WHEN OTHERS =>
202
                    FAILED ("EXCEPTION RAISED - UL");
203
          END;
204
 
205
     END;
206
 
207
     RESULT;
208
 
209
END C48009G;

powered by: WebSVN 2.1.0

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