Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cc/cc54003.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 -- CC54003.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 a general access-to-subprogram type may be passed as an
28 -- actual to a generic formal access-to-subprogram type. Check that
29 -- designated subprograms may be called by dereferencing the access
30 -- values.
31 --
32 -- TEST DESCRIPTION:
33 -- The generic implements a stack of access-to-subprogram objects as an
34 -- array. The profile of the access-to-subprogram formal corresponds to
35 -- a function which accepts a parameter of some type and returns an
36 -- object of the same type.
37 --
38 -- For this test, the functions for which access values will be pushed
39 -- onto the stack accept a parameter of type access-to-string, lengthen
40 -- the pointed-to string, then return an access object pointing to this
41 -- lengthened string.
42 --
43 -- The instance declares a function Execute_Stack which executes each
44 -- subprogram on the stack in sequence. This function accepts some initial
45 -- access-to-string, then returns an access object pointing to the
46 -- lengthened string resulting from the execution of the stacked
47 -- subprograms. Access-to-string objects are used rather than strings
48 -- themselves because the initial string "grows" during each iteration.
49 --
50 --
51 -- CHANGE HISTORY:
52 -- 06 Dec 94 SAIC ACVC 2.0
53 -- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
54 -- preceding CC54003_2.
55 --
56 --!
57
58 generic
59
60 Size : in Positive;
61
62 type Item_Type (<>) is private;
63 type Item_Ptr is access Item_Type;
64
65 type Function_Ptr is access function (Item : Item_Ptr)
66 return Item_Ptr;
67
68 package CC54003_0 is -- Generic stack of pointers.
69
70 type Stack_Type is private;
71
72 procedure Push (Stack : in out Stack_Type;
73 Func_Ptr : in Function_Ptr);
74
75 function Execute_Stack (Stack : Stack_Type;
76 Initial_Input : Item_Ptr) return Item_Ptr;
77
78 -- ... Other operations.
79
80 private
81
82 subtype Index is Positive range 1 .. (Size + 1);
83 type Stack_Type is array (Index) of Function_Ptr; -- Last slot unused.
84
85 Top : Index := 1; -- Top refers to the next available slot.
86
87 end CC54003_0;
88
89
90 --===================================================================--
91
92
93 package body CC54003_0 is
94
95 procedure Push (Stack : in out Stack_Type;
96 Func_Ptr : in Function_Ptr) is
97 begin
98 Stack(Top) := Func_Ptr;
99 Top := Top + 1; -- Artificial: no Constraint_Error protection.
100 end Push;
101
102
103 -- Call each subprogram on the stack in sequence. For the first call, pass
104 -- Initial_Input. For succeeding calls, pass the result of the previous
105 -- call.
106
107 function Execute_Stack (Stack : Stack_Type;
108 Initial_Input : Item_Ptr) return Item_Ptr is
109 Result : Item_Ptr := Initial_Input;
110 begin
111 for I in reverse Index'First .. (Top - 1) loop -- Artificial: no C_E
112 Result := Stack(I)(Result); -- protection.
113 end loop;
114 return Result;
115 end Execute_Stack;
116
117 end CC54003_0;
118
119
120 --===================================================================--
121
122
123 package CC54003_1 is
124
125 subtype Message is String;
126 type Message_Ptr is access Message;
127
128 function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr;
129 function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr;
130
131 -- ...Other operations.
132
133 end CC54003_1;
134
135
136 --===================================================================--
137
138
139 package body CC54003_1 is
140
141 function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr is
142 Sender : constant String := "Dummy: "; -- Artificial; in a real
143 -- application Sender might
144 New_Msg : Message := Sender & Msg_Ptr.all; -- be a call to a function.
145 begin
146 return new Message'(New_Msg);
147 end Add_Prefix;
148
149
150 function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr is
151 Time : constant String := " (12:03pm)"; -- Artificial; in a real
152 -- application Time might be a
153 New_Msg : Message := Msg_Ptr.all & Time; -- be a call to a function.
154 begin
155 return new Message'(New_Msg);
156 end Add_Suffix;
157
158 end CC54003_1;
159
160
161 --===================================================================--
162
163
164 with CC54003_0; -- Generic stack of pointers.
165 pragma Elaborate (CC54003_0);
166
167 with CC54003_1; -- Message abstraction.
168
169 package CC54003_2 is
170
171 type Operation_Ptr is access function (Msg_Ptr : CC54003_1.Message_Ptr)
172 return CC54003_1.Message_Ptr;
173
174 Maximum_Ops : constant := 4; -- Arbitrary.
175
176 package Stack_of_Ops is new CC54003_0
177 (Item_Type => CC54003_1.Message,
178 Item_Ptr => CC54003_1.Message_Ptr,
179 Function_Ptr => Operation_Ptr,
180 Size => Maximum_Ops);
181
182 Operation_Stack : Stack_Of_Ops.Stack_Type;
183
184
185 procedure Create_Operation_Stack;
186
187 end CC54003_2;
188
189 --===================================================================--
190
191
192 package body CC54003_2 is
193
194 procedure Create_Operation_Stack is
195 begin
196 Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Prefix'Access);
197 Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Suffix'Access);
198 end Create_Operation_Stack;
199
200 end CC54003_2;
201
202
203 --===================================================================--
204
205
206 with CC54003_1; -- Message abstraction.
207 with CC54003_2; -- Message-operation stack.
208
209 with Report;
210 procedure CC54003 is
211
212 package Msg_Ops renames CC54003_2.Stack_Of_Ops;
213
214 Msg : CC54003_1.Message_Ptr := new CC54003_1.Message'("Hello there");
215 Expected : CC54003_1.Message := "Dummy: Hello there (12:03pm)";
216
217 begin
218 Report.Test ("CC54003", "Check that a general access-to-subprogram type " &
219 "may be passed as an actual to a generic formal " &
220 "access-to-subprogram type");
221
222 CC54003_2.Create_Operation_Stack;
223
224 declare
225 Actual : CC54003_1.Message_Ptr :=
226 Msg_Ops.Execute_Stack (CC54003_2.Operation_Stack, Msg);
227 begin
228 if Actual.all /= Expected then
229 Report.Failed ("Wrong result from dereferenced subprogram execution");
230 end if;
231 end;
232
233 Report.Result;
234 end CC54003;