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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c460005.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C460005.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, for a view conversion of a tagged type that is the left
28
--      side of an assignment statement, the assignment assigns to the
29
--      corresponding part of the object denoted by the operand.
30
--
31
-- TEST DESCRIPTION:
32
--      View conversions of class-wide operands to specific types are
33
--      placed on the right and left sides of assignment statements, and
34
--      conversions of class-wide operands to class-wide types are used
35
--      as actual parameters to dispatching operations. In all cases, a
36
--      check is made that Constraint_Error is raised if the tag of the
37
--      operand does not identify a specific type covered by or descended
38
--      from the target type, and not raised otherwise.
39
--
40
--      For the cases where the view conversion is the left side of an
41
--      assignment statement, and Constraint_Error should not be raised,
42
--      an additional check is made that only the corresponding portion
43
--      of the operand is updated by the assignment. For example:
44
--
45
--         type T is tagged record
46
--            C1 : Integer := 0;
47
--         end record;
48
--
49
--         type DT is new T with record
50
--            C2 : Integer := 0;
51
--         end record;
52
--
53
--         A    : T       := (C1 => 5);
54
--         B    : DT      := (C1 => 0, C2 => 10);
55
--         CWDT : T'Class := B;
56
--
57
--         T(CWDT) := A;  -- Updates component C1; C2 remains unchanged.
58
--                        -- Value of CWDT is (C1 => 5, C2 => 10).
59
--
60
--
61
-- CHANGE HISTORY:
62
--      31 Jul 95   SAIC    Initial prerelease version.
63
--      22 Apr 96   SAIC    ACVC 2.1: Added a check for correct tag.
64
--      08 Sep 96   SAIC    ACVC 2.1: Modified Report.Test.
65
--
66
--!
67
 
68
package C460005_0 is
69
 
70
   type Tag_Type is tagged record
71
      C1 : Natural;
72
   end record;
73
 
74
   procedure Proc (X : in out Tag_Type);
75
 
76
 
77
   type DTag_Type is new Tag_Type with record
78
      C2 : String (1 .. 5);
79
   end record;
80
 
81
   procedure Proc (X : in out DTag_Type);
82
 
83
 
84
   type DDTag_Type is new DTag_Type with record
85
      C3 : String (1 .. 5);
86
   end record;
87
 
88
   procedure Proc (X : in out DDTag_Type);
89
 
90
end C460005_0;
91
 
92
 
93
     --==================================================================--
94
 
95
 
96
package body C460005_0 is
97
 
98
   procedure Proc (X : in out Tag_Type) is
99
   begin
100
      X.C1 := 25;
101
   end Proc;
102
 
103
   -----------------------------------------
104
   procedure Proc (X : in out DTag_Type) is
105
   begin
106
      Proc ( Tag_Type(X) );
107
      X.C2 := "Earth";
108
   end Proc;
109
 
110
   -----------------------------------------
111
   procedure Proc (X : in out DDTag_Type) is
112
   begin
113
      Proc ( DTag_Type(X) );
114
      X.C3 := "Orbit";
115
   end Proc;
116
 
117
end C460005_0;
118
 
119
 
120
     --==================================================================--
121
 
122
 
123
with C460005_0;
124
use  C460005_0;
125
 
126
with Report;
127
procedure C460005 is
128
 
129
   Tag_Type_Init    :  constant Tag_Type   := (C1 => 0);
130
   DTag_Type_Init   :  constant DTag_Type  := (Tag_Type_Init with "Hello");
131
   DDTag_Type_Init  :  constant DDTag_Type := (DTag_Type_Init with "World");
132
 
133
   Tag_Type_Value   :  constant Tag_Type   := (C1 => 25);
134
   DTag_Type_Value  :  constant DTag_Type  := (Tag_Type_Value  with "Earth");
135
   DDTag_Type_Value :  constant DDTag_Type := (DTag_Type_Value with "Orbit");
136
 
137
   Tag_Type_Res     :  constant Tag_Type   := (C1 => 25);
138
   DTag_Type_Res    :  constant DTag_Type  := (Tag_Type_Res  with "Hello");
139
   DDTag_Type_Res   :  constant DDTag_Type := (DTag_Type_Res with "World");
140
 
141
begin
142
 
143
   Report.Test ("C460005", "Check that, for a view conversion of a tagged " &
144
                "type that is the left side of an assignment statement, "   &
145
                "the assignment assigns to the corresponding part of the "  &
146
                "object denoted by the operand");
147
 
148
 
149
   declare
150
      procedure CW_Proc (P : Tag_Type'Class) is
151
         Operand : Tag_Type'Class := P;
152
      begin
153
         Tag_Type(Operand) := Tag_Type_Value;
154
 
155
         if (Operand /= Tag_Type'Class (Tag_Type_Value)) then
156
            Report.Failed ("Operand has wrong value: #01");
157
         end if;
158
 
159
      exception
160
         when Constraint_Error =>
161
            Report.Failed ("Constraint_Error raised: #01");
162
         when others           =>
163
            Report.Failed ("Unexpected exception: #01");
164
      end CW_Proc;
165
 
166
   begin
167
      CW_Proc (Tag_Type_Init);
168
   end;
169
 
170
   ----------------------------------------------------------------------
171
 
172
   declare
173
      procedure CW_Proc (P : Tag_Type'Class) is
174
         Operand : Tag_Type'Class := P;
175
      begin
176
         DTag_Type(Operand) := DTag_Type_Value;
177
         Report.Failed ("Constraint_Error not raised: #02");
178
 
179
      exception
180
         when Constraint_Error => null;              -- expected exception
181
         when others           => Report.Failed ("Unexpected exception: #02");
182
      end CW_Proc;
183
 
184
   begin
185
      CW_Proc (Tag_Type_Init);
186
   end;
187
 
188
   ----------------------------------------------------------------------
189
 
190
   declare
191
      procedure CW_Proc (P : Tag_Type'Class) is
192
         Operand : Tag_Type'Class := P;
193
      begin
194
         DDTag_Type(Operand) := DDTag_Type_Value;
195
         Report.Failed ("Constraint_Error not raised: #03");
196
 
197
      exception
198
         when Constraint_Error => null;              -- expected exception
199
         when others           => Report.Failed ("Unexpected exception: #03");
200
      end CW_Proc;
201
 
202
   begin
203
      CW_Proc (Tag_Type_Init);
204
   end;
205
 
206
   ----------------------------------------------------------------------
207
 
208
   declare
209
      procedure CW_Proc (P : Tag_Type'Class) is
210
         Operand : Tag_Type'Class := P;
211
      begin
212
         Tag_Type(Operand) := Tag_Type_Value;
213
 
214
         if Operand not in DTag_Type then
215
            Report.Failed ("Operand has wrong tag: #04");
216
         elsif (Operand /= Tag_Type'Class (DTag_Type_Res))
217
         then                                              -- Check to make
218
           Report.Failed ("Operand has wrong value: #04"); -- sure that C2 was
219
         end if;                                           -- not modified.
220
 
221
      exception
222
         when Constraint_Error =>
223
            Report.Failed ("Constraint_Error raised: #04");
224
         when others           =>
225
            Report.Failed ("Unexpected exception: #04");
226
      end CW_Proc;
227
 
228
   begin
229
      CW_Proc (DTag_Type_Init);
230
   end;
231
 
232
   ----------------------------------------------------------------------
233
 
234
   declare
235
      procedure CW_Proc (P : Tag_Type'Class) is
236
         Operand : Tag_Type'Class := P;
237
      begin
238
         Tag_Type(Operand) := Tag_Type_Value;
239
 
240
         if Operand not in DDTag_Type then
241
            Report.Failed ("Operand has wrong tag: #05");
242
         elsif (Operand /= Tag_Type'Class (DDTag_Type_Res))
243
         then                                              -- Check to make
244
           Report.Failed ("Operand has wrong value: #05"); -- sure that C2, C3
245
         end if;                                           -- were not changed.
246
 
247
      exception
248
         when Constraint_Error =>
249
            Report.Failed ("Constraint_Error raised: #05");
250
         when others           =>
251
            Report.Failed ("Unexpected exception: #05");
252
      end CW_Proc;
253
 
254
   begin
255
      CW_Proc (DDTag_Type_Init);
256
   end;
257
 
258
   Report.Result;
259
 
260
end C460005;

powered by: WebSVN 2.1.0

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