OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c393010.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- 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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.