Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cc/cc54001.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 -- CC54001.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-constant type may be passed as an
28 -- actual to a generic formal access-to-constant type.
29 --
30 -- TEST DESCRIPTION:
31 -- The generic implements a stack of access objects as an array. The
32 -- designated type of the formal access type is itself a formal private
33 -- type declared in the same generic formal part.
34 --
35 -- The generic is instantiated with an unconstrained subtype of String,
36 -- which results in a stack which can accommodate strings of varying
37 -- lengths (ragged array). Furthermore, the access objects to be pushed
38 -- onto the stack are created both statically and dynamically, utilizing
39 -- allocators and the 'Access attribute.
40 --
41 --
42 -- CHANGE HISTORY:
43 -- 06 Dec 94 SAIC ACVC 2.0
44 -- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
45 -- preceding CC54001_1.
46 --
47 --!
48
49 generic
50 Size : in Positive;
51 type Element_Type (<>) is private;
52 type Element_Ptr is access constant Element_Type;
53 package CC54001_0 is -- Generic stack of pointers.
54
55 type Stack_Type is private;
56
57 procedure Push (Stack : in out Stack_Type;
58 Elem_Ptr : in Element_Ptr);
59
60 procedure Pop (Stack : in out Stack_Type;
61 Elem_Ptr : out Element_Ptr);
62
63 -- ... Other operations.
64
65 private
66
67 subtype Index is Positive range 1 .. (Size + 1);
68 type Stack_Type is array (Index) of Element_Ptr; -- Last element unused.
69
70 Top : Index := 1;
71
72 end CC54001_0;
73
74
75 --===================================================================--
76
77
78 package body CC54001_0 is
79
80 procedure Push (Stack : in out Stack_Type;
81 Elem_Ptr : in Element_Ptr) is
82 begin
83 Stack(Top) := Elem_Ptr;
84 Top := Top + 1; -- Artificial: no Constraint_Error protection.
85 end Push;
86
87
88 procedure Pop (Stack : in out Stack_Type;
89 Elem_Ptr : out Element_Ptr) is
90 begin
91 Top := Top - 1; -- Artificial: no Constraint_Error protection.
92 Elem_Ptr := Stack(Top);
93 end Pop;
94
95 end CC54001_0;
96
97
98 --===================================================================--
99
100
101 with CC54001_0; -- Generic stack of pointers.
102 pragma Elaborate (CC54001_0);
103
104 package CC54001_1 is
105
106 subtype Message is String;
107 type Message_Ptr is access constant Message;
108
109 Message_Count : constant := 4;
110
111 Message_0 : aliased constant Message := "Hello";
112 Message_1 : aliased constant Message := "Doctor";
113 Message_2 : aliased constant Message := "Name";
114 Message_3 : aliased constant Message := "Continue";
115
116
117 package Stack_of_Messages is new CC54001_0
118 (Element_Type => Message,
119 Element_Ptr => Message_Ptr,
120 Size => Message_Count);
121
122 Message_Stack : Stack_Of_Messages.Stack_Type;
123
124
125 procedure Create_Message_Stack;
126
127 end CC54001_1;
128
129
130 --===================================================================--
131
132
133 package body CC54001_1 is
134
135 procedure Create_Message_Stack is
136 -- Push access objects onto stack. Note that some are statically
137 -- allocated, and some are dynamically allocated (using an aliased
138 -- object to initialize).
139 begin
140 Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static.
141 Stack_Of_Messages.Push (Message_Stack,
142 new Message'(Message_1)); -- Dynamic.
143 Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static.
144 Stack_Of_Messages.Push (Message_Stack, -- Dynamic.
145 new Message'(Message_3));
146 end Create_Message_Stack;
147
148 end CC54001_1;
149
150
151 --===================================================================--
152
153
154 with CC54001_1;
155
156 with Report;
157 procedure CC54001 is
158
159 package Messages renames CC54001_1.Stack_Of_Messages;
160
161 Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr;
162
163 begin
164 Report.Test ("CC54001", "Check that a general access-to-constant type " &
165 "may be passed as an actual to a generic formal " &
166 "access-to-constant type");
167
168 CC54001_1.Create_Message_Stack;
169
170 Messages.Pop (CC54001_1.Message_Stack, Msg3); -- Pop items off stack in the
171 Messages.Pop (CC54001_1.Message_Stack, Msg2); -- reverse order that they
172 Messages.Pop (CC54001_1.Message_Stack, Msg1); -- were pushed.
173 Messages.Pop (CC54001_1.Message_Stack, Msg0);
174
175 if Msg0.all /= CC54001_1.Message_0 or else
176 Msg1.all /= CC54001_1.Message_1 or else
177 Msg2.all /= CC54001_1.Message_2 or else
178 Msg3.all /= CC54001_1.Message_3
179 then
180 Report.Failed ("Items popped off of stack do not match those pushed");
181 end if;
182
183 Report.Result;
184 end CC54001;