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

   1 -- C341A03.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 an object of one class-wide type can initialize a
  28 --      class-wide object of a different type when the operation is embedded
  29 --      in a generic unit.
  30 --
  31 -- TEST DESCRIPTION:
  32 --      Declare specific-type objects of an extended type.  Declare an array
  33 --      of access values designating class-wide objects, initialized to point
  34 --      to the objects of the specific type.  Define a generic subprogram
  35 --      having a generic formal derived type parameter.  Within the generic,
  36 --      declare a class-wide variable of the formal parameter type.  Verify
  37 --      that the variable can be initialized with the value of an object
  38 --      of another class-wide type within the class.
  39 --
  40 --      The particular root and extended types used in this abstraction are
  41 --      defined in foundation code (F341A00.A), and are graphically displayed
  42 --      as follows:
  43 --
  44 --           package Bank
  45 --              type Account
  46 --                  |
  47 --                  |
  48 --                  |
  49 --               package Checking
  50 --                  type Account
  51 --                      |
  52 --                      |
  53 --                      |
  54 --                   package Interest_Checking
  55 --                          type Account
  56 --
  57 -- TEST FILES:
  58 --      This test depends on the following foundation code:
  59 --
  60 --         F341A00.A
  61 --
  62 --
  63 -- CHANGE HISTORY:
  64 --      06 Dec 94   SAIC    ACVC 2.0
  65 --      16 Dec 94   SAIC    Changed level of 'Class for ATM_Card
  66 --
  67 --!
  68
  69 with F341A00_0;            -- package Bank
  70 generic
  71    type Account_Type is new F341A00_0.Account with private; -- new Bank.Account
  72 function C341A03_0 (The_Account : Account_Type'Class)       -- function Audit
  73   return F341A00_0.Dollar_Amount;
  74
  75 function C341A03_0 (The_Account : Account_Type'Class)
  76   return F341A00_0.Dollar_Amount is
  77    Acct : Account_Type'Class := The_Account;  -- Init. of class-wide with
  78 begin                                         -- another class-wide object.
  79    return Acct.Current_Balance;
  80 end C341A03_0;
  81
  82
  83      --=================================================================--
  84
  85
  86 with F341A00_0;            -- package Bank
  87 with F341A00_1;            -- package Checking
  88 with C341A03_0;            -- generic function Audit
  89 with Report;
  90
  91 procedure C341A03 is
  92
  93    package Bank     renames F341A00_0;
  94    package Checking renames F341A00_1;
  95
  96    Current_Checking_Accounts : constant := 3;
  97
  98    Checking_Acct1 : aliased Checking.Account := (Current_Balance => 10.00,
  99                                                  Overdraft_Fee   =>  5.00);
 100    Checking_Acct2 : aliased Checking.Account := (Current_Balance => 20.00,
 101                                                  Overdraft_Fee   =>  5.00);
 102    Checking_Acct3 : aliased Checking.Account := (Current_Balance => 30.00,
 103                                                  Overdraft_Fee   =>  5.00);
 104
 105    type ATM_Card is access all Checking.Account'Class;
 106
 107    -- Declare array of accesses to class-wide objects.
 108    Account_Array : array (1 .. Current_Checking_Accounts) of
 109      ATM_Card := (Checking_Acct1'Access,
 110                   Checking_Acct2'Access,
 111                   Checking_Acct3'Access);
 112 begin  -- C341A03
 113
 114    Report.Test ("C341A03",  "Check that an object of one class-wide type " &
 115                             "can initialize a class-wide object of a "   &
 116                             "different type when the operation is embedded " &
 117                             "in a generic unit" );
 118
 119    Audit_Checking_Accounts:
 120    declare
 121       Balance_In_Checking_Accounts : Bank.Dollar_Amount := 0.00;
 122       -- Instantiate with a specific extended type.
 123       function Checking_Audit is new C341A03_0 (Checking.Account);
 124       use type Bank.Dollar_Amount;
 125    begin
 126
 127       for I in 1 .. Current_Checking_Accounts loop
 128          Balance_In_Checking_Accounts := Balance_In_Checking_Accounts +
 129            Checking_Audit (Account_Array (I).all);
 130       end loop;
 131
 132       if Balance_In_Checking_Accounts /= 60.00 then
 133          Report.Failed ("Incorrect initialization of class-wide object");
 134       end if;
 135
 136    end Audit_Checking_Accounts;
 137
 138    Report.Result;
 139
 140 end C341A03;