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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C460004.A
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
--
26
-- OBJECTIVE:
27
--      Check that if the operand type of a type conversion is class-wide,
28
--      Constraint_Error is raised if the tag of the operand does not
29
--      identify a specific type that is covered by or descended from the
30
--      target type.
31
--
32
-- TEST DESCRIPTION:
33
--      View conversions of class-wide operands to specific types are
34
--      placed on the right and left sides of assignment statements, and
35
--      conversions of class-wide operands to class-wide types are used
36
--      as actual parameters to dispatching operations. In all cases, a
37
--      check is made that Constraint_Error is raised if the tag of the
38
--      operand does not identify a specific type covered by or descended
39
--      from the target type, and not raised otherwise.
40
--
41
--      A specific type is descended from itself and from those types it is
42
--      directly or indirectly derived from. A specific type is covered by
43
--      itself and each class-wide type to whose class it belongs.
44
--
45
--      A class-wide type T'Class is descended from T and those types which
46
--      T is descended from. A class-wide type is covered by each class-wide
47
--      type to whose class it belongs.
48
--
49
--
50
-- CHANGE HISTORY:
51
--      19 Jul 95   SAIC    Initial prerelease version.
52
--      18 Apr 96   SAIC    ACVC 2.1: Added a check for correct tag.
53
--
54
--!
55
package C460004_0 is
56
 
57
   type Tag_Type is tagged record
58
      C1 : Natural;
59
   end record;
60
 
61
   procedure Proc (X : in out Tag_Type);
62
 
63
 
64
   type DTag_Type is new Tag_Type with record
65
      C2 : String (1 .. 5);
66
   end record;
67
 
68
   procedure Proc (X : in out DTag_Type);
69
 
70
 
71
   type DDTag_Type is new DTag_Type with record
72
      C3 : String (1 .. 5);
73
   end record;
74
 
75
   procedure Proc (X : in out DDTag_Type);
76
 
77
   procedure NewProc (X : in DDTag_Type);
78
 
79
   function CWFunc (X : Tag_Type'Class) return Tag_Type'Class;
80
 
81
end C460004_0;
82
 
83
 
84
     --==================================================================--
85
 
86
with Report;
87
package body C460004_0 is
88
 
89
   procedure Proc (X : in out Tag_Type) is
90
   begin
91
      X.C1 := 25;
92
   end Proc;
93
 
94
   -----------------------------------------
95
   procedure Proc (X : in out DTag_Type) is
96
   begin
97
      Proc ( Tag_Type(X) );
98
      X.C2 := "Earth";
99
   end Proc;
100
 
101
   -----------------------------------------
102
   procedure Proc (X : in out DDTag_Type) is
103
   begin
104
      Proc ( DTag_Type(X) );
105
      X.C3 := "Orbit";
106
   end Proc;
107
 
108
   -----------------------------------------
109
   procedure NewProc (X : in DDTag_Type) is
110
      Y : DDTag_Type := X;
111
   begin
112
      Proc (Y);
113
   exception
114
      when others =>
115
         Report.Failed ("Unexpected exception in NewProc");
116
   end NewProc;
117
 
118
   -----------------------------------------
119
   function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is
120
      Y : Tag_Type'Class := X;
121
   begin
122
      Proc (Y);
123
      return Y;
124
   end CWFunc;
125
 
126
end C460004_0;
127
 
128
 
129
     --==================================================================--
130
 
131
 
132
with C460004_0;
133
use  C460004_0;
134
 
135
with Report;
136
procedure C460004 is
137
 
138
   Tag_Type_Init    :  constant Tag_Type   := (C1 => 0);
139
   DTag_Type_Init   :  constant DTag_Type  := (Tag_Type_Init with "Hello");
140
   DDTag_Type_Init  :  constant DDTag_Type := (DTag_Type_Init with "World");
141
 
142
   Tag_Type_Value   :  constant Tag_Type   := (C1 => 25);
143
   DTag_Type_Value  :  constant DTag_Type  := (Tag_Type_Value  with "Earth");
144
   DDTag_Type_Value :  constant DDTag_Type := (DTag_Type_Value with "Orbit");
145
 
146
begin
147
 
148
   Report.Test ("C460004", "Check that for a view conversion of a "      &
149
                "class-wide operand, Constraint_Error is raised if the " &
150
                "tag of the operand does not identify a specific type "  &
151
                "covered by or descended from the target type");
152
 
153
--
154
-- View conversion to specific type:
155
--
156
 
157
   declare
158
      procedure CW_Proc (P : Tag_Type'Class) is
159
         Target : Tag_Type := Tag_Type_Init;
160
      begin
161
         Target := Tag_Type(P);
162
         if (Target /= Tag_Type_Value) then
163
            Report.Failed ("Target has wrong value: #01");
164
         end if;
165
      exception
166
         when Constraint_Error =>
167
            Report.Failed ("Constraint_Error raised: #01");
168
         when others           =>
169
            Report.Failed ("Unexpected exception: #01");
170
      end CW_Proc;
171
 
172
   begin
173
      CW_Proc (DDTag_Type_Value);
174
   end;
175
 
176
   ----------------------------------------------------------------------
177
 
178
   declare
179
      Target : DTag_Type := DTag_Type_Init;
180
   begin
181
      Target := DTag_Type(CWFunc(DDTag_Type_Value));
182
      if (Target /= DTag_Type_Value) then
183
         Report.Failed ("Target has wrong value: #02");
184
      end if;
185
   exception
186
      when Constraint_Error => Report.Failed ("Constraint_Error raised: #02");
187
      when others           => Report.Failed ("Unexpected exception: #02");
188
   end;
189
 
190
   ----------------------------------------------------------------------
191
 
192
   declare
193
      Target : DDTag_Type;
194
   begin
195
      Target := DDTag_Type(CWFunc(Tag_Type_Value));
196
                -- CWFunc returns a Tag_Type; its tag is preserved through
197
                -- the view conversion.  Constraint_Error should be raised.
198
 
199
      Report.Failed ("Constraint_Error not raised: #03");
200
 
201
   exception
202
      when Constraint_Error => null;                 -- expected exception
203
      when others           => Report.Failed ("Unexpected exception: #03");
204
   end;
205
 
206
   ----------------------------------------------------------------------
207
 
208
   declare
209
      procedure CW_Proc (P : Tag_Type'Class) is
210
      begin
211
         NewProc (DDTag_Type(P));
212
         Report.Failed ("Constraint_Error not raised: #04");
213
 
214
      exception
215
         when Constraint_Error => null;              -- expected exception
216
         when others           => Report.Failed ("Unexpected exception: #04");
217
      end CW_Proc;
218
 
219
   begin
220
      CW_Proc (DTag_Type_Value);
221
   end;
222
 
223
   ----------------------------------------------------------------------
224
 
225
   declare
226
      procedure CW_Proc (P : Tag_Type'Class) is
227
         Target : DDTag_Type := DDTag_Type_Init;
228
      begin
229
         Target := DDTag_Type(P);
230
         if (Target /= DDTag_Type_Value) then
231
            Report.Failed ("Target has wrong value: #05");
232
         end if;
233
 
234
      exception
235
         when Constraint_Error =>
236
            Report.Failed ("Constraint_Error raised: #05");
237
         when others
238
            => Report.Failed ("Unexpected exception: #05");
239
      end CW_Proc;
240
 
241
   begin
242
      CW_Proc (DDTag_Type_Value);
243
   end;
244
 
245
 
246
--
247
-- View conversion to class-wide type:
248
--
249
 
250
   declare
251
      procedure CW_Proc (P : Tag_Type'Class) is
252
         Operand : Tag_Type'Class := P;
253
      begin
254
         Proc( DTag_Type'Class(Operand) );
255
         Report.Failed ("Constraint_Error not raised: #06");
256
 
257
      exception
258
         when Constraint_Error => null;              -- expected exception
259
         when others           => Report.Failed ("Unexpected exception: #06");
260
      end CW_Proc;
261
 
262
   begin
263
      CW_Proc (Tag_Type_Init);
264
   end;
265
 
266
   ----------------------------------------------------------------------
267
 
268
   declare
269
      procedure CW_Proc (P : Tag_Type'Class) is
270
         Operand : Tag_Type'Class := P;
271
      begin
272
         Proc( DDTag_Type'Class(Operand) );
273
         Report.Failed ("Constraint_Error not raised: #07");
274
 
275
      exception
276
         when Constraint_Error => null;              -- expected exception
277
         when others           => Report.Failed ("Unexpected exception: #07");
278
      end CW_Proc;
279
 
280
   begin
281
      CW_Proc (Tag_Type_Init);
282
   end;
283
 
284
   ----------------------------------------------------------------------
285
 
286
   declare
287
      procedure CW_Proc (P : Tag_Type'Class) is
288
         Operand : Tag_Type'Class := P;
289
      begin
290
         Proc( DTag_Type'Class(Operand) );
291
         if Operand not in DTag_Type then
292
            Report.Failed ("Operand has wrong tag: #08");
293
         elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then
294
            Report.Failed ("Operand has wrong value: #08");
295
         end if;
296
 
297
      exception
298
         when Constraint_Error =>
299
            Report.Failed ("Constraint_Error raised: #08");
300
         when others           =>
301
            Report.Failed ("Unexpected exception: #08");
302
      end CW_Proc;
303
 
304
   begin
305
      CW_Proc (DTag_Type_Init);
306
   end;
307
 
308
   ----------------------------------------------------------------------
309
 
310
   declare
311
      procedure CW_Proc (P : Tag_Type'Class) is
312
         Operand : Tag_Type'Class := P;
313
      begin
314
         Proc( Tag_Type'Class(Operand) );
315
         if Operand not in DDTag_Type then
316
            Report.Failed ("Operand has wrong tag: #09");
317
         elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then
318
            Report.Failed ("Operand has wrong value: #09");
319
         end if;
320
 
321
      exception
322
         when Constraint_Error =>
323
            Report.Failed ("Constraint_Error raised: #09");
324
         when others           =>
325
            Report.Failed ("Unexpected exception: #09");
326
      end CW_Proc;
327
 
328
   begin
329
      CW_Proc (DDTag_Type_Init);
330
   end;
331
 
332
 
333
   Report.Result;
334
 
335
end C460004;

powered by: WebSVN 2.1.0

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