1-- CDD2A01.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- The Ada Conformity Assessment Authority (ACAA) holds unlimited 6-- rights in the software and documentation contained herein. Unlimited 7-- rights are the same as those granted by the U.S. Government for older 8-- parts of the Ada Conformity Assessment Test Suite, and are defined 9-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA 10-- intends to confer upon all recipients unlimited rights equal to those 11-- held by the ACAA. These rights include rights to use, duplicate, 12-- release or disclose the released technical data and computer software 13-- in whole or in part, in any manner and for any purpose whatsoever, and 14-- to have or permit others 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 the Read and Write attributes for a type extension are created 28-- from the parent type's attribute (which may be user-defined) and those 29-- for the extension components. Also check that the default Input and 30-- Output attributes are used for a type extension, even if the parent 31-- type's attribute is user-defined. (Defect Report 8652/0040, 32-- as reflected in Technical Corrigendum 1, penultimate sentence of 33-- 13.13.2(9/1) and 13.13.2(25/1)). 34-- 35-- CHANGE HISTORY: 36-- 30 JUL 2001 PHL Initial version. 37-- 5 DEC 2001 RLB Reformatted for ACATS. 38-- 39--! 40with Ada.Streams; 41use Ada.Streams; 42with FDD2A00; 43use FDD2A00; 44with Report; 45use Report; 46procedure CDD2A01 is 47 48 Input_Output_Error : exception; 49 50 type Int is range 1 .. 1000; 51 type Str is array (Int range <>) of Character; 52 53 procedure Read (Stream : access Root_Stream_Type'Class; 54 Item : out Int'Base); 55 procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base); 56 function Input (Stream : access Root_Stream_Type'Class) return Int'Base; 57 procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base); 58 59 for Int'Read use Read; 60 for Int'Write use Write; 61 for Int'Input use Input; 62 for Int'Output use Output; 63 64 65 type Parent (D1, D2 : Int; B : Boolean) is tagged 66 record 67 S : Str (D1 .. D2); 68 case B is 69 when False => 70 C1 : Integer; 71 when True => 72 C2 : Float; 73 end case; 74 end record; 75 76 procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent); 77 procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent); 78 function Input (Stream : access Root_Stream_Type'Class) return Parent; 79 procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent); 80 81 for Parent'Read use Read; 82 for Parent'Write use Write; 83 for Parent'Input use Input; 84 for Parent'Output use Output; 85 86 87 procedure Actual_Read 88 (Stream : access Root_Stream_Type'Class; Item : out Int) is 89 begin 90 Integer'Read (Stream, Integer (Item)); 91 end Actual_Read; 92 93 procedure Actual_Write 94 (Stream : access Root_Stream_Type'Class; Item : Int) is 95 begin 96 Integer'Write (Stream, Integer (Item)); 97 end Actual_Write; 98 99 function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is 100 begin 101 return Int (Integer'Input (Stream)); 102 end Actual_Input; 103 104 procedure Actual_Output 105 (Stream : access Root_Stream_Type'Class; Item : Int) is 106 begin 107 Integer'Output (Stream, Integer (Item)); 108 end Actual_Output; 109 110 111 procedure Actual_Read 112 (Stream : access Root_Stream_Type'Class; Item : out Parent) is 113 begin 114 case Item.B is 115 when False => 116 Item.C1 := 7; 117 when True => 118 Float'Read (Stream, Item.C2); 119 end case; 120 Str'Read (Stream, Item.S); 121 end Actual_Read; 122 123 procedure Actual_Write 124 (Stream : access Root_Stream_Type'Class; Item : Parent) is 125 begin 126 case Item.B is 127 when False => 128 null; -- Don't write C1 129 when True => 130 Float'Write (Stream, Item.C2); 131 end case; 132 Str'Write (Stream, Item.S); 133 end Actual_Write; 134 135 function Actual_Input 136 (Stream : access Root_Stream_Type'Class) return Parent is 137 X : Parent (1, 1, True); 138 begin 139 raise Input_Output_Error; 140 return X; 141 end Actual_Input; 142 143 procedure Actual_Output 144 (Stream : access Root_Stream_Type'Class; Item : Parent) is 145 begin 146 raise Input_Output_Error; 147 end Actual_Output; 148 149 package Int_Ops is new Counting_Stream_Ops (T => Int'Base, 150 Actual_Write => Actual_Write, 151 Actual_Input => Actual_Input, 152 Actual_Read => Actual_Read, 153 Actual_Output => Actual_Output); 154 155 package Parent_Ops is 156 new Counting_Stream_Ops (T => Parent, 157 Actual_Write => Actual_Write, 158 Actual_Input => Actual_Input, 159 Actual_Read => Actual_Read, 160 Actual_Output => Actual_Output); 161 162 procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base) 163 renames Int_Ops.Read; 164 procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base) 165 renames Int_Ops.Write; 166 function Input (Stream : access Root_Stream_Type'Class) return Int'Base 167 renames Int_Ops.Input; 168 procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base) 169 renames Int_Ops.Output; 170 171 procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent) 172 renames Parent_Ops.Read; 173 procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent) 174 renames Parent_Ops.Write; 175 function Input (Stream : access Root_Stream_Type'Class) return Parent 176 renames Parent_Ops.Input; 177 procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent) 178 renames Parent_Ops.Output; 179 180 type Derived1 is new Parent with 181 record 182 C3 : Int; 183 end record; 184 185 type Derived2 (D : Int) is new Parent (D1 => D, 186 D2 => D, 187 B => False) with 188 record 189 C3 : Int; 190 end record; 191 192begin 193 Test ("CDD2A01", 194 "Check that the Read and Write attributes for a type " & 195 "extension are created from the parent type's " & 196 "attribute (which may be user-defined) and those for the " & 197 "extension components; also check that the default input " & 198 "and output attributes are used for a type extension, even " & 199 "if the parent type's attribute is user-defined"); 200 201 Test1: 202 declare 203 S : aliased My_Stream (1000); 204 X1 : Derived1 (D1 => Int (Ident_Int (2)), 205 D2 => Int (Ident_Int (5)), 206 B => Ident_Bool (True)); 207 Y1 : Derived1 := (D1 => 3, 208 D2 => 6, 209 B => False, 210 S => Str (Ident_Str ("3456")), 211 C1 => Ident_Int (100), 212 C3 => Int (Ident_Int (88))); 213 X2 : Derived1 (D1 => Int (Ident_Int (2)), 214 D2 => Int (Ident_Int (5)), 215 B => Ident_Bool (True)); 216 begin 217 X1.S := Str (Ident_Str ("bcde")); 218 X1.C2 := Float (Ident_Int (4)); 219 X1.C3 := Int (Ident_Int (99)); 220 221 Derived1'Write (S'Access, X1); 222 if Int_Ops.Get_Counts /= 223 (Read => 0, Write => 1, Input => 0, Output => 0) then 224 Failed ("Error writing extension components - 1"); 225 end if; 226 if Parent_Ops.Get_Counts /= 227 (Read => 0, Write => 1, Input => 0, Output => 0) then 228 Failed ("Didn't call parent type's Write - 1"); 229 end if; 230 231 Derived1'Read (S'Access, X2); 232 if Int_Ops.Get_Counts /= 233 (Read => 1, Write => 1, Input => 0, Output => 0) then 234 Failed ("Error reading extension components - 1"); 235 end if; 236 if Parent_Ops.Get_Counts /= 237 (Read => 1, Write => 1, Input => 0, Output => 0) then 238 Failed ("Didn't call inherited Read - 1"); 239 end if; 240 241 if X2 /= (D1 => 2, 242 D2 => 5, 243 B => True, 244 S => Str (Ident_Str ("bcde")), 245 C2 => Float (Ident_Int (4)), 246 C3 => Int (Ident_Int (99))) then 247 Failed 248 ("Inherited Read and Write are not inverses of each other - 1"); 249 end if; 250 251 begin 252 Derived1'Output (S'Access, Y1); 253 if Int_Ops.Get_Counts /= 254 (Read => 1, Write => 4, Input => 0, Output => 0) then 255 Failed ("Error writing extension components - 2"); 256 end if; 257 if Parent_Ops.Get_Counts /= 258 (Read => 1, Write => 2, Input => 0, Output => 0) then 259 Failed ("Didn't call inherited Write - 2"); 260 end if; 261 exception 262 when Input_Output_Error => 263 Failed ("Did call inherited Output - 2"); 264 end; 265 266 begin 267 declare 268 Y2 : Derived1 := Derived1'Input (S'Access); 269 begin 270 if Int_Ops.Get_Counts /= 271 (Read => 4, Write => 4, Input => 0, Output => 0) then 272 Failed ("Error reading extension components - 2"); 273 end if; 274 if Parent_Ops.Get_Counts /= 275 (Read => 2, Write => 2, Input => 0, Output => 0) then 276 Failed ("Didn't call inherited Read - 2"); 277 end if; 278 if Y2 /= (D1 => 3, 279 D2 => 6, 280 B => False, 281 S => Str (Ident_Str ("3456")), 282 C1 => Ident_Int (7), 283 C3 => Int (Ident_Int (88))) then 284 Failed 285 ("Input and Output are not inverses of each other - 2"); 286 end if; 287 end; 288 exception 289 when Input_Output_Error => 290 Failed ("Did call inherited Input - 2"); 291 end; 292 293 end Test1; 294 295 Test2: 296 declare 297 S : aliased My_Stream (1000); 298 X1 : Derived2 (D => Int (Ident_Int (7))); 299 Y1 : Derived2 := (D => 8, 300 S => Str (Ident_Str ("8")), 301 C1 => Ident_Int (200), 302 C3 => Int (Ident_Int (77))); 303 X2 : Derived2 (D => Int (Ident_Int (7))); 304 begin 305 X1.S := Str (Ident_Str ("g")); 306 X1.C1 := Ident_Int (4); 307 X1.C3 := Int (Ident_Int (666)); 308 309 Derived2'Write (S'Access, X1); 310 if Int_Ops.Get_Counts /= 311 (Read => 4, Write => 5, Input => 0, Output => 0) then 312 Failed ("Error writing extension components - 3"); 313 end if; 314 if Parent_Ops.Get_Counts /= 315 (Read => 2, Write => 3, Input => 0, Output => 0) then 316 Failed ("Didn't call inherited Write - 3"); 317 end if; 318 319 Derived2'Read (S'Access, X2); 320 if Int_Ops.Get_Counts /= 321 (Read => 5, Write => 5, Input => 0, Output => 0) then 322 Failed ("Error reading extension components - 3"); 323 end if; 324 if Parent_Ops.Get_Counts /= 325 (Read => 3, Write => 3, Input => 0, Output => 0) then 326 Failed ("Didn't call inherited Read - 3"); 327 end if; 328 329 if X2 /= (D => 7, 330 S => Str (Ident_Str ("g")), 331 C1 => Ident_Int (7), 332 C3 => Int (Ident_Int (666))) then 333 Failed ("Read and Write are not inverses of each other - 3"); 334 end if; 335 336 begin 337 Derived2'Output (S'Access, Y1); 338 if Int_Ops.Get_Counts /= 339 (Read => 5, Write => 7, Input => 0, Output => 0) then 340 Failed ("Error writing extension components - 4"); 341 end if; 342 if Parent_Ops.Get_Counts /= 343 (Read => 3, Write => 4, Input => 0, Output => 0) then 344 Failed ("Didn't call inherited Write - 4"); 345 end if; 346 exception 347 when Input_Output_Error => 348 Failed ("Did call inherited Output - 4"); 349 end; 350 351 begin 352 declare 353 Y2 : Derived2 := Derived2'Input (S'Access); 354 begin 355 if Int_Ops.Get_Counts /= 356 (Read => 7, Write => 7, Input => 0, Output => 0) then 357 Failed ("Error reading extension components - 4"); 358 end if; 359 if Parent_Ops.Get_Counts /= 360 (Read => 4, Write => 4, Input => 0, Output => 0) then 361 Failed ("Didn't call inherited Read - 4"); 362 end if; 363 if Y2 /= (D => 8, 364 S => Str (Ident_Str ("8")), 365 C1 => Ident_Int (7), 366 C3 => Int (Ident_Int (77))) then 367 Failed 368 ("Input and Output are not inverses of each other - 4"); 369 end if; 370 end; 371 exception 372 when Input_Output_Error => 373 Failed ("Did call inherited Input - 4"); 374 end; 375 376 end Test2; 377 378 Result; 379end CDD2A01; 380