| -- 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; |
