aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c393010.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c393010.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393010.a306
1 files changed, 0 insertions, 306 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393010.a b/gcc/testsuite/ada/acats/tests/c3/c393010.a
deleted file mode 100644
index 6a52cf889a2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393010.a
+++ /dev/null
@@ -1,306 +0,0 @@
--- C393010.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.
---*
---
--- TEST OBJECTIVE:
--- Check that an extended type can be derived from an abstract type and
--- that a call on an abstract operation is a dispatching operation.
--- Check that such a call can dispatch to an overriding operation
--- declared in the private part of a package.
---
--- TEST DESCRIPTION:
--- Taking from a classroom example of a typical usage: declare a basic
--- abstract type containing data germane to the entire class structure,
--- derive from that a type with specific data, and derive from that
--- another type merely providing a "secret" override. The abstract type
--- provides a concrete procedure that itself "redispatches" to an
--- abstract procedure; the abstract procedure must be provided by one or
--- more of the concrete types derived from the abstract type, and hence
--- upon re-evaluating the actual type of the operand should dispatch
--- accordingly.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Mar 96 SAIC ACVC 2.1
---
---!
-
------------------------------------------------------------------ C393010_0
-
-package C393010_0 is
-
- type Ticket is abstract tagged record
- Flight : Natural;
- Serial_Number : Natural;
- end record;
-
- function Issue return Ticket is abstract;
- procedure Label( T: Ticket ) is abstract;
-
- procedure Print( T: Ticket );
-
-end C393010_0;
-
-with TCTouch;
-package body C393010_0 is
-
- procedure Print( T: Ticket ) is
- begin
- -- Check that a call on an abstract operation is a dispatching operation
- Label( Ticket'Class( T ) );
- -- Appropriate_IO.Put( T.Flight & T.Serial_Number );
- TCTouch.Touch('P'); -------------------------------------------------- P
- end Print;
-
-end C393010_0;
-
------------------------------------------------------------------ C393010_1
-
-with C393010_0;
-package C393010_1 is
-
- type Service_Classes is (First, Business, Coach);
-
- type Menu is (Steak, Lobster, Fowl, Vegan);
-
- -- Check that an extended type can be derived from an abstract type.
- type Passenger_Ticket(Service : Service_Classes) is
- new C393010_0.Ticket with record
- Row_Seat : String(1..3);
- case Service is
- when First | Business => Meal : Menu;
- when Coach => null;
- end case;
- end record;
-
- function Issue return Passenger_Ticket;
- function Issue( Service : Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : Menu := Fowl ) return Passenger_Ticket;
-
- procedure Label( T: Passenger_Ticket );
-
- procedure Print( T: Passenger_Ticket );
-
-end C393010_1;
-
-with TCTouch;
-package body C393010_1 is
-
- procedure Label( T: Passenger_Ticket ) is
- begin
- -- Appropriate_IO.Put( T.Service );
- TCTouch.Touch('L'); -------------------------------------------------- L
- end Label;
-
- procedure Print( T: Passenger_Ticket ) is
- begin
- -- call parent print:
- C393010_0.Print( C393010_0.Ticket( T ) );
- case T.Service is
- when First => -- Appropriate_IO.Put( Meal );
- TCTouch.Touch('F'); ---------------------------------------------- F
- when Business => -- Appropriate_IO.Put( Meal );
- TCTouch.Touch('B'); ---------------------------------------------- B
- when Coach => -- Appropriate_IO.Put( "BYO" & " peanuts" );
- TCTouch.Touch('C'); ---------------------------------------------- C
- end case;
- end Print;
-
- Num : Natural := 1000;
-
- function Issue( Service : Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : Menu := Fowl ) return Passenger_Ticket is
- begin
- Num := Num +1;
- case Service is
- when First =>
- return Passenger_Ticket'(Service => First, Flight => Flight,
- Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
- when Business =>
- return Passenger_Ticket'(Service => Business, Flight => Flight,
- Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
- when Coach =>
- return Passenger_Ticket'(Service => Coach, Flight => Flight,
- Row_Seat => Seat, Serial_Number => Num );
- end case;
- end Issue;
-
- function Issue return Passenger_Ticket is
- begin
- return Issue( Coach, 0, "non" );
- end Issue;
-
-end C393010_1;
-
------------------------------------------------------------------ C393010_1
-
-with C393010_1;
-package C393010_2 is
-
- type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
- with private;
-
- function Issue return Charter;
-
- -- procedure Print( T: Passenger_Ticket );
-
-private
- type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
- with null record;
-
- -- Check that the dispatching call to the abstract operation will dispatch
- -- to a procedure defined in the private part of a package.
- procedure Label( T: Charter );
-
- -- an example of a required function the users shouldn't see:
- function Issue( Service : C393010_1.Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : C393010_1.Menu ) return Charter;
-
-end C393010_2;
-
-with TCTouch;
-package body C393010_2 is
-
- procedure Label( T: Charter ) is
- begin
- -- Appropriate_IO.Put( "Excursion Fare" );
- TCTouch.Touch('X'); -------------------------------------------------- X
- end Label;
-
- Num : Natural := 4000;
-
- function Issue return Charter is
- begin
- Num := Num +1;
- return Charter'(Service => C393010_1.Coach, Flight => 1001,
- Row_Seat => "OPN", Serial_Number => Num );
- end Issue;
-
- function Issue( Service : C393010_1.Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : C393010_1.Menu ) return Charter is
- begin
- return Issue;
- end Issue;
-
-end C393010_2;
-
------------------------------------------------------------------ C393010_1
-
-with Report;
-with TCTouch;
-with C393010_0;
-with C393010_1;
-with C393010_2; -- Charter Tours
-
-procedure C393010 is
-
- type Agents_Handle is access all C393010_0.Ticket'Class;
-
- type Itinerary;
-
- type Next_Leg is access Itinerary;
-
- type Itinerary is record
- Leg : Agents_Handle;
- Next : Next_Leg;
- end record;
-
- function Travel_Agent_1 return Next_Leg is
- begin
- -- ORL -> JFK -> LAX -> SAN -> DFW -> ORL
- return new Itinerary'(
- -- ORL -> JFK 01 12 2A First, Lobster
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )),
- new Itinerary'(
- -- JFK -> LAX 02 18 2B First, Steak
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )),
- new Itinerary'(
- -- LAX -> SAN 03 5225 34H Coach
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.Coach, 5225, "34H")),
- new Itinerary'(
- -- SAN -> DFW 04 25 13A Business, Fowl
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.Business, 25, "13A")),
- new Itinerary'(
- -- DFW -> ORL 05 15 1D First, Lobster
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )),
- null )))));
- end Travel_Agent_1;
-
- function Travel_Agent_2 return Next_Leg is
- begin
- -- LAX -> NRT -> SYD -> LAX
- return new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- null ))));
- end Travel_Agent_2;
-
- procedure Traveler( Pax_Tix : in Next_Leg ) is
- Fly_Me : Next_Leg := Pax_Tix;
- begin
- -- a particularly consumptive process...
- while Fly_Me /= null loop
- C393010_0.Print( Fly_Me.Leg.all ); -- herein lies the test.
- Fly_Me := Fly_Me.Next;
- end loop;
- end Traveler;
-
-begin
-
- Report.Test ("C393010", "Check that an extended type can be derived from "
- & "an abstract type and that a call on an abstract "
- & "operation is a dispatching operation. Check "
- & "that such a call can dispatch to an overriding "
- & "operation declared in the private part of a "
- & "package" );
-
- Traveler( Travel_Agent_1 );
- TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip");
-
- Traveler( Travel_Agent_2 );
- TCTouch.Validate("XPCXPCXPCXPC","Second Trip");
-
- Report.Result;
-
-end C393010;
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-18 01:24:42 +0000