Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c392c05.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 -- C392C05.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 statically tagged controlling operands
30 -- of the type T. Check this for various operands of tagged types:
31 -- objects (declared or allocated), formal parameters, view conversions,
32 -- function calls (both primitive and non-primitive).
33 --
34 -- TEST DESCRIPTION:
35 -- This test uses foundation F392C00 to test the usages of statically
36 -- tagged objects and values. The calls to Validate indicate the
37 -- expected sequence of procedure calls since the previous call to
38 -- Validate. Static tags can be determined at compile time, and
39 -- hence this is a test of correct overload resolution for tagged types.
40 -- A clever compiler which unrolls loops and does path analysis on
41 -- access values will be able to perform the same kind of determination
42 -- for all of the code in this test.
43 --
44 -- TEST FILES:
45 -- The following files comprise this test:
46 --
47 -- F392C00.A (foundation code)
48 -- C392C05.A
49 --
50 --
51 -- CHANGE HISTORY:
52 -- 06 Dec 94 SAIC ACVC 2.0
53 -- 19 Dec 94 SAIC Removed RM references from objective text.
54 -- 24 Oct 95 SAIC Updated for ACVC 2.0.1
55 -- 13 Feb 97 PWB.CTA Corrected assumption that "or" operands are
56 -- evaluated in textual order.
57 --!
58
59 with Report;
60 with TCTouch;
61 with F392C00_1;
62 procedure C392C05 is -- Hardware_Store
63
64 package Switch renames F392C00_1;
65
66 subtype Switch_Class is Switch.Toggle'Class;
67
68 type Reference is access all Switch_Class;
69
70 A_Switch : aliased Switch.Toggle;
71 A_Dimmer : aliased Switch.Dimmer;
72 An_Autodim : aliased Switch.Auto_Dimmer;
73
74 type Light_Bank is array(Positive range <>) of Reference;
75
76 Lamps : Light_Bank(1..3);
77
78 begin -- Main test procedure.
79
80 Report.Test ("C392C05", "Check that a dispatching subprogram call is "
81 & "determined by the controlling tag for statically "
82 & "tagged controlling operands" );
83
84 -- Check use of static tagged declared objects,
85 -- and static tagged formal parameters
86 -- Must call correct version of flip based on type of controlling op.
87
88 -- Turn on the lights!
89
90 Switch.Flip( A_Switch );
91 TCTouch.Validate( "A", "Declared Toggle" );
92
93 Switch.Flip( A_Dimmer );
94 TCTouch.Validate( "GBA", "Declared Dimmer" );
95
96 Switch.Flip( An_Autodim );
97 TCTouch.Validate( "KGBA", "Declared Auto_Dimmer" );
98
99 Lamps(1) := new Switch.Toggle;
100 Lamps(2) := new Switch.Dimmer;
101 Lamps(3) := new Switch.Auto_Dimmer;
102
103 -- Check use of static tagged allocated objects,
104 -- and static tagged formal parameters in a loop which may dynamically
105 -- dispatch. If an optimizer unrolls the loop, it may then be statically
106 -- determined, and no dispatching will occur. Either interpretation is
107 -- correct.
108 for Knob in Lamps'Range loop
109 Switch.Flip( Lamps(Knob).all );
110 end loop;
111 TCTouch.Validate( "AGBAKGBA", "Allocated Objects" );
112
113 -- Check use of static tagged declared objects,
114 -- calling non-primitive functions.
115 if not Switch.TC_Non_Disp( A_Switch ) then
116 Report.Failed( "Bad Value 1" );
117 end if;
118 TCTouch.Validate( "X", "Nonprimitive Function" );
119
120 if not Switch.TC_Non_Disp( A_Dimmer ) then
121 Report.Failed( "Bad Value 2" );
122 end if;
123 TCTouch.Validate( "Y", "Nonprimitive Function" );
124
125 if not Switch.TC_Non_Disp( An_Autodim ) then
126 Report.Failed( "Bad Value 3" );
127 end if;
128 TCTouch.Validate( "Z", "Nonprimitive Function" );
129
130 A_Switch := Switch.Create;
131 A_Dimmer := Switch.Create;
132 An_Autodim := Switch.Create;
133 TCTouch.Validate( "123", "Primitive Function" );
134
135 -- View conversions
136 Switch.Brighten( An_Autodim, 50 );
137
138 Switch.Flip( Switch.Toggle( A_Switch ) );
139 Switch.Flip( Switch.Toggle( A_Dimmer ) );
140 Switch.Flip( Switch.Dimmer( An_Autodim ) );
141 TCTouch.Validate( "DAAGBA", "View Conversions" );
142
143 -- statically tagged controlling operands (specific types) provided to
144 -- class-wide functions
145 if Switch.On( A_Switch )
146 or Switch.On( A_Dimmer )
147 or Switch.On( An_Autodim ) then
148 Report.Failed( "Bad Value 4" );
149 end if;
150 TCTouch.Validate( "BBB", "Class-wide" );
151
152 -- statically tagged controlling operands qualified expressions provided to
153 -- primitive functions, also using context to determine call to a
154 -- class-wide function.
155 if Switch.Off( Switch.Toggle'( Switch.Create ) )
156 or else Switch.Off( Switch.Dimmer'( Switch.Create ) )
157 or else Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then
158 Report.Failed( "Bad Value 5" );
159 end if;
160 TCTouch.Validate( "1C2C3C", "Qualified Expression/Class-Wide" );
161
162 Report.Result;
163
164 end C392C05;