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 for a call to a dispatching subprogram the subprogram
28 -- body which is executed is determined by the controlling tag for
29 -- the case where the call has dynamic tagged controlling operands
30 -- of the type T. Check for calls to these same subprograms where
31 -- the operands are of specific statically tagged types:
32 -- objects (declared or allocated), formal parameters, view
33 -- conversions, and function calls (both primitive and non-primitive).
36 -- This test uses foundation F392C00 to test the usages of statically
37 -- tagged objects and values. This test is derived in part from
42 -- 06 Dec 94 SAIC ACVC 2.0
43 -- 24 Oct 95 SAIC Updated for ACVC 2.0.1
50 procedure C392C07
is -- Hardware_Store
51 package Switch
renames F392C00_1
;
53 subtype Switch_Class
is Switch
.Toggle
'Class;
55 type Reference
is access all Switch_Class
;
57 A_Switch
: aliased Switch
.Toggle
;
58 A_Dimmer
: aliased Switch
.Dimmer
;
59 An_Autodim
: aliased Switch
.Auto_Dimmer
;
61 type Light_Bank
is array(Positive range <>) of Reference
;
63 Lamps
: Light_Bank
(1..3);
65 -- dynamically tagged controlling operands : class wide formal parameters
66 procedure Clamp
( Device
: in out Switch_Class
; On
: Boolean := False ) is
68 if Switch
.On
( Device
) /= On
then
69 Switch
.Flip
( Device
);
72 function Class_Item
(Bank_Pos
: Positive) return Switch_Class
is
74 return Lamps
(Bank_Pos
).all;
77 begin -- Main test procedure.
78 Report
.Test
("C392C07", "Check that a dispatching subprogram call is "
79 & "determined by the controlling tag for "
80 & "dynamically tagged controlling operands" );
82 Lamps
:= ( A_Switch
'Access, A_Dimmer
'Access, An_Autodim
'Access );
84 -- dynamically tagged operands referring to
85 -- statically tagged declared objects
86 for Knob
in Lamps
'Range loop
87 Clamp
( Lamps
(Knob
).all, On
=> True );
89 TCTouch
.Validate
( "BABGBABKGBA", "Clamping On Lamps" );
91 Lamps
(1) := new Switch
.Toggle
;
92 Lamps
(2) := new Switch
.Dimmer
;
93 Lamps
(3) := new Switch
.Auto_Dimmer
;
95 -- turn the full bank of switches ON
96 -- dynamically tagged allocated objects
97 for Knob
in Lamps
'Range loop
98 Clamp
( Lamps
(Knob
).all, On
=> True );
100 TCTouch
.Validate
( "BABGBABKGBA", "Dynamic Allocated");
102 -- Double check execution correctness
103 if Switch
.Off
( Lamps
(1).all )
104 or Switch
.Off
( Lamps
(2).all )
105 or Switch
.Off
( Lamps
(3).all ) then
106 Report
.Failed
( "Bad Value" );
108 TCTouch
.Validate
( "CCC", "Class-wide");
110 -- turn the full bank of switches OFF
111 for Knob
in Lamps
'Range loop
112 Switch
.Flip
( Lamps
(Knob
).all );
114 TCTouch
.Validate
( "AGBAKGBA", "Dynamic Allocated, Primitive Ops");
116 -- check switches for OFF
117 -- a few function calls as operands
118 for Knob
in Lamps
'Range loop
119 if not Switch
.Off
( Class_Item
(Knob
) ) then
120 Report
.Failed
("At function tests, Switch not OFF");
123 TCTouch
.Validate
( "CCC",
124 "Using function returning class-wide type");
126 -- Switches are all OFF now.
127 -- dynamically tagged view conversion
128 Clamp
( Switch_Class
( A_Switch
) );
129 Clamp
( Switch_Class
( A_Dimmer
) );
130 Clamp
( Switch_Class
( An_Autodim
) );
131 TCTouch
.Validate
( "BABGBABKGBA", "View Conversions" );
133 -- dynamically tagged controlling operands : declared class wide objects
134 -- calling primitive functions
136 Dine_O_Might
: Switch_Class
:= Switch
.TC_CW_TI
( 't' );
138 Switch
.Flip
( Dine_O_Might
);
139 if Switch
.On
( Dine_O_Might
) then
140 Report
.Failed
( "Exploded at Dine_O_Might" );
142 TCTouch
.Validate
( "WAB", "Dispatching function 1" );
146 Dyne_A_Mite
: Switch_Class
:= Switch
.TC_CW_TI
( 'd' );
148 Switch
.Flip
( Dyne_A_Mite
);
149 if Switch
.On
( Dyne_A_Mite
) then
150 Report
.Failed
( "Exploded at Dyne_A_Mite" );
152 TCTouch
.Validate
( "WGBAB", "Dispatching function 2" );
156 Din_Um_Out
: Switch_Class
:= Switch
.TC_CW_TI
( 'a' );
158 Switch
.Flip
( Din_Um_Out
);
159 if Switch
.Off
( Din_Um_Out
) then
160 Report
.Failed
( "Exploded at Din_Um_Out" );
162 TCTouch
.Validate
( "WKCC", "Dispatching function 3" );
164 -- Non-dispatching function calls.
165 if not Switch
.TC_Non_Disp
( Switch
.Toggle
( Din_Um_Out
) ) then
166 Report
.Failed
( "Non primitive, via view conversion" );
168 TCTouch
.Validate
( "X", "View Conversion 1" );
170 if not Switch
.TC_Non_Disp
( Switch
.Dimmer
( Din_Um_Out
) ) then
171 Report
.Failed
( "Non primitive, via view conversion" );
173 TCTouch
.Validate
( "Y", "View Conversion 2" );
176 -- a few more function calls as operands (oops)
177 if not Switch
.On
( Switch
.Toggle
'( Switch.Create ) ) then
178 Report.Failed("Toggle did not create ""On""");
181 if Switch.Off( Switch.Dimmer'( Switch
.Create
) ) then
182 Report
.Failed
("Dimmer created ""Off""");
185 if Switch
.Off
( Switch
.Auto_Dimmer
'( Switch.Create ) ) then
186 Report.Failed("Auto_Dimmer created ""Off""");