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
50with Report; pragma Elaborate_All (Report);
51package 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
99end C390010_0;
100
101-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C390010_0
102
103with Report;
104with TCTouch;
105package 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
150end C390010_0;
151
152------------------------------------------------------------------- C390010
153
154with Report;
155with TCTouch;
156with C390010_0;
157procedure 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
179begin  -- 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
216end C390010;
217