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
|
-- C392004.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 subprograms inherited from tagged derivations, which are
-- subsequently redefined for the derived type, are available to the
-- package defining the new class via view conversion. Check
-- that operations performed on objects using view conversion do not
-- affect the extended fields. Check that visible operations not masked
-- by the deriving package remain available to the client, and do not
-- affect the extended fields.
--
-- TEST DESCRIPTION:
-- This test declares a tagged type, with a constructor operation,
-- derives a type from that tagged type, and declares a constructor
-- operation which masks the inherited operation. It then tests
-- that the correct constructor is called, and that the extended
-- part of the derived type remains untouched as appropriate.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 19 Dec 94 SAIC Removed RM references from objective text.
-- 04 Jan 94 SAIC Fixed objective typo, removed dead code.
--
--!
with Report;
package C392004_1 is
type Vehicle is tagged private;
procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural );
procedure Start ( The_Vehicle : in out Vehicle );
private
type Vehicle is tagged record
Engine_On : Boolean;
end record;
end C392004_1;
package body C392004_1 is
procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is
begin
case TC_Flag is
when 1 => null; -- expected flag for this subprogram
when others =>
Report.Failed ("Called Vehicle Create");
end case;
The_Vehicle := (Engine_On => False);
end Create;
procedure Start ( The_Vehicle : in out Vehicle ) is
begin
The_Vehicle.Engine_On := True;
end Start;
end C392004_1;
----------------------------------------------------------------------------
with C392004_1;
package C392004_2 is
type Car is new C392004_1.Vehicle with record
Convertible : Boolean;
end record;
-- masking definition
procedure Create( The_Car : out Car; TC_Flag : Natural );
type Limo is new Car with null record;
procedure Create( The_Limo : out Limo; TC_Flag : Natural );
end C392004_2;
----------------------------------------------------------------------------
with Report;
package body C392004_2 is
procedure Create( The_Car : out Car; TC_Flag : Natural ) is
begin
case TC_Flag is
when 2 => null; -- expected flag for this subprogram
when others => Report.Failed ("Called Car Create");
end case;
C392004_1.Create( C392004_1.Vehicle(The_Car), 1);
The_Car.Convertible := False;
end Create;
procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is
begin
case TC_Flag is
when 3 => null; -- expected flag for this subprogram
when others => Report.Failed ("Called Limo Create");
end case;
C392004_1.Create( C392004_1.Vehicle(The_Limo), 1);
The_Limo.Convertible := True;
end Create;
end C392004_2;
----------------------------------------------------------------------------
with Report;
with C392004_1; use C392004_1;
with C392004_2; use C392004_2;
procedure C392004 is
My_Car : Car;
Your_Car : Limo;
procedure TC_Assert( Is_True : Boolean; Message : String ) is
begin
if not Is_True then
Report.Failed (Message);
end if;
end TC_Assert;
begin -- Main test procedure.
Report.Test ("C392004", "Check subprogram inheritance & visibility " &
"for derived tagged types" );
My_Car.Convertible := False;
Create( Vehicle( My_Car ), 1 );
TC_Assert( not My_Car.Convertible, "Altered descendent component 1");
Create( Your_Car, 3 );
TC_Assert( Your_Car.Convertible, "Did not set inherited component 2");
My_Car.Convertible := True;
Create( Vehicle( My_Car ), 1 );
TC_Assert( My_Car.Convertible, "Altered descendent component 3");
Create( My_Car, 2 );
TC_Assert( not My_Car.Convertible, "Did not set extending component 4");
My_Car.Convertible := False;
Start( Vehicle( My_Car ) );
TC_Assert( not My_Car.Convertible , "Altered descendent component 5");
Start( My_Car );
TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6");
Your_Car.Convertible := False;
Start( Vehicle( Your_Car ) );
TC_Assert( not Your_Car.Convertible , "Altered descendent component 7");
Start( Your_Car );
TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8");
My_Car.Convertible := True;
Start( Vehicle( My_Car ) );
TC_Assert( My_Car.Convertible, "Altered descendent component 9");
Start( My_Car );
TC_Assert( My_Car.Convertible, "Altered unreferenced component 10");
Report.Result;
end C392004;
|
