|
111
|
1 -- C392C07.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 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).
|
|
|
34 --
|
|
|
35 -- TEST DESCRIPTION:
|
|
|
36 -- This test uses foundation F392C00 to test the usages of statically
|
|
|
37 -- tagged objects and values. This test is derived in part from
|
|
|
38 -- C392C05.
|
|
|
39 --
|
|
|
40 --
|
|
|
41 -- CHANGE HISTORY:
|
|
|
42 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
43 -- 24 Oct 95 SAIC Updated for ACVC 2.0.1
|
|
|
44 --
|
|
|
45 --!
|
|
|
46
|
|
|
47 with Report;
|
|
|
48 with TCTouch;
|
|
|
49 with F392C00_1;
|
|
|
50 procedure C392C07 is -- Hardware_Store
|
|
|
51 package Switch renames F392C00_1;
|
|
|
52
|
|
|
53 subtype Switch_Class is Switch.Toggle'Class;
|
|
|
54
|
|
|
55 type Reference is access all Switch_Class;
|
|
|
56
|
|
|
57 A_Switch : aliased Switch.Toggle;
|
|
|
58 A_Dimmer : aliased Switch.Dimmer;
|
|
|
59 An_Autodim : aliased Switch.Auto_Dimmer;
|
|
|
60
|
|
|
61 type Light_Bank is array(Positive range <>) of Reference;
|
|
|
62
|
|
|
63 Lamps : Light_Bank(1..3);
|
|
|
64
|
|
|
65 -- dynamically tagged controlling operands : class wide formal parameters
|
|
|
66 procedure Clamp( Device : in out Switch_Class; On : Boolean := False ) is
|
|
|
67 begin
|
|
|
68 if Switch.On( Device ) /= On then
|
|
|
69 Switch.Flip( Device );
|
|
|
70 end if;
|
|
|
71 end Clamp;
|
|
|
72 function Class_Item(Bank_Pos: Positive) return Switch_Class is
|
|
|
73 begin
|
|
|
74 return Lamps(Bank_Pos).all;
|
|
|
75 end Class_Item;
|
|
|
76
|
|
|
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" );
|
|
|
81
|
|
|
82 Lamps := ( A_Switch'Access, A_Dimmer'Access, An_Autodim'Access );
|
|
|
83
|
|
|
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 );
|
|
|
88 end loop;
|
|
|
89 TCTouch.Validate( "BABGBABKGBA", "Clamping On Lamps" );
|
|
|
90
|
|
|
91 Lamps(1) := new Switch.Toggle;
|
|
|
92 Lamps(2) := new Switch.Dimmer;
|
|
|
93 Lamps(3) := new Switch.Auto_Dimmer;
|
|
|
94
|
|
|
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 );
|
|
|
99 end loop;
|
|
|
100 TCTouch.Validate( "BABGBABKGBA", "Dynamic Allocated");
|
|
|
101
|
|
|
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" );
|
|
|
107 end if;
|
|
|
108 TCTouch.Validate( "CCC", "Class-wide");
|
|
|
109
|
|
|
110 -- turn the full bank of switches OFF
|
|
|
111 for Knob in Lamps'Range loop
|
|
|
112 Switch.Flip( Lamps(Knob).all );
|
|
|
113 end loop;
|
|
|
114 TCTouch.Validate( "AGBAKGBA", "Dynamic Allocated, Primitive Ops");
|
|
|
115
|
|
|
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");
|
|
|
121 end if;
|
|
|
122 end loop;
|
|
|
123 TCTouch.Validate( "CCC",
|
|
|
124 "Using function returning class-wide type");
|
|
|
125
|
|
|
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" );
|
|
|
132
|
|
|
133 -- dynamically tagged controlling operands : declared class wide objects
|
|
|
134 -- calling primitive functions
|
|
|
135 declare
|
|
|
136 Dine_O_Might : Switch_Class := Switch.TC_CW_TI( 't' );
|
|
|
137 begin
|
|
|
138 Switch.Flip( Dine_O_Might );
|
|
|
139 if Switch.On( Dine_O_Might ) then
|
|
|
140 Report.Failed( "Exploded at Dine_O_Might" );
|
|
|
141 end if;
|
|
|
142 TCTouch.Validate( "WAB", "Dispatching function 1" );
|
|
|
143 end;
|
|
|
144
|
|
|
145 declare
|
|
|
146 Dyne_A_Mite : Switch_Class := Switch.TC_CW_TI( 'd' );
|
|
|
147 begin
|
|
|
148 Switch.Flip( Dyne_A_Mite );
|
|
|
149 if Switch.On( Dyne_A_Mite ) then
|
|
|
150 Report.Failed( "Exploded at Dyne_A_Mite" );
|
|
|
151 end if;
|
|
|
152 TCTouch.Validate( "WGBAB", "Dispatching function 2" );
|
|
|
153 end;
|
|
|
154
|
|
|
155 declare
|
|
|
156 Din_Um_Out : Switch_Class := Switch.TC_CW_TI( 'a' );
|
|
|
157 begin
|
|
|
158 Switch.Flip( Din_Um_Out );
|
|
|
159 if Switch.Off( Din_Um_Out ) then
|
|
|
160 Report.Failed( "Exploded at Din_Um_Out" );
|
|
|
161 end if;
|
|
|
162 TCTouch.Validate( "WKCC", "Dispatching function 3" );
|
|
|
163
|
|
|
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" );
|
|
|
167 end if;
|
|
|
168 TCTouch.Validate( "X", "View Conversion 1" );
|
|
|
169
|
|
|
170 if not Switch.TC_Non_Disp( Switch.Dimmer( Din_Um_Out ) ) then
|
|
|
171 Report.Failed( "Non primitive, via view conversion" );
|
|
|
172 end if;
|
|
|
173 TCTouch.Validate( "Y", "View Conversion 2" );
|
|
|
174 end;
|
|
|
175
|
|
|
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""");
|
|
|
179 end if;
|
|
|
180
|
|
|
181 if Switch.Off( Switch.Dimmer'( Switch.Create ) ) then
|
|
|
182 Report.Failed("Dimmer created ""Off""");
|
|
|
183 end if;
|
|
|
184
|
|
|
185 if Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then
|
|
|
186 Report.Failed("Auto_Dimmer created ""Off""");
|
|
|
187 end if;
|
|
|
188
|
|
|
189 Report.Result;
|
|
|
190 end C392C07;
|
