Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c392c07.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;