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/] [c392003.a] - Blame information for rev 294

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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