1-- C3A2001.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 an access type may be defined to designate the 28-- class-wide type of an abstract type. Check that the access type 29-- may then be used subsequently with types derived from the abstract 30-- type. Check that dispatching operations dispatch correctly, when 31-- called using values designated by objects of the access type. 32-- 33-- TEST DESCRIPTION: 34-- This test declares an abstract type Breaker in a package, and 35-- then derives from it. The type Basic_Breaker defines the least 36-- possible in order to not be abstract. The type Ground_Fault is 37-- defined to inherit as much as possible, whereas type Special_Breaker 38-- overrides everything it can. The type Special_Breaker also includes 39-- an embedded Basic_Breaker object. The main program then utilizes 40-- each of the three types of breaker, and to ascertain that the 41-- overloading and tagging resolution are correct, each "Create" 42-- procedure is called with a unique value. The diagram below 43-- illustrates the relationships. 44-- 45-- Abstract type: Breaker(1) 46-- | 47-- Basic_Breaker(2) 48-- / \ 49-- Ground_Fault(3) Special_Breaker(4) 50-- 51-- Test structure is a polymorphic linked list, modeling a circuit 52-- as a list of components. The type component is the access type 53-- defined to designate Breaker'Class values. The test then creates 54-- some values, and traverses the list to determine correct operation. 55-- This test is instrumented with a the trace facility found in 56-- foundation F392C00 to simplify the verification process. 57-- 58-- 59-- CHANGE HISTORY: 60-- 06 Dec 94 SAIC ACVC 2.0 61-- 10 Nov 95 SAIC Checked compilation for ACVC 2.0.1 62-- 23 APR 96 SAIC Added pragma Elaborate_All 63-- 26 NOV 96 SAIC Elaborate_Body changed to Elaborate_All 64-- 65--! 66 67with Report; 68with TCTouch; 69package C3A2001_1 is 70 71 type Breaker is abstract tagged private; 72 type Status is ( Power_Off, Power_On, Tripped, Failed ); 73 74 procedure Flip ( The_Breaker : in out Breaker ) is abstract; 75 procedure Trip ( The_Breaker : in out Breaker ) is abstract; 76 procedure Reset( The_Breaker : in out Breaker ) is abstract; 77 procedure Fail ( The_Breaker : in out Breaker ); 78 79 procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status ); 80 81 function Status_Of( The_Breaker : Breaker ) return Status; 82 83private 84 type Breaker is abstract tagged record 85 State : Status := Power_Off; 86 end record; 87end C3A2001_1; 88 89---------------------------------------------------------------------------- 90 91with TCTouch; 92package body C3A2001_1 is 93 procedure Fail( The_Breaker : in out Breaker ) is 94 begin 95 TCTouch.Touch( 'a' ); --------------------------------------------- a 96 The_Breaker.State := Failed; 97 end Fail; 98 99 procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is 100 begin 101 The_Breaker.State := To_State; 102 end Set; 103 104 function Status_Of( The_Breaker : Breaker ) return Status is 105 begin 106 TCTouch.Touch( 'b' ); --------------------------------------------- b 107 return The_Breaker.State; 108 end Status_Of; 109end C3A2001_1; 110 111---------------------------------------------------------------------------- 112 113with C3A2001_1; 114package C3A2001_2 is 115 116 type Basic_Breaker is new C3A2001_1.Breaker with private; 117 118 type Voltages is ( V12, V110, V220, V440 ); 119 type Amps is ( A1, A5, A10, A25, A100 ); 120 121 function Construct( Voltage : Voltages; Amperage : Amps ) 122 return Basic_Breaker; 123 124 procedure Flip ( The_Breaker : in out Basic_Breaker ); 125 procedure Trip ( The_Breaker : in out Basic_Breaker ); 126 procedure Reset( The_Breaker : in out Basic_Breaker ); 127private 128 type Basic_Breaker is new C3A2001_1.Breaker with record 129 Voltage_Level : Voltages := V110; 130 Amperage : Amps; 131 end record; 132end C3A2001_2; 133 134---------------------------------------------------------------------------- 135 136with TCTouch; 137package body C3A2001_2 is 138 function Construct( Voltage : Voltages; Amperage : Amps ) 139 return Basic_Breaker is 140 It : Basic_Breaker; 141 begin 142 TCTouch.Touch( 'c' ); --------------------------------------------- c 143 It.Amperage := Amperage; 144 It.Voltage_Level := Voltage; 145 C3A2001_1.Set( It, C3A2001_1.Power_Off ); 146 return It; 147 end Construct; 148 149 procedure Flip ( The_Breaker : in out Basic_Breaker ) is 150 begin 151 TCTouch.Touch( 'd' ); --------------------------------------------- d 152 case Status_Of( The_Breaker ) is 153 when C3A2001_1.Power_Off => 154 C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On ); 155 when C3A2001_1.Power_On => 156 C3A2001_1.Set( The_Breaker, C3A2001_1.Power_Off ); 157 when C3A2001_1.Tripped | C3A2001_1.Failed => null; 158 end case; 159 end Flip; 160 161 procedure Trip ( The_Breaker : in out Basic_Breaker ) is 162 begin 163 TCTouch.Touch( 'e' ); --------------------------------------------- e 164 C3A2001_1.Set( The_Breaker, C3A2001_1.Tripped ); 165 end Trip; 166 167 procedure Reset( The_Breaker : in out Basic_Breaker ) is 168 begin 169 TCTouch.Touch( 'f' ); --------------------------------------------- f 170 case Status_Of( The_Breaker ) is 171 when C3A2001_1.Power_Off | C3A2001_1.Tripped => 172 C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On ); 173 when C3A2001_1.Power_On | C3A2001_1.Failed => null; 174 end case; 175 end Reset; 176 177end C3A2001_2; 178 179---------------------------------------------------------------------------- 180 181with C3A2001_1,C3A2001_2; 182package C3A2001_3 is 183 use type C3A2001_1.Status; 184 185 type Ground_Fault is new C3A2001_2.Basic_Breaker with private; 186 187 function Construct( Voltage : C3A2001_2.Voltages; 188 Amperage : C3A2001_2.Amps ) 189 return Ground_Fault; 190 191 procedure Set_Trip( The_Breaker : in out Ground_Fault; 192 Capacitance : in Integer ); 193 194private 195 type Ground_Fault is new C3A2001_2.Basic_Breaker with record 196 Capacitance : Integer; 197 end record; 198end C3A2001_3; 199 200---------------------------------------------------------------------------- 201 202with TCTouch; 203package body C3A2001_3 is 204 205 function Construct( Voltage : C3A2001_2.Voltages; 206 Amperage : C3A2001_2.Amps ) 207 return Ground_Fault is 208 begin 209 TCTouch.Touch( 'g' ); --------------------------------------------- g 210 return ( C3A2001_2.Construct( Voltage, Amperage ) 211 with Capacitance => 0 ); 212 end Construct; 213 214 215 procedure Set_Trip( The_Breaker : in out Ground_Fault; 216 Capacitance : in Integer ) is 217 begin 218 TCTouch.Touch( 'h' ); --------------------------------------------- h 219 The_Breaker.Capacitance := Capacitance; 220 end Set_Trip; 221 222end C3A2001_3; 223 224---------------------------------------------------------------------------- 225 226with C3A2001_1, C3A2001_2; 227package C3A2001_4 is 228 229 type Special_Breaker is new C3A2001_2.Basic_Breaker with private; 230 231 function Construct( Voltage : C3A2001_2.Voltages; 232 Amperage : C3A2001_2.Amps ) 233 return Special_Breaker; 234 235 procedure Flip ( The_Breaker : in out Special_Breaker ); 236 procedure Trip ( The_Breaker : in out Special_Breaker ); 237 procedure Reset( The_Breaker : in out Special_Breaker ); 238 procedure Fail ( The_Breaker : in out Special_Breaker ); 239 240 function Status_Of( The_Breaker : Special_Breaker ) return C3A2001_1.Status; 241 function On_Backup( The_Breaker : Special_Breaker ) return Boolean; 242 243private 244 type Special_Breaker is new C3A2001_2.Basic_Breaker with record 245 Backup : C3A2001_2.Basic_Breaker; 246 end record; 247end C3A2001_4; 248 249---------------------------------------------------------------------------- 250 251with TCTouch; 252package body C3A2001_4 is 253 254 function Construct( Voltage : C3A2001_2.Voltages; 255 Amperage : C3A2001_2.Amps ) 256 return Special_Breaker is 257 It: Special_Breaker; 258 procedure Set_Root( It: in out C3A2001_2.Basic_Breaker ) is 259 begin 260 It := C3A2001_2.Construct( Voltage, Amperage ); 261 end Set_Root; 262 begin 263 TCTouch.Touch( 'i' ); --------------------------------------------- i 264 Set_Root( C3A2001_2.Basic_Breaker( It ) ); 265 Set_Root( It.Backup ); 266 return It; 267 end Construct; 268 269 function Status_Of( It: C3A2001_1.Breaker ) return C3A2001_1.Status 270 renames C3A2001_1.Status_Of; 271 272 procedure Flip ( The_Breaker : in out Special_Breaker ) is 273 begin 274 TCTouch.Touch( 'j' ); --------------------------------------------- j 275 case Status_Of( C3A2001_1.Breaker( The_Breaker )) is 276 when C3A2001_1.Power_Off | C3A2001_1.Power_On => 277 C3A2001_2.Flip( C3A2001_2.Basic_Breaker( The_Breaker ) ); 278 when others => 279 C3A2001_2.Flip( The_Breaker.Backup ); 280 end case; 281 end Flip; 282 283 procedure Trip ( The_Breaker : in out Special_Breaker ) is 284 begin 285 TCTouch.Touch( 'k' ); --------------------------------------------- k 286 case Status_Of( C3A2001_1.Breaker( The_Breaker )) is 287 when C3A2001_1.Power_Off => null; 288 when C3A2001_1.Power_On => 289 C3A2001_2.Reset( The_Breaker.Backup ); 290 C3A2001_2.Trip( C3A2001_2.Basic_Breaker( The_Breaker ) ); 291 when others => 292 C3A2001_2.Trip( The_Breaker.Backup ); 293 end case; 294 end Trip; 295 296 procedure Reset( The_Breaker : in out Special_Breaker ) is 297 begin 298 TCTouch.Touch( 'l' ); --------------------------------------------- l 299 case Status_Of( C3A2001_1.Breaker( The_Breaker )) is 300 when C3A2001_1.Tripped => 301 C3A2001_2.Reset( C3A2001_2.Basic_Breaker( The_Breaker )); 302 when C3A2001_1.Failed => 303 C3A2001_2.Reset( The_Breaker.Backup ); 304 when C3A2001_1.Power_On | C3A2001_1.Power_Off => 305 null; 306 end case; 307 end Reset; 308 309 procedure Fail ( The_Breaker : in out Special_Breaker ) is 310 begin 311 TCTouch.Touch( 'm' ); --------------------------------------------- m 312 case Status_Of( C3A2001_1.Breaker( The_Breaker )) is 313 when C3A2001_1.Failed => 314 C3A2001_2.Fail( The_Breaker.Backup ); 315 when others => 316 C3A2001_2.Fail( C3A2001_2.Basic_Breaker( The_Breaker )); 317 C3A2001_2.Reset( The_Breaker.Backup ); 318 end case; 319 end Fail; 320 321 function Status_Of( The_Breaker : Special_Breaker ) 322 return C3A2001_1.Status is 323 begin 324 TCTouch.Touch( 'n' ); --------------------------------------------- n 325 case Status_Of( C3A2001_1.Breaker( The_Breaker )) is 326 when C3A2001_1.Power_On => return C3A2001_1.Power_On; 327 when C3A2001_1.Power_Off => return C3A2001_1.Power_Off; 328 when others => 329 return C3A2001_2.Status_Of( The_Breaker.Backup ); 330 end case; 331 end Status_Of; 332 333 function On_Backup( The_Breaker : Special_Breaker ) return Boolean is 334 use C3A2001_2; 335 use type C3A2001_1.Status; 336 begin 337 return Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Tripped 338 or Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Failed; 339 end On_Backup; 340 341end C3A2001_4; 342 343---------------------------------------------------------------------------- 344 345with C3A2001_1; 346package C3A2001_5 is 347 348 type Component is access C3A2001_1.Breaker'Class; 349 350 type Circuit; 351 type Connection is access Circuit; 352 353 type Circuit is record 354 The_Gadget : Component; 355 Next : Connection; 356 end record; 357 358 procedure Flipper( The_Circuit : Connection ); 359 procedure Tripper( The_Circuit : Connection ); 360 procedure Restore( The_Circuit : Connection ); 361 procedure Failure( The_Circuit : Connection ); 362 363 Short : Connection := null; 364 365end C3A2001_5; 366 367---------------------------------------------------------------------------- 368with Report; 369with TCTouch; 370with C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4; 371 372pragma Elaborate_All( Report, TCTouch, 373 C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4 ); 374 375package body C3A2001_5 is 376 377 function Neww( Breaker: in C3A2001_1.Breaker'Class ) 378 return Component is 379 begin 380 return new C3A2001_1.Breaker'Class'( Breaker ); 381 end Neww; 382 383 procedure Add( Gadget : in Component; 384 To_Circuit : in out Connection) is 385 begin 386 To_Circuit := new Circuit'(Gadget,To_Circuit); 387 end Add; 388 389 procedure Flipper( The_Circuit : Connection ) is 390 Probe : Connection := The_Circuit; 391 begin 392 while Probe /= null loop 393 C3A2001_1.Flip( Probe.The_Gadget.all ); 394 Probe := Probe.Next; 395 end loop; 396 end Flipper; 397 398 procedure Tripper( The_Circuit : Connection ) is 399 Probe : Connection := The_Circuit; 400 begin 401 while Probe /= null loop 402 C3A2001_1.Trip( Probe.The_Gadget.all ); 403 Probe := Probe.Next; 404 end loop; 405 end Tripper; 406 407 procedure Restore( The_Circuit : Connection ) is 408 Probe : Connection := The_Circuit; 409 begin 410 while Probe /= null loop 411 C3A2001_1.Reset( Probe.The_Gadget.all ); 412 Probe := Probe.Next; 413 end loop; 414 end Restore; 415 416 procedure Failure( The_Circuit : Connection ) is 417 Probe : Connection := The_Circuit; 418 begin 419 while Probe /= null loop 420 C3A2001_1.Fail( Probe.The_Gadget.all ); 421 Probe := Probe.Next; 422 end loop; 423 end Failure; 424 425begin 426 Add( Neww( C3A2001_2.Construct( C3A2001_2.V440, C3A2001_2.A5 )), Short ); 427 Add( Neww( C3A2001_3.Construct( C3A2001_2.V110, C3A2001_2.A1 )), Short ); 428 Add( Neww( C3A2001_4.Construct( C3A2001_2.V12, C3A2001_2.A100 )), Short ); 429end C3A2001_5; 430 431---------------------------------------------------------------------------- 432 433with Report; 434with TCTouch; 435with C3A2001_5; 436procedure C3A2001 is 437 438begin -- Main test procedure. 439 440 Report.Test ("C3A2001", "Check that an abstract type can be declared " & 441 "and used. Check actual subprograms dispatch correctly" ); 442 443 -- This Validate call must be _after_ the call to Report.Test 444 TCTouch.Validate( "cgcicc", "Adding" ); 445 446 C3A2001_5.Flipper( C3A2001_5.Short ); 447 TCTouch.Validate( "jbdbdbdb", "Flipping" ); 448 449 C3A2001_5.Tripper( C3A2001_5.Short ); 450 TCTouch.Validate( "kbfbeee", "Tripping" ); 451 452 C3A2001_5.Restore( C3A2001_5.Short ); 453 TCTouch.Validate( "lbfbfbfb", "Restoring" ); 454 455 C3A2001_5.Failure( C3A2001_5.Short ); 456 TCTouch.Validate( "mbafbaa", "Circuits Failing" ); 457 458 Report.Result; 459 460end C3A2001; 461