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
|
-- CA11A02.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 a type extended in a client of a public child inherits
-- primitive operations from parent.
--
-- 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.
--
-- In the main program, "with" the child. Declare an extension of
-- the child extension. Access the primitive operations from both
-- parent and child packages.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11A00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 20 Dec 94 SAIC Moved declaration of Label_Widget to library level
--
--!
package FA11A00.CA11A02_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 parent.
-- Inherits procedure Set_Height from parent.
-- To be inherited by its derivatives.
procedure Set_Color (The_Widget : in out Color_Widget;
C : in Widget_Color_Enum);
end FA11A00.CA11A02_0; -- Color_Widget_Pkg
--=======================================================================--
package body FA11A00.CA11A02_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;
end FA11A00.CA11A02_0; -- Color_Widget_Pkg
--=======================================================================--
with FA11A00.CA11A02_0; -- Color_Widget_Pkg.
package CA11A02_1 is
type Label_Widget (Str_Disc : Integer) is new
FA11A00.CA11A02_0.Color_Widget with
record
Label : String (1 .. Str_Disc);
end record;
-- Inherits (inherited) procedure Set_Width from Color_Widget.
-- Inherits (inherited) procedure Set_Height from Color_Widget.
-- Inherits procedure Set_Color from Color_Widget.
end CA11A02_1;
--=======================================================================--
with FA11A00.CA11A02_0; -- Color_Widget_Pkg,
-- implicitly with Widget_Pkg
with CA11A02_1;
with Report;
procedure CA11A02 is
package Widget_Pkg renames FA11A00;
package Color_Widget_Pkg renames FA11A00.CA11A02_0;
use Widget_Pkg; -- All user-defined operators directly visible.
procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget;
L : in String) is
begin
The_Widget.Label := L;
end Set_Label;
---------------------------------------------------------
procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in
Color_Widget_Pkg.Widget_Color_Enum;
The_Label : in String) is
begin
CA11A02_1.Set_Width (The_Widget, The_Width); -- Twice inherited.
CA11A02_1.Set_Height (The_Widget, The_Height); -- Twice inherited.
CA11A02_1.Set_Color (The_Widget, The_Color); -- Inherited.
Set_Label (The_Widget, The_Label); -- Explicitly declared.
end Set_Widget;
White_Widget : CA11A02_1.Label_Widget (11);
begin
Report.Test ("CA11A02", "Check that a type extended in a client of " &
"a public child inherits primitive operations from parent");
Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock");
If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or
White_Widget.Label /= "Alarm_Clock" then
Report.Failed ("Incorrect result for White_Widget");
end if;
Report.Result;
end CA11A02;
|
