3 -- Grant of Unlimited Rights
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
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.
27 -- Check that a type derived in a client of a public child inherits
28 -- primitive operations from parent.
31 -- Declare a root record type with discriminant in a package
32 -- specification. Declare a primitive subprogram for the type
35 -- Add a public child to the above package. Derive a new type
36 -- with constraint to the discriminant record type from the parent
37 -- package. Declare a new primitive subprogram to write to the child
40 -- In the main program, "with" the child. Derive a new type using the
41 -- record type from the child package. Access the inherited operations
42 -- from both parent and child packages.
45 -- This test depends on the following foundation code:
51 -- 06 Dec 94 SAIC ACVC 2.0
55 -- Child package of FA11B00.
56 package FA11B00
.CA11B02_0
is -- Application_Two_Widget
57 -- This public child declares a derived type from its parent. It
58 -- represents processing of widgets in a window system.
60 -- Dimension of app2_widget is limited to 5000 pixels.
62 type App2_Widget
is new App1_Widget
(Maximum_Size
=> 5000);
63 -- Derived record of parent type.
65 -- Inherits procedure App1_Widget_Specific_Oper from parent.
68 -- Primitive operation of type App2_Widget.
70 procedure App2_Widget_Specific_Op1
(The_Widget
: in out App2_Widget
;
73 -- Primitive operation of type App2_Widget.
75 procedure App2_Widget_Specific_Op2
(The_Widget
: in out App2_Widget
;
76 Loc
: in Widget_Location
);
78 end FA11B00
.CA11B02_0
; -- Application_Two_Widget
81 --=======================================================================--
84 package body FA11B00
.CA11B02_0
is -- Application_Two_Widget
86 procedure App2_Widget_Specific_Op1
(The_Widget
: in out App2_Widget
;
87 S
: in Widget_Size
) is
90 end App2_Widget_Specific_Op1
;
92 --==============================================--
94 procedure App2_Widget_Specific_Op2
(The_Widget
: in out App2_Widget
;
95 Loc
: in Widget_Location
) is
97 The_Widget
.Location
:= Loc
;
98 end App2_Widget_Specific_Op2
;
100 end FA11B00
.CA11B02_0
; -- Application_Two_Widget
103 --=======================================================================--
105 with FA11B00
.CA11B02_0
; -- Application_Two_Widget
106 -- implicitly with Application_One_Widget.
111 package Application_One_Widget
renames FA11B00
;
113 package Application_Two_Widget
renames FA11B00
.CA11B02_0
;
115 use Application_One_Widget
;
116 use Application_Two_Widget
;
118 type Emulator_Widget
is new App2_Widget
; -- Derived record of
121 White_Widget
, Amber_Widget
: Emulator_Widget
;
126 Report
.Test
("CA11B02", "Check that a type derived in client of a " &
127 "public child inherits primitive operations from parent");
129 App1_Widget_Specific_Oper
(C
=> White
, L
=> "Line Editor ",
130 The_Widget
=> White_Widget
, I
=> 10);
131 -- Inherited from Application_One_Widget.
132 If White_Widget
.Color
/= White
or
133 White_Widget
.Id
/= Widget_ID
(Report
.Ident_Int
(10)) or
134 White_Widget
.Label
/= "Line Editor "
136 Report
.Failed
("Incorrect result for White_Widget");
139 -- perform an App2_Widget specific operation.
141 App2_Widget_Specific_Op1
(White_Widget
, S
=> (100, 200));
143 If White_Widget
.Size
.X_Length
/= 100 or
144 White_Widget
.Size
.Y_Length
/= 200
146 Report
.Failed
("Incorrect size for White_Widget");
149 App1_Widget_Specific_Oper
(Amber_Widget
, 5, Amber
, "Screen Editor ");
150 -- Inherited from Application_One_Widget.
152 -- perform an App2_Widget specific operations.
154 App2_Widget_Specific_Op1
(S
=> (1024,100), The_Widget
=> Amber_Widget
);
155 App2_Widget_Specific_Op2
(Amber_Widget
, (1024, 760));
157 If Amber_Widget
.Color
/= Amber
or
158 Amber_Widget
.Id
/= Widget_ID
(Report
.Ident_Int
(5)) or
159 Amber_Widget
.Label
/= "Screen Editor " or
160 Amber_Widget
.Size
/= (1024,100) or
161 Amber_Widget
.Location
.X_Location
/= 1024 or
162 Amber_Widget
.Location
.Y_Location
/= 760
164 Report
.Failed
("Incorrect result for Amber_Widget");