path: root/gcc/testsuite/ada/acats/tests/c3/c393010.a

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