|
111
|
1 -- C390010.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 S is a subtype of a tagged type T, and if S is
|
|
|
28 -- constrained, then the allowable values of S'Class are only those
|
|
|
29 -- that, when converted to T, belong to S.
|
|
|
30 --
|
|
|
31 -- TEST DESCRIPTION:
|
|
|
32 -- This test defines a small tagged hierarchy of discriminated tagged
|
|
|
33 -- records, and constrained subtypes of those tagged record types.
|
|
|
34 -- It then uses access to the classwide of the constrained subtype
|
|
|
35 -- to check the objective.
|
|
|
36 --
|
|
|
37 --
|
|
|
38 -- CHANGE HISTORY:
|
|
|
39 -- 09 APR 96 SAIC Initial version
|
|
|
40 -- 03 NOV 96 SAIC Revised for 2.1 release
|
|
|
41 -- 31 DEC 97 EDS Restored use of intermediate access variable
|
|
|
42 -- to eliminate raising of Program_Error
|
|
|
43 -- 13 SEP 99 RLB Repaired previous change to avoid premature
|
|
|
44 -- subtype check.
|
|
|
45 -- 28 JUN 02 RLB Added pragma Elaborate_All (Report);.
|
|
|
46 --!
|
|
|
47
|
|
|
48 ----------------------------------------------------------------- C390010_0
|
|
|
49
|
|
|
50 with Report; pragma Elaborate_All (Report);
|
|
|
51 package C390010_0 is
|
|
|
52
|
|
|
53 -- the defined subprograms will allow checking the placement of
|
|
|
54 -- constraint_checks
|
|
|
55
|
|
|
56 -- define a discriminated tagged type, and a constrained subtype of
|
|
|
57 -- that type:
|
|
|
58
|
|
|
59 type Discr_Tag_Record( Disc: Boolean ) is tagged record
|
|
|
60 FieldA : Character := 'A';
|
|
|
61 case Disc is
|
|
|
62 when True => FieldB : Character := 'B';
|
|
|
63 when False => FieldC : Character := 'C';
|
|
|
64 end case;
|
|
|
65 end record;
|
|
|
66
|
|
|
67 procedure Dispatching_Op( DTO : in out Discr_Tag_Record );
|
|
|
68
|
|
|
69 Authentic : Boolean := Report.Ident_Bool( True );
|
|
|
70
|
|
|
71 subtype True_Record is Discr_Tag_Record( Authentic );
|
|
|
72
|
|
|
73
|
|
|
74 -- derive a type, "passing through" one discriminant, adding one
|
|
|
75 -- discriminant, and a constrained subtype of THAT type:
|
|
|
76
|
|
|
77 type Derived_Record( Disc1, Disc2: Boolean ) is
|
|
|
78 new Discr_Tag_Record( Disc1 ) with record
|
|
|
79 FieldD : Character := 'D';
|
|
|
80 case Disc2 is
|
|
|
81 when True => FieldE : Character := 'E';
|
|
|
82 when False => FieldF : Character := 'F';
|
|
|
83 end case;
|
|
|
84 end record;
|
|
|
85
|
|
|
86 procedure Dispatching_Op( DR : in out Derived_Record );
|
|
|
87
|
|
|
88 subtype True_True_Derived is Derived_Record( Authentic, Authentic );
|
|
|
89
|
|
|
90
|
|
|
91 -- now, define an access to classwide type, using the classwide from the
|
|
|
92 -- constrained subtype of the root (or parent) type:
|
|
|
93
|
|
|
94 type Subtype_Parent_Class_Access is access all True_Record'Class;
|
|
|
95 type Parent_Class_Access is access all Discr_Tag_Record'Class;
|
|
|
96
|
|
|
97 procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access );
|
|
|
98
|
|
|
99 end C390010_0;
|
|
|
100
|
|
|
101 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C390010_0
|
|
|
102
|
|
|
103 with Report;
|
|
|
104 with TCTouch;
|
|
|
105 package body C390010_0 is
|
|
|
106
|
|
|
107 procedure Dispatching_Op( DTO : in out Discr_Tag_Record ) is
|
|
|
108 begin
|
|
|
109 TCTouch.Touch('1'); --------------------------------------------------- 1
|
|
|
110 if DTO.Disc then
|
|
|
111 TCTouch.Touch(DTO.FieldB); ------------------------------------------ B
|
|
|
112 else
|
|
|
113 TCTouch.Touch(DTO.FieldC); ------------------------------------------ C
|
|
|
114 end if;
|
|
|
115 end Dispatching_Op;
|
|
|
116
|
|
|
117
|
|
|
118 procedure Dispatching_Op( DR : in out Derived_Record ) is
|
|
|
119 begin
|
|
|
120 TCTouch.Touch('2'); --------------------------------------------------- 2
|
|
|
121 if DR.Disc1 then
|
|
|
122 TCTouch.Touch(DR.FieldB); ------------------------------------------ B
|
|
|
123 else
|
|
|
124 TCTouch.Touch(DR.FieldC); ------------------------------------------ C
|
|
|
125 end if;
|
|
|
126 if DR.Disc2 then
|
|
|
127 TCTouch.Touch(DR.FieldE); ------------------------------------------ E
|
|
|
128 else
|
|
|
129 TCTouch.Touch(DR.FieldF); ------------------------------------------ F
|
|
|
130 end if;
|
|
|
131 end Dispatching_Op;
|
|
|
132
|
|
|
133 procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ) is
|
|
|
134 begin
|
|
|
135
|
|
|
136 -- the following line is the "heart" of this test, objects of all types
|
|
|
137 -- covered by the classwide type will be passed to this subprogram in
|
|
|
138 -- the execution of the test.
|
|
|
139 if SPCA.Disc then
|
|
|
140 TCTouch.Touch(SPCA.FieldB); ------------------------------------------ B
|
|
|
141 else
|
|
|
142 TCTouch.Touch(SPCA.FieldC); ------------------------------------------ C
|
|
|
143 end if;
|
|
|
144
|
|
|
145 Dispatching_Op( SPCA.all ); -- check that this dispatches correctly,
|
|
|
146 -- with discriminants correctly represented
|
|
|
147
|
|
|
148 end PCW_Op;
|
|
|
149
|
|
|
150 end C390010_0;
|
|
|
151
|
|
|
152 ------------------------------------------------------------------- C390010
|
|
|
153
|
|
|
154 with Report;
|
|
|
155 with TCTouch;
|
|
|
156 with C390010_0;
|
|
|
157 procedure C390010 is
|
|
|
158
|
|
|
159 package CP renames C390010_0;
|
|
|
160
|
|
|
161 procedure Check_Element( Item : access CP.Discr_Tag_Record'Class ) is
|
|
|
162 begin
|
|
|
163
|
|
|
164 -- the implicit conversion from the general access parameter to the more
|
|
|
165 -- constrained subtype access type in the following call should cause
|
|
|
166 -- Constraint_Error in the cases where the object is not correctly
|
|
|
167 -- constrained
|
|
|
168
|
|
|
169 CP.PCW_Op( Item.all'Access );
|
|
|
170
|
|
|
171 exception
|
|
|
172 when Constraint_Error => TCTouch.Touch('X'); -------------------------- X
|
|
|
173 when others => Report.Failed("Unanticipated exception in Check_Element");
|
|
|
174
|
|
|
175 end Check_Element;
|
|
|
176
|
|
|
177 An_Item : CP.Parent_Class_Access;
|
|
|
178
|
|
|
179 begin -- Main test procedure.
|
|
|
180
|
|
|
181 Report.Test ("C390010", "Check that if S is a subtype of a tagged type " &
|
|
|
182 "T, and if S is constrained, then the allowable " &
|
|
|
183 "values of S'Class are only those that, when " &
|
|
|
184 "converted to T, belong to S" );
|
|
|
185
|
|
|
186 An_Item := new CP.Discr_Tag_Record(True);
|
|
|
187 Check_Element( An_Item );
|
|
|
188 TCTouch.Validate("B1B","Case 1");
|
|
|
189
|
|
|
190 An_Item := new CP.Discr_Tag_Record(False);
|
|
|
191 Check_Element( An_Item );
|
|
|
192 TCTouch.Validate("X","Case 2");
|
|
|
193
|
|
|
194 An_Item := new CP.True_Record;
|
|
|
195 Check_Element( An_Item );
|
|
|
196 TCTouch.Validate("B1B","Case 3");
|
|
|
197
|
|
|
198 An_Item := new CP.Derived_Record(False, False);
|
|
|
199 Check_Element( An_Item );
|
|
|
200 TCTouch.Validate("X","Case 4");
|
|
|
201
|
|
|
202 An_Item := new CP.Derived_Record(False, True);
|
|
|
203 Check_Element( An_Item );
|
|
|
204 TCTouch.Validate("X","Case 5");
|
|
|
205
|
|
|
206 An_Item := new CP.Derived_Record(True, False);
|
|
|
207 Check_Element( An_Item );
|
|
|
208 TCTouch.Validate("B2BF","Case 6");
|
|
|
209
|
|
|
210 An_Item := new CP.True_True_Derived;
|
|
|
211 Check_Element( An_Item );
|
|
|
212 TCTouch.Validate("B2BE","Case 7");
|
|
|
213
|
|
|
214 Report.Result;
|
|
|
215
|
|
|
216 end C390010;
|
