Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c3a0009.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 -- C3A0009.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 subprogram references may be passed as parameters using
28 -- access-to-subprogram types. Check that the passed subprograms may
29 -- be invoked from within the called subprogram.
30 --
31 -- TEST DESCRIPTION:
32 -- Declare an access to procedure type in a package specification.
33 -- Declare a root tagged type with the access to procedure type as a
34 -- component. Declare three primitive procedures for the type that
35 -- can be referred to by the access to procedure type. Use the access
36 -- to procedure type to initialize the component of a record.
37 --
38 -- Extend the root type with a private extension in the same package
39 -- specification. Declare two new primitive subprograms for the extension
40 -- (in addition to its three inherited subprograms).
41 --
42 -- In the main program, declare an operation for the root tagged type
43 -- which can be passed as an access value to change the initial value
44 -- of the component. Call the inherited operations indirectly by
45 -- de-referencing the access value to set value in the extension.
46 -- Call the primitive function to modify the extension by passing
47 -- the access value designating the primitive procedure as a parameter.
48 --
49 --
50 -- CHANGE HISTORY:
51 -- 06 Dec 94 SAIC ACVC 2.0
52 --
53 --!
54
55 package C3A0009_0 is -- Push_Buttons
56
57 type Button is tagged private;
58
59 -- Type accesses to procedures Push and Default_Response
60 type Button_Response_Ptr is access procedure
61 (B : in out Button);
62
63 procedure Push (B : in out Button); -- to be inherited
64
65 procedure Set_Response (B : in out Button; -- to be inherited
66 R : in Button_Response_Ptr);
67
68 procedure Default_Response (B : in out Button); -- to be inherited
69
70 type Alert_Button is new Button with private; -- private extension of
71 -- root tagged type
72 -- Inherits procedure Push from Button
73 -- Inherits procedure Set_Response from Button
74 -- Inherits procedure Default_Response from Button
75
76 procedure Replace_Action( B: in out Alert_Button );
77
78 -- type accesses to procedure Default_Action
79 type Button_Action_Ptr is access procedure;
80
81 -- The following function is needed to set value in the
82 -- extension's private component.
83 function Alert (B : in Alert_Button) return Button_Action_Ptr;
84
85 private
86
87 type Button is tagged -- root tagged type
88 record
89 Response : Button_Response_Ptr
90 := Default_Response'Access;
91 end record;
92
93 procedure Default_Action;
94
95 type Alert_Button is new Button with record
96 Action : Button_Action_Ptr
97 := Default_Action'Access;
98 end record;
99
100 end C3A0009_0;
101
102
103 -----------------------------------------------------------------------------
104
105
106 with TCTouch;
107 package body C3A0009_0 is
108
109 procedure Push (B : in out Button) is
110 begin
111 TCTouch.Touch( 'P' ); --------------------------------------------- P
112 -- Invoking subprogram designated by access value
113 B.Response (B);
114 end Push;
115
116
117 procedure Set_Response (B : in out Button;
118 R : in Button_Response_Ptr) is
119 begin
120 TCTouch.Touch( 'S' ); --------------------------------------------- S
121 -- Set procedure value in record
122 B.Response := R;
123 end Set_Response;
124
125
126 procedure Default_Response (B : in out Button) is
127 begin
128 TCTouch.Touch( 'D' ); --------------------------------------------- D
129 end Default_Response;
130
131
132 procedure Default_Action is
133 begin
134 TCTouch.Touch( 'd' ); --------------------------------------------- d
135 end Default_Action;
136
137 procedure Replacement_Action is
138 begin
139 TCTouch.Touch( 'r' ); --------------------------------------------- r
140 end Replacement_Action;
141
142 procedure Replace_Action( B: in out Alert_Button ) is
143 begin
144 TCTouch.Touch( 'R' ); --------------------------------------------- R
145 B.Action := Replacement_Action'Access;
146 end Replace_Action;
147
148 function Alert (B : in Alert_Button) return Button_Action_Ptr is
149 begin
150 TCTouch.Touch( 'A' ); --------------------------------------------- A
151 return (B.Action);
152 end Alert;
153
154 end C3A0009_0;
155
156 -----------------------------------------------------------------------------
157
158 with C3A0009_0;
159 package C3A0009_1 is -- Emergency_Items
160 package Push_Buttons renames C3A0009_0;
161
162 procedure Emergency (B : in out Push_Buttons.Button);
163 end C3A0009_1;
164
165 with TCTouch;
166 package body C3A0009_1 is -- Emergency_Items
167 procedure Emergency (B : in out Push_Buttons.Button) is
168 begin
169 TCTouch.Touch( 'E' ); ------------------------------------------- E
170 end Emergency;
171 end C3A0009_1;
172 -----------------------------------------------------------------------------
173
174 with Report;
175
176 with C3A0009_0, C3A0009_1;
177 with TCTouch;
178 procedure C3A0009 is
179
180 package Push_Buttons renames C3A0009_0;
181 package Emergency_Items renames C3A0009_1;
182
183 Black_Button : Push_Buttons.Alert_Button;
184 Alert_Ptr : Push_Buttons.Button_Action_Ptr;
185
186 begin
187
188 Report.Test ("C3A0009", "Check that subprogram references may be passed "
189 & "as parameters using access-to-subprogram types. "
190 & "Check that the passed subprograms may be "
191 & "invoked from within the called subprogram");
192
193
194 Push_Buttons.Push( Black_Button );
195 Push_Buttons.Alert( Black_Button ).all;
196
197 TCTouch.Validate( "PDAd", "Default operation set" );
198
199 -- Call inherited operations Set_Response and Push to set
200 -- Emergency value in the extension.
201 Push_Buttons.Set_Response (Black_Button, Emergency_Items.Emergency'Access);
202
203
204 Push_Buttons.Push( Black_Button );
205 Push_Buttons.Alert( Black_Button ).all;
206
207 TCTouch.Validate( "SPEAd", "Altered Response set" );
208
209 -- Call primitive operation to set action value in the extension.
210 Push_Buttons.Replace_Action( Black_Button );
211
212
213 Push_Buttons.Push( Black_Button );
214 Push_Buttons.Alert( Black_Button ).all;
215
216 TCTouch.Validate( "RPEAr", "Altered Action set" );
217
218 Report.Result;
219 end C3A0009;