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, in an instance, each implicit declaration of a user-defined
28 -- subprogram of a formal derived record type declares a view of the
29 -- corresponding primitive subprogram of the ancestor, even if the
30 -- primitive subprogram has been overridden for the actual type.
33 -- Declare a "fraction" type abstraction in a package (foundation code).
34 -- Declare a "fraction" I/O routine in a generic package with a formal
35 -- derived type whose ancestor type is the fraction type declared in
36 -- the first package. Within the I/O routine, call other operations of
37 -- ancestor type. Derive from the root fraction type in another package
38 -- and override one of the operations called in the generic I/O routine.
39 -- Derive from the derivative of the root fraction type. Instantiate
40 -- the generic package for each of the three types and call the I/O
44 -- The following files comprise this test:
51 -- 06 Dec 94 SAIC ACVC 2.0
55 with FC51A00
; -- Fraction type abstraction.
56 generic -- Fraction I/O support.
57 type Fraction
is new FC51A00
.Fraction_Type
; -- Formal derived type of a
58 package CC51A01_0
is -- (private) record type.
60 -- Simulate writing a fraction to standard output. In a real application,
61 -- this subprogram might be a procedure which uses Text_IO routines. For
62 -- the purposes of the test, the "output" is returned to the caller as a
64 function Put
(Item
: in Fraction
) return String;
66 -- ... Other I/O operations for fractions.
71 --==================================================================--
74 package body CC51A01_0
is
76 function Put
(Item
: in Fraction
) return String is
77 Num
: constant String := -- Fraction's primitive subprograms
78 Integer'Image (Numerator
(Item
)); -- are inherited from its parent
79 Den
: constant String := -- (FC51A00.Fraction_Type) and NOT
80 Integer'Image (Denominator
(Item
)); -- from the actual type.
82 return (Num
& '/' & Den
);
88 --==================================================================--
91 with FC51A00
; -- Fraction type abstraction.
94 -- Derive directly from the root type of the class and override one of the
95 -- primitive subprograms.
97 type Pos_Fraction
is new FC51A00
.Fraction_Type
; -- Derived directly from
98 -- root type of class.
99 -- Inherits "/" from root type.
100 -- Inherits "-" from root type.
101 -- Inherits Numerator from root type.
102 -- Inherits Denominator from root type.
104 -- Return absolute value of numerator as integer.
105 function Numerator
(Frac
: Pos_Fraction
) -- Overrides parent's
106 return Integer; -- operation.
111 --==================================================================--
114 package body CC51A01_1
is
116 -- This body should never be called.
118 -- The test sends the function Numerator a fraction with a negative
119 -- numerator, and expects this negative numerator to be returned. This
120 -- version of the function returns the absolute value of the numerator.
121 -- Thus, a call to this version is detectable by examining the sign
122 -- of the return value.
124 function Numerator
(Frac
: Pos_Fraction
) return Integer is
125 Converted_Frac
: FC51A00
.Fraction_Type
:= FC51A00
.Fraction_Type
(Frac
);
126 Orig_Numerator
: Integer := FC51A00
.Numerator
(Converted_Frac
);
128 return abs (Orig_Numerator
);
134 --==================================================================--
137 with FC51A00
; -- Fraction type abstraction.
138 with CC51A01_0
; -- Fraction I/O support.
139 with CC51A01_1
; -- Positive fraction type abstraction.
144 type Distance
is new CC51A01_1
.Pos_Fraction
; -- Derived indirectly from
145 -- root type of class.
146 -- Inherits "/" indirectly from root type.
147 -- Inherits "-" indirectly from root type.
148 -- Inherits Numerator directly from parent type.
149 -- Inherits Denominator indirectly from root type.
151 use FC51A00
, CC51A01_1
; -- All primitive subprograms
154 package Fraction_IO
is new CC51A01_0
(Fraction_Type
);
155 package Pos_Fraction_IO
is new CC51A01_0
(Pos_Fraction
);
156 package Distance_IO
is new CC51A01_0
(Distance
);
158 -- For each of the instances above, the subprogram "Put" should produce
159 -- the same result. That is, the primitive subprograms called by Put
160 -- should in all cases be those of the type Fraction_Type, which is the
161 -- ancestor type for the formal derived type in the generic unit. In
162 -- particular, for Pos_Fraction_IO and Distance_IO, the versions of
163 -- Numerator called should NOT be those of the actual types, which override
164 -- Fraction_Type's version.
166 TC_Expected_Result
: constant String := "-3/ 16";
168 TC_Root_Type_Of_Class
: Fraction_Type
:= -3/16;
169 TC_Direct_Derivative
: Pos_Fraction
:= -3/16;
170 TC_Indirect_Derivative
: Distance
:= -3/16;
173 Report
.Test
("CC51A01", "Check that, in an instance, each implicit " &
174 "declaration of a user-defined subprogram of a formal " &
175 "derived record type declares a view of the corresponding " &
176 "primitive subprogram of the ancestor, even if the " &
177 "primitive subprogram has been overridden for the actual " &
180 if (Fraction_IO
.Put
(TC_Root_Type_Of_Class
) /= TC_Expected_Result
) then
181 Report
.Failed
("Wrong result for root type");
184 if (Pos_Fraction_IO
.Put
(TC_Direct_Derivative
) /= TC_Expected_Result
) then
185 Report
.Failed
("Wrong result for direct derivative");
188 if (Distance_IO
.Put
(TC_Indirect_Derivative
) /= TC_Expected_Result
) then
189 Report
.Failed
("Wrong result for INdirect derivative");