Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cc/cc50a02.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 -- CC50A02.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 nonlimited tagged type may be passed as an actual to a
28 -- formal (non-tagged) private type. Check that if the formal type has
29 -- an unknown discriminant part, a class-wide type may also be passed as
30 -- an actual.
31 --
32 -- TEST DESCRIPTION:
33 -- A generic package declares a formal private type and defines a
34 -- stack abstraction. Stacks are modeled as singly linked lists of
35 -- pointers to elements. Pointers are used because the elements may
36 -- be unconstrained.
37 --
38 -- A generic testing procedure pushes an item onto a stack, then views
39 -- the item on top of the stack.
40 --
41 -- The formal private type has an unknown discriminant part, and
42 -- is thus indefinite. This allows both definite and indefinite types
43 -- (including class-wide types) to be passed as actuals. For tagged types,
44 -- definite implies nondiscriminated, and indefinite implies discriminated
45 -- (with known/unknown discriminants).
46 --
47 -- TEST FILES:
48 -- The following files comprise this test:
49 --
50 -- FC50A00.A
51 -- -> CC50A02.A
52 --
53 --
54 -- CHANGE HISTORY:
55 -- 06 Dec 94 SAIC ACVC 2.0
56 -- 10 Nov 95 SAIC ACVC 2.0.1 fixes: Removed use of formal package
57 -- exception name in exception choice.
58 --
59 --!
60
61 generic -- Generic stack abstraction.
62 type Item (<>) is private; -- Formal private type.
63 package CC50A02_0 is
64
65 type Stack is private;
66
67 procedure Push (I : in Item; S : in out Stack);
68 function View_Top (S : Stack) return Item;
69
70 -- ...Other stack operations...
71
72 Stack_Empty : exception;
73
74 private
75
76 type Item_Ptr is access Item;
77
78 type Stack_Item;
79 type Stack_Ptr is access Stack_Item;
80
81 type Stack_Item is record
82 Item : Item_Ptr;
83 Next : Stack_Ptr;
84 end record;
85
86 type Stack is record
87 Top : Stack_Ptr := null;
88 Size : Natural := 0;
89 end record;
90
91 end CC50A02_0;
92
93
94 --==================================================================--
95
96
97 package body CC50A02_0 is
98
99 -- Link NewItem in at the top of the stack.
100
101 procedure Push (I : in Item; S : in out Stack) is
102 NewItem : Item_Ptr := new Item'(I);
103 Element : Stack_Ptr := new Stack_Item'(Item => NewItem, Next => S.Top);
104 begin
105 S.Top := Element;
106 S.Size := S.Size + 1;
107 end Push;
108
109
110 -- Return (copy) of top item on stack. Do NOT remove from stack.
111
112 function View_Top (S : Stack) return Item is
113 begin
114 if S.Top = null then
115 raise Stack_Empty;
116 else
117 return S.Top.Item.all;
118 end if;
119 end View_Top;
120
121 end CC50A02_0;
122
123
124 --==================================================================--
125
126
127 -- The formal package Stacker below is needed to gain access to the
128 -- appropriate version of the "generic" type Stack. It is provided with an
129 -- explicit actual part in order to restrict the packages that can be passed
130 -- as actuals to those which have been instantiated with the same actuals
131 -- which this generic procedure has been instantiated with.
132
133 with CC50A02_0; -- Generic stack abstraction.
134 generic
135 type Item_Type (<>) is private; -- Formal private type.
136 with package Stacker is new CC50A02_0 (Item_Type);
137 procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type);
138
139
140 --==================================================================--
141
142 --
143 -- This generic procedure performs all of the testing of the
144 -- stack abstraction.
145 --
146
147 with Report;
148 procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type) is
149 begin
150 Stacker.Push (I, S); -- Push onto empty stack.
151
152 -- Calls to View_Top must initialize a declared object of type Item_Type
153 -- because the type may be unconstrained.
154
155 declare
156 Buffer : Item_Type := Stacker.View_Top (S);
157 begin
158 if Buffer /= I then
159 Report.Failed (" Expected item not on stack");
160 end if;
161 exception
162 when Constraint_Error =>
163 Report.Failed (" Unexpected error: Tags of pushed and popped " &
164 "items don't match");
165 end;
166
167
168 exception
169 when others =>
170 Report.Failed (" Unexpected error: Item not pushed onto stack");
171 end CC50A02_1;
172
173
174 --==================================================================--
175
176
177 with FC50A00; -- Tagged (actual) type declarations.
178 with CC50A02_0; -- Generic stack abstraction.
179 with CC50A02_1; -- Generic stack testing procedure.
180
181 with Report;
182 procedure CC50A02 is
183
184 --
185 -- Pass a nondiscriminated tagged actual:
186 --
187
188 package Count_Stacks is new CC50A02_0 (FC50A00.Count_Type);
189 procedure TC_Count_Test is new CC50A02_1 (FC50A00.Count_Type,
190 Count_Stacks);
191 Count_Stack : Count_Stacks.Stack;
192
193
194 --
195 -- Pass a discriminated tagged actual:
196 --
197
198 package Person_Stacks is new CC50A02_0 (FC50A00.Person_Type);
199 procedure TC_Person_Test is new CC50A02_1 (FC50A00.Person_Type,
200 Person_Stacks);
201 Person_Stack : Person_Stacks.Stack;
202
203
204 --
205 -- Pass a class-wide actual:
206 --
207
208 package People_Stacks is new CC50A02_0 (FC50A00.Person_Type'Class);
209 procedure TC_People_Test is new CC50A02_1 (FC50A00.Person_Type'Class,
210 People_Stacks);
211 People_Stack : People_Stacks.Stack;
212
213 begin
214 Report.Test ("CC50A02", "Check that tagged actuals may be passed " &
215 "to a formal (nontagged) private type");
216
217 Report.Comment ("Testing definite tagged type..");
218 TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item);
219
220 Report.Comment ("Testing indefinite tagged type..");
221 TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
222
223 Report.Comment ("Testing class-wide type..");
224 TC_People_Test (People_Stack, FC50A00.TC_VIPerson_Item);
225
226 Report.Result;
227 end CC50A02;