1-- 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
68package 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
90end C460005_0;
91
92
93     --==================================================================--
94
95
96package 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
117end C460005_0;
118
119
120     --==================================================================--
121
122
123with C460005_0;
124use  C460005_0;
125
126with Report;
127procedure 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
141begin
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
260end C460005;
261