Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/support/f341a00.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- F341A00.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 -- FOUNDATION DESCRIPTION:
27 -- This foundation provides a simple class hierarchy (a root type and two
28 -- levels of derivation from it) to use in testing the basic OO features
29 -- related to tagged types.
30 --
31 -- CHANGE HISTORY:
32 -- 06 Dec 94 SAIC ACVC 2.0
33 --
34 --!
35
36 package F341A00_0 is -- package Bank
37
38 type Dollar_Amount is new Float;
39
40 type Account is tagged
41 record
42 Current_Balance: Dollar_Amount;
43 end record;
44
45 -- Primitive operations.
46
47 procedure Deposit (A : in out Account;
48 X : in Dollar_Amount);
49 procedure Withdrawal (A : in out Account;
50 X : in Dollar_Amount);
51 function Balance (A : in Account) return Dollar_Amount;
52 procedure Service_Charge (A : in out Account);
53 procedure Add_Interest (A : in out Account);
54 procedure Open (A : in out Account);
55
56 end F341A00_0;
57
58
59 --=================================================================--
60
61
62 package body F341A00_0 is
63
64 -- Primitive operations for type Account.
65
66 procedure Deposit (A : in out Account;
67 X : in Dollar_Amount) is
68 begin
69 A.Current_Balance := A.Current_Balance + X;
70 end Deposit;
71
72 --
73
74 procedure Withdrawal (A : in out Account;
75 X : in Dollar_Amount) is
76 begin
77 A.Current_Balance := A.Current_Balance - X;
78 end Withdrawal;
79
80 --
81
82 function Balance (A : in Account) return Dollar_Amount is
83 begin
84 return (A.Current_Balance);
85 end Balance;
86
87 --
88
89 procedure Service_Charge (A : in out Account) is
90 begin
91 A.Current_Balance := A.Current_Balance - 5.00;
92 end Service_Charge;
93
94 --
95
96 procedure Add_Interest (A : in out Account) is
97 -- No interest accumulated on this type of account.
98 Interest_On_Account : Dollar_Amount := 0.00;
99 begin
100 A.Current_Balance := A.Current_Balance + Interest_On_Account;
101 end Add_Interest;
102
103 --
104
105 procedure Open (A : in out Account) is
106 Initial_Deposit : Dollar_Amount := 10.00;
107 begin
108 A.Current_Balance := Initial_Deposit;
109 end Open;
110
111 end F341A00_0;
112
113
114 --=================================================================--
115
116
117 with F341A00_0;
118
119 package F341A00_1 is -- package Checking
120
121 package Bank renames F341A00_0;
122
123 type Account is new Bank.Account with
124 record
125 Overdraft_Fee : Bank.Dollar_Amount;
126 end record;
127
128
129 -- Inherited primitive operations.
130 -- procedure Deposit (A : in out Account; X : in Bank.Dollar_Amount);
131 -- procedure Withdrawal (A : in out Account; X : in Bank.Dollar_Amount);
132 -- function Balance (A : in Account) return Bank.Dollar_Amount;
133 -- procedure Service_Charge(A : in out Account);
134 -- procedure Add_Interest (A : in out Account);
135
136 -- Overridden primitive operation.
137 procedure Open (A : in out Account);
138
139 end F341A00_1;
140
141
142 --=================================================================--
143
144
145 package body F341A00_1 is
146
147 -- Overridden primitive operation.
148
149 procedure Open (A : in out Account) is
150 Check_Guarantee : Bank.Dollar_Amount := 10.00;
151 Initial_Deposit : Bank.Dollar_Amount := 100.00;
152 begin
153 A.Current_Balance := Initial_Deposit;
154 A.Overdraft_Fee := Check_Guarantee;
155 end Open;
156
157 end F341A00_1;
158
159
160 --=================================================================--
161
162
163 with F341A00_0; -- package Bank
164 with F341A00_1; -- package Checking
165
166 package F341A00_2 is -- package Interest_Checking
167
168 package Bank renames F341A00_0;
169 package Checking renames F341A00_1;
170
171 subtype Interest_Rate is Bank.Dollar_Amount digits 4;
172
173 Current_Rate : Interest_Rate := 0.030;
174
175 type Account is new Checking.Account with
176 record
177 Rate : Interest_Rate;
178 end record;
179
180 -- "Twice" inherited primitive operations (Bank.Account, Checking.Account)
181 -- procedure Deposit (A : in out Account; X : in Bank.Dollar_Amount);
182 -- procedure Withdrawal (A : in out Account; X : in Bank.Dollar_Amount);
183 -- function Balance (A : in Account) return Bank.Dollar_Amount;
184 -- procedure Service_Charge(A : in out Account);
185
186 -- Overridden primitive operations.
187 procedure Add_Interest (A : in out Account);
188 procedure Open (A : in out Account);
189
190 end F341A00_2;
191
192
193 --=================================================================--
194
195
196 package body F341A00_2 is
197
198 -- Overridden primitive operations.
199
200 procedure Add_Interest (A : in out Account) is
201 use type Bank.Dollar_Amount;
202 Interest_On_Account : Bank.Dollar_Amount
203 := Bank.Dollar_Amount(A.Current_Balance * A.Rate);
204 begin
205 A.Current_Balance := A.Current_Balance + Interest_On_Account;
206 end Add_Interest;
207
208 procedure Open (A : in out Account) is
209 Initial_Deposit : Bank.Dollar_Amount := 1000.00;
210 begin
211 Checking.Open (Checking.Account (A));
212 A.Current_Balance := Initial_Deposit;
213 A.Rate := Current_Rate;
214 end Open;
215
216 end F341A00_2;