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
|
-- CA11A01.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 type extended in a public child inherits primitive
-- operations from its ancestor.
--
-- TEST DESCRIPTION:
-- Declare a root tagged type in a package specification. Declare two
-- primitive subprograms for the type (foundation code).
--
-- Add a public child to the above package. Extend the root type with
-- a record extension in the specification. Declare a new primitive
-- subprogram to write to the child extension.
--
-- Add a public grandchild to the above package. Extend the extension of
-- the parent type with a record extension in the private part of the
-- specification. Declare a new primitive subprogram for this grandchild
-- extension.
--
-- In the main program, "with" the grandchild. Access the primitive
-- operations from grandparent and parent package.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11A00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
package FA11A00.CA11A01_0 is -- Color_Widget_Pkg
-- This public child declares an extension from its parent. It
-- represents processing of widgets in a window system.
type Widget_Color_Enum is (Black, Green, White);
type Color_Widget is new Widget with -- Record extension of
record -- parent tagged type.
Color : Widget_Color_Enum;
end record;
-- Inherits procedure Set_Width from Widget.
-- Inherits procedure Set_Height from Widget.
-- To be inherited by its derivatives.
procedure Set_Color (The_Widget : in out Color_Widget;
C : in Widget_Color_Enum);
procedure Set_Color_Widget (The_Widget : in out Color_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in Widget_Color_Enum);
end FA11A00.CA11A01_0; -- Color_Widget_Pkg
--=======================================================================--
package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg
procedure Set_Color (The_Widget : in out Color_Widget;
C : in Widget_Color_Enum) is
begin
The_Widget.Color := C;
end Set_Color;
---------------------------------------------------------------
procedure Set_Color_Widget (The_Widget : in out Color_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in Widget_Color_Enum) is
begin
Set_Width (The_Widget, The_Width); -- Inherited from parent.
Set_Height (The_Widget, The_Height); -- Inherited from parent.
Set_Color (The_Widget, The_Color);
end Set_Color_Widget;
end FA11A00.CA11A01_0; -- Color_Widget_Pkg
--=======================================================================--
package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg
-- This public grandchild extends the extension from its parent. It
-- represents processing of widgets in a window system.
-- Declaration used by private extension component.
subtype Widget_Label_Str is string (1 .. 10);
type Label_Widget is new Color_Widget with private;
-- Record extension of parent tagged type.
-- Inherits (inherited) procedure Set_Width from Color_Widget.
-- Inherits (inherited) procedure Set_Height from Color_Widget.
-- Inherits procedure Set_Color from Color_Widget.
-- Inherits procedure Set_Color_Widget from Color_Widget.
procedure Set_Label_Widget (The_Widget : in out Label_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in Widget_Color_Enum;
The_Label : in Widget_Label_Str);
-- The following function is needed to verify the value of the
-- extension's private component.
function Verify_Label (The_Widget : in Label_Widget;
The_Label : in Widget_Label_Str) return Boolean;
private
type Label_Widget is new Color_Widget with
record
Label : Widget_Label_Str;
end record;
end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg
--=======================================================================--
package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg
procedure Set_Label (The_Widget : in out Label_Widget;
L : in Widget_Label_Str) is
begin
The_Widget.Label := L;
end Set_Label;
--------------------------------------------------------------
procedure Set_Label_Widget (The_Widget : in out Label_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in Widget_Color_Enum;
The_Label : in Widget_Label_Str) is
begin
Set_Width (The_Widget, The_Width); -- Twice inherited.
Set_Height (The_Widget, The_Height); -- Twice inherited.
Set_Color (The_Widget, The_Color); -- Inherited from parent.
Set_Label (The_Widget, The_Label);
end Set_Label_Widget;
--------------------------------------------------------------
function Verify_Label (The_Widget : in Label_Widget;
The_Label : in Widget_Label_Str) return Boolean is
begin
return (The_Widget.Label = The_Label);
end Verify_Label;
end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg
--=======================================================================--
with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg,
-- implicitly with Widget_Pkg,
-- implicitly with Color_Widget_Pkg
with Report;
procedure CA11A01 is
package Widget_Pkg renames FA11A00;
package Color_Widget_Pkg renames FA11A00.CA11A01_0;
package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1;
use Widget_Pkg; -- All user-defined operators directly visible.
Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail";
Default_Widget : Widget;
Black_Widget : Color_Widget_Pkg.Color_Widget;
Mail_Widget : Label_Widget_Pkg.Label_Widget;
begin
Report.Test ("CA11A01", "Check that type extended in a public " &
"child inherits primitive operations from its " &
"ancestor");
Set_Width (Default_Widget, 9); -- Call from parent.
Set_Height (Default_Widget, 10); -- Call from parent.
If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or
Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then
Report.Failed ("Incorrect result for Default_Widget");
end if;
Color_Widget_Pkg.Set_Color_Widget
(Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared.
If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or
Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or
Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then
Report.Failed ("Incorrect result for Black_Widget");
end if;
Label_Widget_Pkg.Set_Label_Widget
(Mail_Widget, 15, 21, Color_Widget_Pkg.White,
"Quick_Mail"); -- Explicitly declared.
If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or
not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then
Report.Failed ("Incorrect result for Mail_Widget");
end if;
Report.Result;
end CA11A01;
|
