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