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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C41304B.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
--      CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN:
27
--        L DENOTES A RECORD OBJECT SUCH THAT, FOR THE EXISTING
28
--           DISCRIMINANT VALUES, THE COMPONENT DENOTED BY R DOES
29
--           NOT EXIST.
30
--        L IS A FUNCTION CALL DELIVERING A RECORD VALUE SUCH THAT,
31
--           FOR THE EXISTING DISCRIMINANT VALUES, THE COMPONENT
32
--           DENOTED BY R DOES NOT EXIST.
33
--        L IS AN ACCESS OBJECT AND THE OBJECT DESIGNATED BY THE ACCESS
34
--           VALUE IS SUCH THAT COMPONENT R DOES NOT EXIST FOR THE
35
--           OBJECT'S CURRENT DISCRIMINANT VALUES.
36
--        L IS A FUNCTION CALL RETURNING AN ACCESS VALUE AND THE OBJECT
37
--           DESIGNATED BY THE ACCESS VALUE IS SUCH THAT COMPONENT R
38
--           DOES NOT EXIST FOR THE OBJECT'S CURRENT DISCRIMINANT
39
--           VALUES.
40
 
41
-- HISTORY:
42
--     TBN 05/23/86  CREATED ORIGINAL TEST.
43
--     JET 01/08/88  MODIFIED HEADER FORMAT AND ADDED CODE TO
44
--                   PREVENT OPTIMIZATION.
45
 
46
WITH REPORT; USE REPORT;
47
PROCEDURE C41304B IS
48
 
49
     TYPE V (DISC : INTEGER := 0) IS
50
          RECORD
51
               CASE DISC IS
52
                    WHEN 1 =>
53
                         X : INTEGER;
54
                    WHEN OTHERS =>
55
                         Y : INTEGER;
56
               END CASE;
57
          END RECORD;
58
 
59
     TYPE T IS ACCESS V;
60
 
61
BEGIN
62
     TEST ("C41304B", "CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN " &
63
                      "THE COMPONENT DENOTED BY R DOES NOT EXIST");
64
 
65
     DECLARE
66
 
67
          VR : V := (DISC => 0, Y => 4);
68
          J : INTEGER;
69
 
70
     BEGIN
71
 
72
          IF EQUAL (4, 4) THEN
73
               VR := (DISC => 1, X => 3);
74
          END IF;
75
 
76
          J := VR.Y;
77
          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A RECORD OBJECT");
78
 
79
          -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
80
 
81
          IF EQUAL (J,3) THEN
82
               FAILED ("CONSTRAINT_ERROR NOT RAISED - 1");
83
          END IF;
84
 
85
     EXCEPTION
86
 
87
          WHEN CONSTRAINT_ERROR =>
88
               NULL;
89
          WHEN OTHERS =>
90
               FAILED ("WRONG EXCEPTION RAISED FOR A RECORD OBJECT");
91
 
92
     END;
93
 
94
     --------------------------------------------------
95
 
96
     DECLARE
97
 
98
          J : INTEGER;
99
 
100
          FUNCTION F RETURN V IS
101
          BEGIN
102
               IF EQUAL (4, 4) THEN
103
                    RETURN (DISC => 2, Y => 3);
104
               END IF;
105
               RETURN (DISC => 1, X => 4);
106
          END F;
107
 
108
     BEGIN
109
 
110
          J := F.X;
111
          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " &
112
                  "DELIVERING A RECORD VALUE");
113
 
114
          -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
115
 
116
          IF EQUAL (J,3) THEN
117
               FAILED ("CONSTRAINT_ERROR NOT RAISED - 2");
118
          END IF;
119
 
120
     EXCEPTION
121
 
122
          WHEN CONSTRAINT_ERROR =>
123
               NULL;
124
          WHEN OTHERS =>
125
               FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " &
126
                       "DELIVERING A RECORD VALUE");
127
 
128
     END;
129
 
130
     --------------------------------------------------
131
 
132
     DECLARE
133
 
134
          A : T := NEW V' (DISC => 0, Y => 4);
135
          J : INTEGER;
136
 
137
     BEGIN
138
 
139
          IF EQUAL (4, 4) THEN
140
               A := NEW V' (DISC => 1, X => 3);
141
          END IF;
142
 
143
          J := A.Y;
144
          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR AN ACCESS OBJECT");
145
 
146
          -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
147
 
148
          IF EQUAL (J,3) THEN
149
               FAILED ("CONSTRAINT_ERROR NOT RAISED - 3");
150
          END IF;
151
 
152
     EXCEPTION
153
 
154
          WHEN CONSTRAINT_ERROR =>
155
               NULL;
156
          WHEN OTHERS =>
157
               FAILED ("WRONG EXCEPTION RAISED FOR AN ACCESS OBJECT");
158
 
159
     END;
160
 
161
     --------------------------------------------------
162
 
163
     DECLARE
164
 
165
          J : INTEGER;
166
 
167
          FUNCTION F RETURN T IS
168
          BEGIN
169
               IF EQUAL (4, 4) THEN
170
                    RETURN NEW V' (DISC => 2, Y => 3);
171
               END IF;
172
               RETURN NEW V' (DISC => 1, X => 4);
173
          END F;
174
 
175
     BEGIN
176
 
177
          J := F.X;
178
          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " &
179
                  "DELIVERING AN ACCESS VALUE");
180
 
181
          -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
182
 
183
          IF EQUAL (J,3) THEN
184
               FAILED ("CONSTRAINT_ERROR NOT RAISED - 4");
185
          END IF;
186
 
187
     EXCEPTION
188
 
189
          WHEN CONSTRAINT_ERROR =>
190
               NULL;
191
          WHEN OTHERS =>
192
               FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " &
193
                       "DELIVERING AN ACCESS VALUE");
194
 
195
     END;
196
 
197
     RESULT;
198
END C41304B;

powered by: WebSVN 2.1.0

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