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

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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