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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C37207A.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
 
27
--     FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK
28
--     THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING
29
--     CONTEXTS AND HAS THE PROPER EFFECT:
30
 
31
--     IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR
32
--     3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE,
33
--     ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT
34
--     VALUES WITHOUT RAISING CONSTRAINT_ERROR
35
 
36
--     4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES
37
--     OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES
38
--     DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES.
39
 
40
--     5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED
41
--     DISCRIMINANT VALUES.
42
 
43
--     6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND
44
--     HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO
45
--     CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR,
46
--     CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT
47
--     VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS
48
--     RAISED.
49
 
50
-- HISTORY:
51
 
52
--     ASL 07/24/81
53
--     RJW 08/28/86  CORRECTED SYNTAX ERRORS.
54
--     JLH 08/07/87  ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION.
55
--     EDS 07/16/98  AVOID OPTIMIZATION
56
 
57
WITH REPORT; USE REPORT;
58
PROCEDURE C37207A IS
59
 
60
BEGIN
61
     TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " &
62
          "DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " &
63
          "DEFAULT DISCRIMINANT VALUES");
64
 
65
     DECLARE
66
          TYPE REC1 (DISC : INTEGER := 5) IS
67
               RECORD
68
                    NULL;
69
               END RECORD;
70
 
71
          TYPE REC2 (DISC : INTEGER) IS
72
               RECORD
73
                    NULL;
74
                END RECORD;
75
 
76
          OBJ1 : REC1(6);                     -- 1.
77
          OBJ2 : REC2(6);                     -- 1.
78
          BADOBJ1 : REC1(7);                  -- 1.
79
          BADOBJ2 : REC2(7);                  -- 1.
80
 
81
          TYPE REC3 IS
82
               RECORD
83
                    COMP1 : REC1(6);          -- 2.
84
                    COMP2 : REC2(6);          -- 2.
85
               END RECORD;
86
 
87
          OBJ3 : REC3;
88
 
89
          TYPE ARR1 IS ARRAY (1..10) OF REC1(6);  -- 3.
90
          TYPE ARR2 IS ARRAY (1..10) OF REC2(6);  -- 3.
91
 
92
          A1 : ARR1;
93
          A2 : ARR2;
94
 
95
          TYPE REC1_NAME IS ACCESS REC1(6);   -- 4.
96
          TYPE REC2_NAME IS ACCESS REC2(6);   -- 4.
97
 
98
          ACC1 : REC1_NAME;
99
          ACC2 : REC2_NAME;
100
 
101
          SUBTYPE REC16 IS REC1(6);
102
          SUBTYPE REC26 IS REC2(6);
103
 
104
          PROCEDURE PROC (P1 : IN OUT REC16;     -- 6.
105
                         P2 : IN OUT REC26) IS  -- 6.
106
          BEGIN
107
               IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN  -- 6.
108
                    FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " &
109
                            "CONSTRAINED FORMAL PARAMETERS");
110
               END IF;
111
               BEGIN
112
                    P1 := (DISC => 7);         -- 6.
113
                    FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
114
                            "ATTEMPT TO CHANGE DISCRIMINANT OF " &
115
                            "CONSTRAINED FORMAL PARAMETER " &
116
                            INTEGER'IMAGE(P1.DISC));
117
               EXCEPTION
118
                    WHEN CONSTRAINT_ERROR => NULL;
119
                    WHEN OTHERS => FAILED ("WRONG EXCEPTION     (1)");
120
               END;
121
               BEGIN
122
                    P2 := (DISC => 7);         -- 6.
123
                    FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
124
                            "ATTEMPT TO CHANGE DISCRIMINANT OF " &
125
                            "CONSTRAINED FORMAL PARAMETER " &
126
                            INTEGER'IMAGE(P2.DISC));
127
               EXCEPTION
128
                    WHEN CONSTRAINT_ERROR => NULL;
129
                    WHEN OTHERS => FAILED ("WRONG EXCEPTION     (2)");
130
               END;
131
          END PROC;
132
     BEGIN
133
---------------------------------------------------------------
134
 
135
          BEGIN
136
               OBJ1 := (DISC => IDENT_INT(7));           -- 1.
137
               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
138
                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &
139
                       "CONSTRAINED OBJECT");
140
               IF OBJ1 = (DISC => 7) THEN
141
                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
142
               END IF;
143
          EXCEPTION
144
               WHEN CONSTRAINT_ERROR => NULL;
145
               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (3)");
146
          END;
147
 
148
---------------------------------------------------------------
149
 
150
          BEGIN
151
               OBJ3 := ((DISC => IDENT_INT(7)),      -- 2.
152
                        (DISC => IDENT_INT(7)));     -- 2.
153
               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
154
                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &
155
                       "CONSTRAINED RECORD COMPONENT");
156
               IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN
157
                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
158
               END IF;
159
          EXCEPTION
160
               WHEN CONSTRAINT_ERROR => NULL;
161
               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (4)");
162
          END;
163
 
164
--------------------------------------------------------------
165
 
166
          BEGIN
167
               A2(2) := (DISC => IDENT_INT(7));          -- 3.
168
               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
169
                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &
170
                       "CONSTRAINED ARRAY COMPONENT");
171
               IF A2(2) = (DISC => 7) THEN
172
                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
173
               END IF;
174
          EXCEPTION
175
               WHEN CONSTRAINT_ERROR => NULL;
176
               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (5)");
177
          END;
178
 
179
--------------------------------------------------------------
180
 
181
          BEGIN
182
               ACC1 := NEW REC1(DISC => IDENT_INT(7));   -- 4.
183
               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
184
                       "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
185
                       "TO ACCESS VARIABLE");
186
               IF ACC1 =  NEW REC1(DISC => 7) THEN
187
                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
188
               END IF;
189
         EXCEPTION
190
               WHEN CONSTRAINT_ERROR => NULL;
191
               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (6)");
192
          END;
193
 
194
----------------------------------------------------------------
195
 
196
               ACC1 := NEW REC1(DISC => IDENT_INT(6));  -- OK.
197
 
198
          BEGIN
199
               ACC1.ALL := BADOBJ1;           -- 5.
200
               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
201
                       "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
202
                       "TO ACCESSED OBJECT");
203
               IF ACC1.ALL = BADOBJ1 THEN
204
                    COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION");
205
               END IF;
206
          EXCEPTION
207
               WHEN CONSTRAINT_ERROR => NULL;
208
               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (7)");
209
          END;
210
 
211
-----------------------------------------------------------------
212
 
213
               PROC (OBJ1,OBJ2);              -- OK.
214
 
215
          BEGIN
216
               PROC (BADOBJ1,BADOBJ2);        -- 6.
217
               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
218
                       "PASSING OF CONSTRAINED ACTUAL " &
219
                       "PARAMETERS TO DIFFERENTLY CONSTRAINED " &
220
                       "FORMAL PARAMETERS");
221
          EXCEPTION
222
               WHEN CONSTRAINT_ERROR => NULL;
223
               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (8)");
224
          END;
225
 
226
---------------------------------------------------------------
227
     END;
228
 
229
     RESULT;
230
END C37207A;

powered by: WebSVN 2.1.0

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