summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c392003.a
blob: d7c5be2286740263e82f1d953d06002d45b79291 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
-- C392003.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 the use of a class-wide formal parameter allows for the 
--      proper dispatching of objects to the appropriate implementation of 
--      a primitive operation.  Check this where the root tagged type is
--      defined in a package, and the extended type is defined in a nested
--      package.
--
-- TEST DESCRIPTION:
--      Declare a root tagged type, and some associated primitive operations.
--      Extend the root type, and override one or more primitive operations, 
--      inheriting the other primitive operations from the root type.
--      Derive from the extended type, again overriding some primitive
--      operations and inheriting others (including some that the parent 
--      inherited).
--      Define a subprogram with a class-wide parameter, inside of which is a 
--      call on a dispatching primitive operation.  These primitive operations
--      modify global variables (the class-wide parameter has mode IN).
--     
--     
--     
-- The following hierarchy of tagged types and primitive operations is 
-- utilized in this test:
--
--    type Bank_Account (root)
--            |
--            | Operations
--            |   Increment_Bank_Reserve
--            |   Assign_Representative
--            |   Increment_Counters
--            |   Open
--            |
--    type Savings_Account (extended from Bank_Account)
--            |
--            | Operations
--            |   (Increment_Bank_Reserve) (inherited)
--            |   Assign_Representative    (overridden)
--            |   Increment_Counters       (overridden)
--            |   Open                     (overridden)
--            |
--    type Preferred_Account (extended from Savings_Account)
--            |
--            | Operations
--            |   (Increment_Bank_Reserve) (inherited twice - Bank_Acct.)
--            |   (Assign_Representative)  (inherited - Savings_Acct.)
--            |   Increment_Counters       (overridden)
--            |   Open                     (overridden)
-- 
--
-- In this test, we are concerned with the following selection of dispatching
-- calls, accomplished with the use of a Bank_Account'Class IN procedure 
-- parameter :
--
--                       \ Type
--               Prim. Op \  Bank_Account  Savings_Account Preferred_Account
--                         \------------------------------------------------ 
--   Increment_Bank_Reserve|      X                               X
--   Assign_Representative |                      X
--   Increment_Counters    |      X               X               X
--
--
--
-- The location of the declaration and derivation of the root and extended
-- types will be varied over a series of tests.  Locations of declaration
-- and derivation for a particular test are marked with an asterisk (*).
--
-- Root type:
--       
--    *  Declared in package.
--       Declared in generic package.
--
-- Extended types:
--
--       Derived in parent location.
--    *  Derived in a nested package.
--       Derived in a nested subprogram.
--       Derived in a nested generic package.
--       Derived in a separate package.
--       Derived in a separate visible child package.
--       Derived in a separate private child package.
--
-- Primitive Operations:
--
--    *  Procedures with same parameter profile.
--       Procedures with different parameter profile.
--    *  Functions with same parameter profile.
--       Functions with different parameter profile.
--    *  Mixture of Procedures and Functions.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!
 
 
 with Report;
 
 procedure C392003 is
 
       --
       -- Types and subtypes.
       --
 
       type Dollar_Amount  is new float;
       type Interest_Rate  is delta 0.001 range 0.000 .. 1.000;
       type Account_Types  is (Bank, Savings, Preferred, Total);
       type Account_Counter is array (Account_Types) of integer;
       type Account_Rep is (President, Manager, New_Account_Manager, Teller);
 
       --
       -- Constants.
       --
 
       Opening_Balance           : constant Dollar_Amount := 100.00;
       Current_Rate              : constant Interest_Rate := 0.030;
       Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00;
 
       --
       -- Global Variables
       --
 
       Bank_Reserve         : Dollar_Amount   := 0.00;
       Daily_Representative : Account_Rep     := New_Account_Manager;
       Number_Of_Accounts   : Account_Counter := (Bank      => 0,
                                                  Savings   => 0,
                                                  Preferred => 0,
                                                  Total     => 0);
 
    -- Root tagged type and primitive operations declared in internal 
    -- package (Accounts).
    -- Extended types (and primitive operations) derived in nested packages.
 
      --=================================================================--
 
    package Accounts is
 
       --
       -- Root account type and primitive operations.
       --
 
       -- Root type.
 
       type Bank_Account is tagged
          record
             Balance : Dollar_Amount;
          end record;
 
       -- Primitive operations of Bank_Account.
 
       function  Increment_Bank_Reserve (Acct : in     Bank_Account) 
         return Dollar_Amount;
       function Assign_Representative   (Acct : in     Bank_Account)
         return Account_Rep;
       procedure Increment_Counters     (Acct : in     Bank_Account);
       procedure Open                   (Acct : in out Bank_Account);
 
      --=================================================================--
                           
       package S_And_L is 
 
          -- Declare extended type in a nested package.
 
          type Savings_Account is new Bank_Account with
          record
             Rate : Interest_Rate;
          end record;
 
          -- Function Increment_Bank_Reserve inherited from 
          -- parent (Bank_Account).
 
          -- Primitive operations (Overridden).
          function Assign_Representative (Acct : in     Savings_Account)
            return Account_Rep;
          procedure Increment_Counters   (Acct : in     Savings_Account);
          procedure Open                 (Acct : in out Savings_Account);
                           
 
      --=================================================================--
                           
          package Premium is 
 
             -- Declare further extended type in a nested package.
 
             type Preferred_Account is new Savings_Account with
             record
                Minimum_Balance : Dollar_Amount;
             end record;
 
             -- Function Increment_Bank_Reserve inherited twice.
             -- Function Assign_Representative inherited from parent 
             --   (Savings_Account).
 
             -- Primitive operation (Overridden).
             procedure Increment_Counters (Acct : in     Preferred_Account);
             procedure Open               (Acct : in out Preferred_Account);
 
             -- Function used to verify Open operation for Preferred_Account 
             -- objects.
             function Verify_Open (Acct : in Preferred_Account) return Boolean;
 
          end Premium;
 
       end S_And_L;
 
    end Accounts;
 
      --=================================================================--
 
    package body Accounts is
 
       --
       -- Primitive operations for Bank_Account.
       --
 
       function Increment_Bank_Reserve (Acct : in Bank_Account) 
         return Dollar_Amount is
       begin
          return (Bank_Reserve + Acct.Balance);
       end Increment_Bank_Reserve;
 
       function Assign_Representative (Acct : in Bank_Account) 
         return Account_Rep is
       begin
          return Account_Rep'(Teller);
       end Assign_Representative;
 
       procedure Increment_Counters (Acct : in Bank_Account) is
       begin
          Number_Of_Accounts (Bank)  := Number_Of_Accounts (Bank) + 1;
          Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
       end Increment_Counters;
 
       procedure Open (Acct : in out Bank_Account) is
       begin
          Acct.Balance := Opening_Balance;
       end Open;
 
      --=================================================================--
 
       package body S_And_L is
 
          --
          -- Overridden operations for Savings_Account type.
          --
 
          function Assign_Representative (Acct : in Savings_Account) 
            return Account_Rep is
          begin
             return (Manager);
          end Assign_Representative;
 
          procedure Increment_Counters (Acct : in Savings_Account) is
          begin
             Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1;
             Number_Of_Accounts (Total)   := Number_Of_Accounts (Total) + 1;
          end Increment_Counters;
 
          procedure Open (Acct : in out Savings_Account) is
          begin
             Open (Bank_Account(Acct));
             Acct.Rate := Current_Rate;
             Acct.Balance := 2.0 * Opening_Balance;
          end Open;
      
      --=================================================================--
 
          package body Premium is
 
             --
             -- Overridden operations for Preferred_Account type.
             --
                      
             procedure Increment_Counters (Acct : in Preferred_Account) is
             begin
                Number_Of_Accounts (Preferred) := 
                  Number_Of_Accounts (Preferred) + 1;
                Number_Of_Accounts (Total)     := 
                  Number_Of_Accounts (Total) + 1;
             end Increment_Counters;
 
             procedure Open (Acct : in out Preferred_Account) is
             begin
                Open (Savings_Account(Acct));
                Acct.Minimum_Balance := Preferred_Minimum_Balance;
                Acct.Balance := Acct.Minimum_Balance;
             end Open;
 
             --
             -- Function used to verify Open operation for Preferred_Account 
             -- objects.
             --
 
             function Verify_Open (Acct : in Preferred_Account) 
               return Boolean is
             begin                                                    
                return (Acct.Balance         = Preferred_Minimum_Balance and
                        Acct.Rate            = Current_Rate              and
                        Acct.Minimum_Balance = Preferred_Minimum_Balance);
             end Verify_Open;
 
          end Premium;
  
       end S_And_L;
 
    end Accounts;
 
      --=================================================================--
 
    -- Declare account objects.
 
    B_Account : Accounts.Bank_Account;
    S_Account : Accounts.S_And_L.Savings_Account;
    P_Account : Accounts.S_And_L.Premium.Preferred_Account;
 
    -- Procedures to operate on accounts.
    -- Each uses a class-wide IN parameter, as well as a call to a
    -- dispatching operation.
 
    -- Function Tabulate_Account performs a dispatching call on a primitive
    -- operation that has been overridden for each of the extended types.
 
    procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is
    begin
       Accounts.Increment_Counters (Acct);   -- Dispatch according to tag.
    end Tabulate_Account;
 
    -- Function Accumulate_Reserve performs a dispatching call on a
    -- primitive operation that has been defined for the root type and 
    -- inherited by each derived type.
 
    function Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) 
      return Dollar_Amount is
    begin
       -- Dispatch according to tag.
       return (Accounts.Increment_Bank_Reserve (Acct));   
    end Accumulate_Reserve;
 
    -- Procedure Resolve_Dispute performs a dispatching call on a primitive
    -- operation that has been defined in the root type, overridden in the
    -- first derived extended type, and inherited by the subsequent extended
    -- type.
 
    procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is
    begin
       -- Dispatch according to tag.
       Daily_Representative := Accounts.Assign_Representative (Acct);   
    end Resolve_Dispute;
 
      --=================================================================--
 
 begin  -- Main test procedure.
 
    Report.Test ("C392003", "Check that the use of a class-wide parameter "   &
                             "allows for proper dispatching where root type " &
                             "is declared in a nested package, and "          &
                             "subsequent extended types are derived in "      &
                             "further nested packages" );
    
    Bank_Account_Subtest:
    begin
       Accounts.Open (B_Account);
 
       -- Demonstrate class-wide parameter allowing dispatch by a primitive
       -- operation that has been defined for this specific type.
       Bank_Reserve := Accumulate_Reserve (Acct => B_Account);
       Tabulate_Account (B_Account);
 
       if (Bank_Reserve /= Opening_Balance) or
          (Number_Of_Accounts (Bank) /= 1)  or
          (Number_Of_Accounts (Total) /= 1) 
       then
          Report.Failed ("Failed in Bank_Account_Subtest");
       end if;
 
    end Bank_Account_Subtest;
 
 
    Savings_Account_Subtest:
    begin
       Accounts.S_And_L.Open (Acct => S_Account);
 
       -- Demonstrate class-wide parameter allowing dispatch by a primitive
       -- operation that has been overridden for this extended type.
       Resolve_Dispute  (Acct => S_Account);
       Tabulate_Account (S_Account);
 
       if (Daily_Representative /= Manager)   or 
          (Number_Of_Accounts (Savings) /= 1) or
          (Number_Of_Accounts (Total) /= 2)
       then
          Report.Failed ("Failed in Savings_Account_Subtest");
       end if;
 
    end Savings_Account_Subtest;
 
 
 
    Preferred_Account_Subtest:
    begin
       Accounts.S_And_L.Premium.Open (P_Account);
 
       -- Verify that the correct implementation of Open (overridden) was 
       -- used for the Preferred_Account object.
       if not Accounts.S_And_L.Premium.Verify_Open (P_Account) then
          Report.Failed ("Incorrect values for init. Preferred Acct object");
       end if;
 
       -- Demonstrate class-wide parameter allowing dispatch by a primitive
       -- operation that has been twice inherited by this extended type.
       Bank_Reserve := Accumulate_Reserve (Acct => P_Account);
 
       -- Demonstrate class-wide parameter allowing dispatch by a primitive
       -- operation that has been overridden for this extended type (the
       -- operation was overridden by its parent type as well).
       Tabulate_Account (P_Account);
       
       if Bank_Reserve /= 1100.00             or 
          Number_Of_Accounts (Preferred) /= 1 or
          Number_Of_Accounts (Total) /= 3
       then
          Report.Failed ("Failed in Preferred_Account_Subtest");
       end if;
 
    end Preferred_Account_Subtest;
 
    Report.Result;
 
 end C392003;