gcc/testsuite/ada/acats/tests/c3/c393010.a

   1 -- C393010.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- TEST OBJECTIVE:
  27 --      Check that an extended type can be derived from an abstract type and
  28 --      that a call on an abstract operation is a dispatching operation.
  29 --      Check that such a call can dispatch to an overriding operation
  30 --      declared in the private part of a package.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      Taking from a classroom example of a typical usage: declare a basic
  34 --      abstract type containing data germane to the entire class structure,
  35 --      derive from that a type with specific data, and derive from that
  36 --      another type merely providing a "secret" override.  The abstract type
  37 --      provides a concrete procedure that itself "redispatches" to an
  38 --      abstract procedure; the abstract procedure must be provided by one or
  39 --      more of the concrete types derived from the abstract type, and hence
  40 --      upon re-evaluating the actual type of the operand should dispatch
  41 --      accordingly.
  42 --
  43 --
  44 --
  45 -- CHANGE HISTORY:
  46 --      06 Dec 94   SAIC    ACVC 2.0
  47 --      15 Mar 96   SAIC    ACVC 2.1
  48 --
  49 --!
  50
  51 ----------------------------------------------------------------- C393010_0
  52
  53 package C393010_0 is
  54
  55   type Ticket is abstract tagged record
  56     Flight        : Natural;
  57     Serial_Number : Natural;
  58   end record;
  59
  60   function Issue return Ticket is abstract;
  61   procedure Label( T: Ticket ) is abstract;
  62
  63   procedure Print( T: Ticket );
  64
  65 end C393010_0;
  66
  67 with TCTouch;
  68 package body C393010_0 is
  69
  70   procedure Print( T: Ticket ) is
  71   begin
  72     -- Check that a call on an abstract operation is a dispatching operation
  73     Label( Ticket'Class( T ) );
  74     -- Appropriate_IO.Put( T.Flight & T.Serial_Number );
  75     TCTouch.Touch('P'); -------------------------------------------------- P
  76   end Print;
  77
  78 end C393010_0;
  79
  80 ----------------------------------------------------------------- C393010_1
  81
  82 with C393010_0;
  83 package C393010_1 is
  84
  85   type Service_Classes is (First, Business, Coach);
  86
  87   type Menu is (Steak, Lobster, Fowl, Vegan);
  88
  89   -- Check that an extended type can be derived from an abstract type.
  90   type Passenger_Ticket(Service : Service_Classes) is
  91     new C393010_0.Ticket with record
  92       Row_Seat : String(1..3);
  93       case Service is
  94         when First | Business => Meal : Menu;
  95         when Coach => null;
  96       end case;
  97   end record;
  98
  99   function Issue return Passenger_Ticket;
 100   function Issue( Service : Service_Classes;
 101                    Flight : Natural;
 102                      Seat : String;
 103                      Meal : Menu := Fowl ) return Passenger_Ticket;
 104
 105   procedure Label( T: Passenger_Ticket );
 106
 107   procedure Print( T: Passenger_Ticket );
 108
 109 end C393010_1;
 110
 111 with TCTouch;
 112 package body C393010_1 is
 113
 114   procedure Label( T: Passenger_Ticket ) is
 115   begin
 116     -- Appropriate_IO.Put( T.Service );
 117     TCTouch.Touch('L'); -------------------------------------------------- L
 118   end Label;
 119
 120   procedure Print( T: Passenger_Ticket ) is
 121   begin
 122     -- call parent print:
 123     C393010_0.Print( C393010_0.Ticket( T ) );
 124     case T.Service is
 125       when First    => -- Appropriate_IO.Put( Meal );
 126         TCTouch.Touch('F'); ---------------------------------------------- F
 127       when Business => -- Appropriate_IO.Put( Meal );
 128         TCTouch.Touch('B'); ---------------------------------------------- B
 129       when Coach    => -- Appropriate_IO.Put( "BYO" & " peanuts" );
 130         TCTouch.Touch('C'); ---------------------------------------------- C
 131     end case;
 132   end Print;
 133
 134   Num : Natural := 1000;
 135
 136   function Issue( Service : Service_Classes;
 137                    Flight : Natural;
 138                      Seat : String;
 139                      Meal : Menu := Fowl ) return Passenger_Ticket is
 140   begin
 141     Num := Num +1;
 142     case Service is
 143       when First =>
 144         return Passenger_Ticket'(Service => First, Flight => Flight,
 145                        Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
 146       when Business =>
 147         return Passenger_Ticket'(Service => Business, Flight => Flight,
 148                        Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
 149       when Coach =>
 150         return Passenger_Ticket'(Service => Coach, Flight => Flight,
 151                        Row_Seat => Seat, Serial_Number => Num );
 152     end case;
 153   end Issue;
 154
 155   function Issue return Passenger_Ticket is
 156   begin
 157     return Issue( Coach, 0, "non" );
 158   end Issue;
 159
 160 end C393010_1;
 161
 162 ----------------------------------------------------------------- C393010_1
 163
 164 with C393010_1;
 165 package C393010_2 is
 166
 167   type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
 168     with private;
 169
 170   function Issue return Charter;
 171
 172   -- procedure Print( T: Passenger_Ticket );
 173
 174 private
 175   type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
 176     with null record;
 177
 178   -- Check that the dispatching call to the abstract operation will dispatch
 179   -- to a procedure defined in the private part of a package.
 180   procedure Label( T: Charter );
 181
 182   -- an example of a required function the users shouldn't see:
 183   function Issue( Service : C393010_1.Service_Classes;
 184                    Flight : Natural;
 185                      Seat : String;
 186                      Meal : C393010_1.Menu ) return Charter;
 187
 188 end C393010_2;
 189
 190 with TCTouch;
 191 package body C393010_2 is
 192
 193   procedure Label( T: Charter ) is
 194   begin
 195     -- Appropriate_IO.Put( "Excursion Fare" );
 196     TCTouch.Touch('X'); -------------------------------------------------- X
 197   end Label;
 198
 199   Num : Natural := 4000;
 200
 201   function Issue return Charter is
 202   begin
 203     Num := Num +1;
 204     return Charter'(Service => C393010_1.Coach, Flight => 1001,
 205                        Row_Seat => "OPN", Serial_Number => Num );
 206   end Issue;
 207
 208   function Issue( Service : C393010_1.Service_Classes;
 209                    Flight : Natural;
 210                      Seat : String;
 211                      Meal : C393010_1.Menu ) return Charter is
 212   begin
 213     return Issue;
 214   end Issue;
 215
 216 end C393010_2;
 217
 218 ----------------------------------------------------------------- C393010_1
 219
 220 with Report;
 221 with TCTouch;
 222 with C393010_0;
 223 with C393010_1;
 224 with C393010_2; -- Charter Tours
 225
 226 procedure C393010 is
 227
 228   type Agents_Handle is access all C393010_0.Ticket'Class;
 229
 230   type Itinerary;
 231
 232   type Next_Leg is access Itinerary;
 233
 234   type Itinerary is record
 235     Leg  : Agents_Handle;
 236     Next : Next_Leg;
 237   end record;
 238
 239   function Travel_Agent_1 return Next_Leg is
 240   begin
 241     -- ORL -> JFK -> LAX -> SAN -> DFW -> ORL
 242     return new Itinerary'(
 243        -- ORL -> JFK 01   12  2A First, Lobster
 244        new C393010_1.Passenger_Ticket'(
 245          C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )),
 246          new Itinerary'(
 247        -- JFK -> LAX 02   18  2B First, Steak
 248        new C393010_1.Passenger_Ticket'(
 249          C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )),
 250          new Itinerary'(
 251        -- LAX -> SAN 03 5225 34H Coach
 252        new C393010_1.Passenger_Ticket'(
 253          C393010_1.Issue(C393010_1.Coach, 5225, "34H")),
 254          new Itinerary'(
 255        -- SAN -> DFW 04   25 13A Business, Fowl
 256        new C393010_1.Passenger_Ticket'(
 257          C393010_1.Issue(C393010_1.Business, 25, "13A")),
 258          new Itinerary'(
 259        -- DFW -> ORL 05   15  1D First, Lobster
 260        new C393010_1.Passenger_Ticket'(
 261          C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )),
 262          null          )))));
 263   end Travel_Agent_1;
 264
 265   function Travel_Agent_2 return Next_Leg is
 266   begin
 267     -- LAX -> NRT -> SYD -> LAX
 268     return new Itinerary'(
 269        new C393010_2.Charter'( C393010_2.Issue ),
 270          new Itinerary'(
 271        new C393010_2.Charter'( C393010_2.Issue ),
 272          new Itinerary'(
 273        new C393010_2.Charter'( C393010_2.Issue ),
 274          new Itinerary'(
 275        new C393010_2.Charter'( C393010_2.Issue ),
 276          null ))));
 277   end Travel_Agent_2;
 278
 279   procedure Traveler( Pax_Tix : in Next_Leg ) is
 280     Fly_Me : Next_Leg := Pax_Tix;
 281   begin
 282     -- a particularly consumptive process...
 283     while Fly_Me /= null loop
 284       C393010_0.Print( Fly_Me.Leg.all );  -- herein lies the test.
 285       Fly_Me := Fly_Me.Next;
 286     end loop;
 287   end Traveler;
 288
 289 begin
 290
 291   Report.Test ("C393010", "Check that an extended type can be derived from "
 292                         & "an abstract type and that a call on an abstract "
 293                         & "operation is a dispatching operation.  Check "
 294                         & "that such a call can dispatch to an overriding "
 295                         & "operation declared in the private part of a "
 296                         & "package" );
 297
 298   Traveler( Travel_Agent_1 );
 299   TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip");
 300
 301   Traveler( Travel_Agent_2 );
 302   TCTouch.Validate("XPCXPCXPCXPC","Second Trip");
 303
 304   Report.Result;
 305
 306 end C393010;