1-- 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--!
55package 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
81end C460004_0;
82
83
84     --==================================================================--
85
86with Report;
87package 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
126end C460004_0;
127
128
129     --==================================================================--
130
131
132with C460004_0;
133use  C460004_0;
134
135with Report;
136procedure 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
146begin
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
335end C460004;
336