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