aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c393012.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c393012.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393012.a221
1 files changed, 0 insertions, 221 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393012.a b/gcc/testsuite/ada/acats/tests/c3/c393012.a
deleted file mode 100644
index 16bf6ddccf8..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393012.a
+++ /dev/null
@@ -1,221 +0,0 @@
--- 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;
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-19 04:49:03 +0000