diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c393012.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c393012.a | 221 |
1 files changed, 221 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393012.a b/gcc/testsuite/ada/acats/tests/c3/c393012.a new file mode 100644 index 000000000..16bf6ddcc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393012.a @@ -0,0 +1,221 @@ +-- 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; |