| -- C390004.A |
| -- |
| -- Grant of Unlimited Rights |
| -- |
| -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, |
| -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained |
| -- unlimited rights in the software and documentation contained herein. |
| -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making |
| -- this public release, the Government intends to confer upon all |
| -- recipients unlimited rights equal to those held by the Government. |
| -- These rights include rights to use, duplicate, release or disclose the |
| -- released technical data and computer software in whole or in part, in |
| -- any manner and for any purpose whatsoever, and to have or permit others |
| -- to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- |
| -- OBJECTIVE: |
| -- Check that the tags of allocated objects correctly identify the |
| -- type of the allocated object. Check that the tag corresponds |
| -- correctly to the value resulting from both normal and view |
| -- conversion. Check that the tags of accessed values designating |
| -- aliased objects correctly identify the type of the object. Check |
| -- that the tag of a function result correctly evaluates. Check this |
| -- for class-wide functions. The tag of a class-wide function result |
| -- should be the tag appropriate to the actual value returned, not the |
| -- tag of the ancestor type. |
| -- |
| -- TEST DESCRIPTION: |
| -- This test defines a class hierarchy of types, with reference |
| -- semantics (an access type to the class-wide type). Similar in |
| -- structure to C392005, this test checks that dynamic allocation does |
| -- not adversely impact the tagging of types. |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- |
| --! |
| |
| package C390004_1 is -- DMV |
| type Equipment is ( T_Veh, T_Car, T_Con, T_Jep ); |
| |
| type Vehicle is tagged record |
| Wheels : Natural := 4; |
| Parked : Boolean := False; |
| end record; |
| |
| function Wheels ( It: Vehicle ) return Natural; |
| procedure Park ( It: in out Vehicle ); |
| procedure UnPark ( It: in out Vehicle ); |
| procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ); |
| procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ); |
| |
| type Car is new Vehicle with record |
| Passengers : Natural := 0; |
| end record; |
| |
| function Passengers ( It: Car ) return Natural; |
| procedure Load_Passengers( It: in out Car; To_Count: in Natural ); |
| procedure Park ( It: in out Car ); |
| procedure TC_Check ( It: in Car; To_Equip: in Equipment ); |
| |
| type Convertible is new Car with record |
| Top_Up : Boolean := True; |
| end record; |
| |
| function Top_Up ( It: Convertible ) return Boolean; |
| procedure Lower_Top( It: in out Convertible ); |
| procedure Park ( It: in out Convertible ); |
| procedure Raise_Top( It: in out Convertible ); |
| procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ); |
| |
| type Jeep is new Convertible with record |
| Windshield_Up : Boolean := True; |
| end record; |
| |
| function Windshield_Up ( It: Jeep ) return Boolean; |
| procedure Lower_Windshield( It: in out Jeep ); |
| procedure Park ( It: in out Jeep ); |
| procedure Raise_Windshield( It: in out Jeep ); |
| procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ); |
| |
| end C390004_1; |
| |
| with Report; |
| package body C390004_1 is |
| |
| procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is |
| begin |
| It.Wheels := To_Count; |
| end Set_Wheels; |
| |
| function Wheels( It: Vehicle ) return Natural is |
| begin |
| return It.Wheels; |
| end Wheels; |
| |
| procedure Park ( It: in out Vehicle ) is |
| begin |
| It.Parked := True; |
| end Park; |
| |
| procedure UnPark ( It: in out Vehicle ) is |
| begin |
| It.Parked := False; |
| end UnPark; |
| |
| procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ) is |
| begin |
| if To_Equip /= T_Veh then |
| Report.Failed ("Failed, called Vehicle for " |
| & Equipment'Image(To_Equip)); |
| end if; |
| end TC_Check; |
| |
| procedure TC_Check ( It: in Car; To_Equip: in Equipment ) is |
| begin |
| if To_Equip /= T_Car then |
| Report.Failed ("Failed, called Car for " |
| & Equipment'Image(To_Equip)); |
| end if; |
| end TC_Check; |
| |
| procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ) is |
| begin |
| if To_Equip /= T_Con then |
| Report.Failed ("Failed, called Convertible for " |
| & Equipment'Image(To_Equip)); |
| end if; |
| end TC_Check; |
| |
| procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ) is |
| begin |
| if To_Equip /= T_Jep then |
| Report.Failed ("Failed, called Jeep for " |
| & Equipment'Image(To_Equip)); |
| end if; |
| end TC_Check; |
| |
| procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is |
| begin |
| It.Passengers := To_Count; |
| UnPark( It ); |
| end Load_Passengers; |
| |
| procedure Park( It: in out Car ) is |
| begin |
| It.Passengers := 0; |
| Park( Vehicle( It ) ); |
| end Park; |
| |
| function Passengers( It: Car ) return Natural is |
| begin |
| return It.Passengers; |
| end Passengers; |
| |
| procedure Raise_Top( It: in out Convertible ) is |
| begin |
| It.Top_Up := True; |
| end Raise_Top; |
| |
| procedure Lower_Top( It: in out Convertible ) is |
| begin |
| It.Top_Up := False; |
| end Lower_Top; |
| |
| function Top_Up ( It: Convertible ) return Boolean is |
| begin |
| return It.Top_Up; |
| end Top_Up; |
| |
| procedure Park ( It: in out Convertible ) is |
| begin |
| It.Top_Up := True; |
| Park( Car( It ) ); |
| end Park; |
| |
| procedure Raise_Windshield( It: in out Jeep ) is |
| begin |
| It.Windshield_Up := True; |
| end Raise_Windshield; |
| |
| procedure Lower_Windshield( It: in out Jeep ) is |
| begin |
| It.Windshield_Up := False; |
| end Lower_Windshield; |
| |
| function Windshield_Up( It: Jeep ) return Boolean is |
| begin |
| return It.Windshield_Up; |
| end Windshield_Up; |
| |
| procedure Park( It: in out Jeep ) is |
| begin |
| It.Windshield_Up := True; |
| Park( Convertible( It ) ); |
| end Park; |
| end C390004_1; |
| |
| with Report; |
| with Ada.Tags; |
| with C390004_1; |
| procedure C390004 is |
| package DMV renames C390004_1; |
| |
| The_Vehicle : aliased DMV.Vehicle; |
| The_Car : aliased DMV.Car; |
| The_Convertible : aliased DMV.Convertible; |
| The_Jeep : aliased DMV.Jeep; |
| |
| type C_Reference is access all DMV.Car'Class; |
| type V_Reference is access all DMV.Vehicle'Class; |
| |
| Designator : V_Reference; |
| Storage : Natural; |
| |
| procedure Valet( It: in out DMV.Vehicle'Class ) is |
| begin |
| DMV.Park( It ); |
| end Valet; |
| |
| procedure TC_Match( Object: DMV.Vehicle'Class; |
| Taglet: Ada.Tags.Tag; |
| Where : String ) is |
| use Ada.Tags; |
| begin |
| if Object'Tag /= Taglet then |
| Report.Failed("Tag mismatch: " & Where); |
| end if; |
| end TC_Match; |
| |
| procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is |
| begin |
| if DMV.Wheels( It ) /= 1 or not It.Parked then |
| Report.Failed ("Failed Vehicle " & TC_Message); |
| end if; |
| end Parking_Validation; |
| |
| procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is |
| begin |
| if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0 |
| or not It.Parked then |
| Report.Failed ("Failed Car " & TC_Message); |
| end if; |
| end Parking_Validation; |
| |
| procedure Parking_Validation( It: DMV.Convertible; |
| TC_Message: String ) is |
| begin |
| if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0 |
| or not DMV.Top_Up( It ) or not It.Parked then |
| Report.Failed ("Failed Convertible " & TC_Message); |
| end if; |
| end Parking_Validation; |
| |
| procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is |
| begin |
| if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0 |
| or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It ) |
| or not It.Parked then |
| Report.Failed ("Failed Jeep " & TC_Message); |
| end if; |
| end Parking_Validation; |
| |
| function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag ) |
| return DMV.Vehicle'Class is |
| This_Machine : DMV.Vehicle'Class := It.all; |
| begin |
| TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); |
| Storage := DMV.Wheels( This_Machine ); |
| return This_Machine; |
| end Wash; |
| |
| function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag ) |
| return DMV.Car'Class is |
| This_Machine : DMV.Car'Class := It.all; |
| begin |
| TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); |
| Storage := DMV.Wheels( This_Machine ); |
| return This_Machine; |
| end Wash; |
| |
| begin |
| |
| Report.Test( "C390004", "Check that the tags of allocated objects " |
| & "correctly identify the type of the allocated " |
| & "object. Check that tags resulting from " |
| & "normal and view conversions. Check tags of " |
| & "accessed values designating aliased objects. " |
| & "Check function result tags" ); |
| |
| DMV.Set_Wheels( The_Vehicle, 1 ); |
| DMV.Set_Wheels( The_Car, 2 ); |
| DMV.Set_Wheels( The_Convertible, 3 ); |
| DMV.Set_Wheels( The_Jeep, 4 ); |
| |
| Valet( The_Vehicle ); |
| Valet( The_Car ); |
| Valet( The_Convertible ); |
| Valet( The_Jeep ); |
| |
| Parking_Validation( The_Vehicle, "setup" ); |
| Parking_Validation( The_Car, "setup" ); |
| Parking_Validation( The_Convertible, "setup" ); |
| Parking_Validation( The_Jeep, "setup" ); |
| |
| -- Check that the tags of allocated objects correctly identify the type |
| -- of the allocated object. |
| |
| Designator := new DMV.Vehicle; |
| DMV.TC_Check( Designator.all, DMV.T_Veh ); |
| TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" ); |
| |
| Designator := new DMV.Car; |
| DMV.TC_Check( Designator.all, DMV.T_Car ); |
| TC_Match( Designator.all, DMV.Car'Tag, "allocated Car"); |
| |
| Designator := new DMV.Convertible; |
| DMV.TC_Check( Designator.all, DMV.T_Con ); |
| TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" ); |
| |
| Designator := new DMV.Jeep; |
| DMV.TC_Check( Designator.all, DMV.T_Jep ); |
| TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" ); |
| |
| -- Check that view conversion causes the correct dispatch |
| DMV.TC_Check( DMV.Vehicle( The_Jeep ), DMV.T_Veh ); |
| DMV.TC_Check( DMV.Car( The_Jeep ), DMV.T_Car ); |
| DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con ); |
| |
| -- And that view conversion does not change the tag |
| TC_Match( DMV.Vehicle( The_Jeep ), DMV.Jeep'Tag, "View Conv Veh" ); |
| TC_Match( DMV.Car( The_Jeep ), DMV.Jeep'Tag, "View Conv Car" ); |
| TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" ); |
| |
| -- Check that the tags of accessed values designating aliased objects |
| -- correctly identify the type of the object. |
| Designator := The_Vehicle'Access; |
| DMV.TC_Check( Designator.all, DMV.T_Veh ); |
| TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" ); |
| |
| Designator := The_Car'Access; |
| DMV.TC_Check( Designator.all, DMV.T_Car ); |
| TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" ); |
| |
| Designator := The_Convertible'Access; |
| DMV.TC_Check( Designator.all, DMV.T_Con ); |
| TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" ); |
| |
| Designator := The_Jeep'Access; |
| DMV.TC_Check( Designator.all, DMV.T_Jep ); |
| TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" ); |
| |
| -- Check that the tag of a function result correctly evaluates. |
| -- Check this for class-wide functions. The tag of a class-wide |
| -- function result should be the tag appropriate to the actual value |
| -- returned, not the tag of the ancestor type. |
| Function_Check: declare |
| A_Vehicle : V_Reference := new DMV.Vehicle'( The_Vehicle ); |
| A_Car : C_Reference := new DMV.Car'( The_Car ); |
| A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible ); |
| A_Jeep : C_Reference := new DMV.Jeep'( The_Jeep ); |
| begin |
| DMV.Unpark( A_Vehicle.all ); |
| DMV.Load_Passengers( A_Car.all, 5 ); |
| DMV.Load_Passengers( A_Convertible.all, 6 ); |
| DMV.Load_Passengers( A_Jeep.all, 7 ); |
| DMV.Lower_Top( DMV.Convertible(A_Convertible.all) ); |
| DMV.Lower_Top( DMV.Jeep(A_Jeep.all) ); |
| DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) ); |
| |
| if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4 |
| or Storage /= 4 then |
| Report.Failed("Did not correctly wash Jeep"); |
| end if; |
| |
| if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3 |
| or Storage /= 3 then |
| Report.Failed("Did not correctly wash Convertible"); |
| end if; |
| |
| if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2 |
| or Storage /= 2 then |
| Report.Failed("Did not correctly wash Car"); |
| end if; |
| |
| if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1 |
| or Storage /= 1 then |
| Report.Failed("Did not correctly wash Vehicle"); |
| end if; |
| |
| end Function_Check; |
| |
| Report.Result; |
| end C390004; |
