-- C393012.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 a non-abstract subprogram of an abstract type can be -- called with a controlling operand that is a type conversion to -- the abstract type. -- -- Check that converting to the class-wide type of an abstract type -- inside an operation of that type causes a "redispatch" of the -- called operation. -- -- TEST DESCRIPTION: -- This test defines an abstract type, and further derives types from it. -- The key feature of this test is in the "Display" procedures where -- the bodies of these procedures convert an object to the class-wide -- type of the root abstract type, causing a "redispatch". -- -- -- CHANGE HISTORY: -- 06 Dec 94 SAIC ACVC 2.0 -- 16 Dec 94 SAIC Add allocation to the object initializations -- --! package C393012_0 is subtype Row_Number is Positive range 1..120; subtype Seat_Letter is Character range 'A'..'M'; type Ticket is abstract tagged record Flight : Natural; Row : Row_Number; Seat : Seat_Letter; end record; function Display( T: Ticket ) return String; function Service( T: Ticket ) return String is abstract; end C393012_0; with TCTouch; package body C393012_0 is function Display( T: Ticket ) return String is begin TCTouch.Touch('T'); --------------------------------------------------- T return "Fl:" & Natural'Image(T.Flight) & Service( Ticket'Class( T ) ) & " Seat:" & Row_Number'Image(T.Row) & T.Seat; end Display; end C393012_0; with C393012_0; package C393012_1 is type Economy is new C393012_0.Ticket with null record; function Display( T: Economy ) return String; function Service( T: Economy ) return String; type Meal_Designator is ( B, L, D, V, SN ); type First is new C393012_0.Ticket with record Meal : Meal_Designator; end record; function Display( T: First ) return String; function Service( T: First ) return String; procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ); end C393012_1; with TCTouch; package body C393012_1 is function Display( T: Economy ) return String is begin TCTouch.Touch('E'); --------------------------------------------------- E return C393012_0.Display( C393012_0.Ticket( T ) ); end Display; -- conversion to abstract type function Service( T: Economy ) return String is begin TCTouch.Touch('e'); --------------------------------------------------- e return " K"; end Service; function Display( T: First ) return String is begin TCTouch.Touch('F'); --------------------------------------------------- F return C393012_0.Display( C393012_0.Ticket( T ) ); end Display; -- conversion to abstract type function Service( T: First ) return String is begin TCTouch.Touch('f'); --------------------------------------------------- f return " F" & Meal_Designator'Image(T.Meal); end Service; procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is begin T.Meal := To_Meal; end Set_Meal; end C393012_1; with Report; with TCTouch; with C393012_0; with C393012_1; procedure C393012 is package Rt renames C393012_0; package Tx renames C393012_1; type Tix is access Rt.Ticket'Class; type Itinerary is array(Positive range 1..3) of Tix; -- Outbound and Inbound itineraries provide different orderings of mixtures -- of Economy and First_Class. Not that that should make any difference... Outbound : Itinerary := ( 1 => new Tx.Economy'( 5335, 5, 'B' ), 2 => new Tx.First' ( 67, 1, 'J', Tx.L ), 3 => new Tx.Economy'( 345, 37, 'C' ) ); Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx.SN ), 2 => new Tx.Economy'( 68, 12, 'D' ), 3 => new Tx.Economy'( 5336, 6, 'A' ) ); -- Each call to Display uses a parameter that is a type conversion -- to the abstract type Ticket. procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is begin if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 ); end if; if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 ); end if; if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 ); end if; end TC_Convert; -- Each call to Display uses a parameter that is not a type conversion procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is begin if Rt.Display( I(1).all ) /= Leg1 then Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 ); end if; if Rt.Display( I(2).all ) /= Leg2 then Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 ); end if; if Rt.Display( I(3).all ) /= Leg3 then Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 ); end if; end TC_Match; begin -- Main test procedure. Report.Test ("C393012", "Check that a non-abstract subprogram of an " & "abstract type can be called with a " & "controlling operand that is a type " & "conversion to the abstract type. " & "Check that converting to the class-wide type " & "of an abstract type inside an operation of " & "that type causes a redispatch" ); -- Test conversions to abstract type TC_Convert( Outbound, "Fl: 5335 K Seat: 5B", "Fl: 67 FL Seat: 1J", "Fl: 345 K Seat: 37C" ); TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" ); TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F", "Fl: 68 K Seat: 12D", "Fl: 5336 K Seat: 6A" ); TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" ); -- Test without conversions to abstract type TC_Match( Outbound, "Fl: 5335 K Seat: 5B", "Fl: 67 FL Seat: 1J", "Fl: 345 K Seat: 37C" ); TCTouch.Validate( "ETeFTfETe", "Outbound flight" ); TC_Match( Inbound, "Fl: 456 FSN Seat: 4F", "Fl: 68 K Seat: 12D", "Fl: 5336 K Seat: 6A" ); TCTouch.Validate( "FTfETeETe", "Inbound flight" ); Report.Result; end C393012;