1-- CA11A01.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 type extended in a public child inherits primitive
28--      operations from its ancestor.
29--
30-- TEST DESCRIPTION:
31--      Declare a root tagged type in a package specification. Declare two
32--      primitive subprograms for the type (foundation code).
33--
34--      Add a public child to the above package.  Extend the root type with
35--      a record extension in the specification.  Declare a new primitive
36--      subprogram to write to the child extension.
37--
38--      Add a public grandchild to the above package.  Extend the extension of
39--      the parent type with a record extension in the private part of the
40--      specification.  Declare a new primitive subprogram for this grandchild
41--      extension.
42--
43--      In the main program, "with" the grandchild.  Access the primitive
44--      operations from grandparent and parent package.
45--
46-- TEST FILES:
47--      This test depends on the following foundation code:
48--
49--         FA11A00.A
50--
51--
52-- CHANGE HISTORY:
53--      06 Dec 94   SAIC    ACVC 2.0
54--
55--!
56
57package FA11A00.CA11A01_0 is     -- Color_Widget_Pkg
58-- This public child declares an extension from its parent.  It
59-- represents processing of widgets in a window system.
60
61   type Widget_Color_Enum is (Black, Green, White);
62
63   type Color_Widget is new Widget with           -- Record extension of
64      record                                      -- parent tagged type.
65         Color : Widget_Color_Enum;
66      end record;
67
68   -- Inherits procedure Set_Width from Widget.
69   -- Inherits procedure Set_Height from Widget.
70
71   -- To be inherited by its derivatives.
72   procedure Set_Color (The_Widget : in out Color_Widget;
73                        C          : in     Widget_Color_Enum);
74
75   procedure Set_Color_Widget (The_Widget : in out Color_Widget;
76                               The_Width  : in     Widget_Length;
77                               The_Height : in     Widget_Length;
78                               The_Color  : in     Widget_Color_Enum);
79
80end FA11A00.CA11A01_0;     -- Color_Widget_Pkg
81
82--=======================================================================--
83
84package body FA11A00.CA11A01_0 is     -- Color_Widget_Pkg
85
86   procedure Set_Color (The_Widget : in out Color_Widget;
87                        C          : in     Widget_Color_Enum) is
88   begin
89      The_Widget.Color := C;
90   end Set_Color;
91   ---------------------------------------------------------------
92   procedure Set_Color_Widget (The_Widget : in out Color_Widget;
93                               The_Width  : in     Widget_Length;
94                               The_Height : in     Widget_Length;
95                               The_Color  : in     Widget_Color_Enum) is
96   begin
97      Set_Width  (The_Widget, The_Width);   -- Inherited from parent.
98      Set_Height (The_Widget, The_Height);  -- Inherited from parent.
99      Set_Color  (The_Widget, The_Color);
100   end Set_Color_Widget;
101
102end FA11A00.CA11A01_0;     -- Color_Widget_Pkg
103
104--=======================================================================--
105
106package FA11A00.CA11A01_0.CA11A01_1 is     -- Label_Widget_Pkg
107-- This public grandchild extends the extension from its parent.  It
108-- represents processing of widgets in a window system.
109
110   -- Declaration used by private extension component.
111   subtype Widget_Label_Str is string (1 .. 10);
112
113   type Label_Widget is new Color_Widget with private;
114                            -- Record extension of parent tagged type.
115
116   -- Inherits (inherited) procedure Set_Width from Color_Widget.
117   -- Inherits (inherited) procedure Set_Height from Color_Widget.
118   -- Inherits procedure Set_Color from Color_Widget.
119   -- Inherits procedure Set_Color_Widget from Color_Widget.
120
121   procedure Set_Label_Widget (The_Widget : in out Label_Widget;
122                               The_Width  : in     Widget_Length;
123                               The_Height : in     Widget_Length;
124                               The_Color  : in     Widget_Color_Enum;
125                               The_Label  : in     Widget_Label_Str);
126
127   -- The following function is needed to verify the value of the
128   -- extension's private component.
129
130   function Verify_Label (The_Widget : in Label_Widget;
131                          The_Label  : in Widget_Label_Str) return Boolean;
132
133private
134   type Label_Widget is new Color_Widget with
135      record
136         Label : Widget_Label_Str;
137      end record;
138
139end FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg
140
141--=======================================================================--
142
143package body FA11A00.CA11A01_0.CA11A01_1 is     -- Label_Widget_Pkg
144
145   procedure Set_Label (The_Widget : in out Label_Widget;
146                        L          : in     Widget_Label_Str) is
147   begin
148      The_Widget.Label := L;
149   end Set_Label;
150   --------------------------------------------------------------
151   procedure Set_Label_Widget (The_Widget : in out Label_Widget;
152                               The_Width  : in     Widget_Length;
153                               The_Height : in     Widget_Length;
154                               The_Color  : in     Widget_Color_Enum;
155                               The_Label  : in     Widget_Label_Str) is
156   begin
157      Set_Width  (The_Widget, The_Width);   -- Twice inherited.
158      Set_Height (The_Widget, The_Height);  -- Twice inherited.
159      Set_Color  (The_Widget, The_Color);   -- Inherited from parent.
160      Set_Label  (The_Widget, The_Label);
161   end Set_Label_Widget;
162   --------------------------------------------------------------
163   function Verify_Label (The_Widget : in Label_Widget;
164                          The_Label  : in Widget_Label_Str) return Boolean is
165   begin
166      return (The_Widget.Label = The_Label);
167   end Verify_Label;
168
169end FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg
170
171--=======================================================================--
172
173with FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg,
174                                      -- implicitly with Widget_Pkg,
175                                      -- implicitly with Color_Widget_Pkg
176with Report;
177
178procedure CA11A01 is
179
180   package Widget_Pkg renames FA11A00;
181   package Color_Widget_Pkg renames FA11A00.CA11A01_0;
182   package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1;
183
184   use Widget_Pkg;              -- All user-defined operators directly visible.
185
186   Mail_Label     : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail";
187
188   Default_Widget : Widget;
189   Black_Widget   : Color_Widget_Pkg.Color_Widget;
190   Mail_Widget    : Label_Widget_Pkg.Label_Widget;
191
192begin
193
194   Report.Test ("CA11A01", "Check that type extended in a public " &
195                "child inherits primitive operations from its " &
196                "ancestor");
197
198   Set_Width (Default_Widget, 9);             -- Call from parent.
199   Set_Height (Default_Widget, 10);           -- Call from parent.
200
201   If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or
202     Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then
203        Report.Failed ("Incorrect result for Default_Widget");
204   end if;
205
206   Color_Widget_Pkg.Set_Color_Widget
207     (Black_Widget, 17, 18, Color_Widget_Pkg.Black);   -- Explicitly declared.
208
209   If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or
210     Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or
211       Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then
212          Report.Failed ("Incorrect result for Black_Widget");
213   end if;
214
215   Label_Widget_Pkg.Set_Label_Widget
216     (Mail_Widget, 15, 21, Color_Widget_Pkg.White,
217       "Quick_Mail");                                  -- Explicitly declared.
218
219   If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
220     Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
221       Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or
222         not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then
223            Report.Failed ("Incorrect result for Mail_Widget");
224   end if;
225
226   Report.Result;
227
228end CA11A01;
229