OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc50a01.a] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- CC50A01.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 formal parameter of a library-level generic unit may be
28
--      a formal tagged private type. Check that a nonlimited tagged type may
29
--      be passed as an actual. Check that if the formal type is indefinite,
30
--      both indefinite and definite types may be passed as actuals.
31
--
32
-- TEST DESCRIPTION:
33
--      The generic package declares a formal tagged private type (this can
34
--      be considered the parent "mixin" class). This type is extended in
35
--      the generic to provide support for stacks of items of any nonlimited
36
--      tagged type. Stacks are modeled as singly linked lists, with the list
37
--      nodes being objects of the extended type.
38
--
39
--      A generic testing procedure pushes items onto a stack, and pops them
40
--      back off, verifying the state of the stack at various points along the
41
--      way. The push and pop routines exercise functionality important to
42
--      tagged types, such as type conversion toward the root of the derivation
43
--      class and extension aggregates.
44
--
45
--      The formal tagged private type has an unknown discriminant part, and
46
--      is thus indefinite. This allows both definite and indefinite types
47
--      to be passed as actuals. For tagged types, definite implies
48
--      nondiscriminated, and indefinite implies discriminated (with known
49
--      or unknown discriminants).
50
--
51
-- TEST FILES:
52
--      This test consists of the following files:
53
--
54
--         FC50A00.A
55
--      -> CC50A01.A
56
--
57
--
58
-- CHANGE HISTORY:
59
--      06 Dec 94   SAIC    ACVC 2.0
60
--      21 Nov 95   SAIC    ACVC 2.0.1 fixes: Moved instantiations of
61
--                          BC50A01_0 to library level.
62
--      11 Aug 96   SAIC    ACVC 2.1: Updated prologue. Added pragma
63
--                          Elaborate to context clauses for CC50A01_2 & _3.
64
--
65
--!
66
 
67
with FC50A00;  -- Tagged (actual) type declarations.
68
generic        -- Generic stack abstraction.
69
 
70
   type Item (<>) is tagged private;            -- Formal tagged private type.
71
   TC_Default_Value : Item;                     -- Needed in View_Top (see
72
                                                -- below).
73
package CC50A01_0 is
74
 
75
   type Stack is private;
76
 
77
-- Note that because the actual type corresponding to Item may be
78
-- unconstrained, the functions of removing the top item from the stack and
79
-- returning the value of the top item of the stack have been separated into
80
-- Pop and View_Top, respectively. This is necessary because otherwise the
81
-- returned value would have to be an out parameter of Pop, which would
82
-- require the user (in the unconstrained case) to create an uninitialized
83
-- unconstrained object to serve as the actual, which is illegal.
84
 
85
   procedure Push     (I : in Item; S : in out Stack);
86
   procedure Pop      (S : in out Stack);
87
   function  View_Top (S : Stack) return Item;
88
 
89
   function Size_Of (S : Stack) return Natural;
90
 
91
private
92
 
93
   type Stack_Item;
94
   type Stack_Ptr is access Stack_Item;
95
 
96
   type Stack_Item is new Item with record      -- Extends formal type.
97
      Next : Stack_Ptr := null;
98
   end record;
99
 
100
   type Stack is record
101
      Top  : Stack_Ptr := null;
102
      Size : Natural   := 0;
103
   end record;
104
 
105
end CC50A01_0;
106
 
107
 
108
     --==================================================================--
109
 
110
 
111
package body CC50A01_0 is
112
 
113
   -- Link NewItem in at the top of the stack (the extension aggregate within
114
   -- the allocator initializes the inherited portion of NewItem to equal I,
115
   -- and NewItem.Next to point to what S.Top points to).
116
 
117
   procedure Push (I : in Item; S : in out Stack) is
118
      NewItem : Stack_Ptr;
119
   begin
120
      NewItem := new Stack_Item'(I with S.Top);     -- Extension aggregate.
121
      S.Top   := NewItem;
122
      S.Size  := S.Size + 1;
123
   end Push;
124
 
125
 
126
   -- Remove item from top of stack. This procedure only updates the state of
127
   -- the stack; it does not return the value of the popped item. Hence, in
128
   -- order to accomplish a "true" pop, both View_Top and Pop must be called
129
   -- consecutively.
130
   --
131
   -- If the stack is empty, the Pop is ignored (for simplicity; in a true
132
   -- application this might be treated as an error condition).
133
 
134
   procedure Pop (S : in out Stack) is
135
   begin
136
      if S.Top = null then                          -- Stack is empty.
137
         null;
138
         -- Raise exception.
139
      else
140
         S.Top  := S.Top.Next;
141
         S.Size := S.Size - 1;
142
         -- Deallocate discarded node.
143
      end if;
144
   end Pop;
145
 
146
 
147
   -- Return the value of the top item on the stack. This procedure only
148
   -- returns the value; it does not remove the top item from the stack.
149
   -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must
150
   -- be called consecutively.
151
   --
152
   -- Since items on the stack are of a type (Stack_Item) derived from Item,
153
   -- which is a (tagged) private type, type conversion toward the root is the
154
   -- only way to get a value of type Item for return to the caller.
155
   --
156
   -- If the stack is empty, View_Top returns a pre-specified default value.
157
   -- (In a true application, an exception might be raised instead).
158
 
159
   function View_Top (S : Stack) return Item is
160
   begin
161
      if S.Top = null then                          -- Stack is empty.
162
         return TC_Default_Value;                   -- Testing artifice.
163
         -- Raise exception.
164
      else
165
         return Item(S.Top.all);                    -- Type conversion.
166
      end if;
167
   end View_Top;
168
 
169
 
170
   function Size_Of (S : Stack) return Natural is
171
   begin
172
      return (S.Size);
173
   end Size_Of;
174
 
175
 
176
end CC50A01_0;
177
 
178
 
179
     --==================================================================--
180
 
181
 
182
-- The formal package Stacker below is needed to gain access to the
183
-- appropriate version of the "generic" type Stack. It is provided with an
184
-- explicit actual part in order to restrict the packages that can be passed
185
-- as actuals to those which have been instantiated with the same actuals
186
-- which this generic procedure has been instantiated with.
187
 
188
with CC50A01_0;  -- Generic stack abstraction.
189
generic
190
   type Item_Type (<>) is tagged private;       -- Formal tagged private type.
191
   Default : Item_Type;
192
   with package Stacker is new CC50A01_0 (Item_Type, Default);
193
procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type);
194
 
195
 
196
     --==================================================================--
197
 
198
--
199
-- This generic procedure performs all of the testing of the
200
-- stack abstraction.
201
--
202
 
203
with Report;
204
procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is
205
begin
206
   Stacker.Push (I, S);                    -- Push onto empty stack.
207
   Stacker.Push (I, S);                    -- Push onto nonempty stack.
208
 
209
   if Stacker.Size_Of (S) /= 2 then
210
      Report.Failed ("   Wrong stack size after 2 Pushes");
211
   end if;
212
 
213
   -- Calls to View_Top must initialize a declared object of type Item_Type
214
   -- because the type may be unconstrained.
215
 
216
   declare
217
      Buffer1 : Item_Type := Stacker.View_Top (S);
218
   begin
219
      Stacker.Pop (S);                     -- Pop item off nonempty stack.
220
      if Buffer1 /= I then
221
         Report.Failed ("   Wrong stack item value after 1st Pop");
222
      end if;
223
   end;
224
 
225
   declare
226
      Buffer2 : Item_Type := Stacker.View_Top (S);
227
   begin
228
      Stacker.Pop (S);                     -- Pop last item off stack.
229
      if Buffer2 /= I then
230
         Report.Failed ("   Wrong stack item value after 2nd Pop");
231
      end if;
232
   end;
233
 
234
   if Stacker.Size_Of (S) /= 0 then
235
      Report.Failed ("   Wrong stack size after 2 Pops");
236
   end if;
237
 
238
   declare
239
      Buffer3 : Item_Type := Stacker.View_Top (S);
240
   begin
241
      if Buffer3 /= Default then
242
         Report.Failed ("   Wrong result after Pop of empty stack");
243
      end if;
244
      Stacker.Pop (S);                     -- Pop off empty stack.
245
   end;
246
 
247
end CC50A01_1;
248
 
249
 
250
     --==================================================================--
251
 
252
 
253
with FC50A00;
254
 
255
with CC50A01_0;
256
pragma Elaborate (CC50A01_0);
257
 
258
package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type,
259
                                    FC50A00.TC_Default_Count);
260
 
261
 
262
     --==================================================================--
263
 
264
 
265
with FC50A00;
266
 
267
with CC50A01_0;
268
pragma Elaborate (CC50A01_0);
269
 
270
package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type,
271
                                    FC50A00.TC_Default_Person);
272
 
273
 
274
     --==================================================================--
275
 
276
 
277
with FC50A00;   -- Tagged (actual) type declarations.
278
with CC50A01_0; -- Generic stack abstraction.
279
with CC50A01_1; -- Generic stack testing procedure.
280
with CC50A01_2;
281
with CC50A01_3;
282
 
283
with Report;
284
procedure CC50A01 is
285
 
286
   package Count_Stacks  renames CC50A01_2;
287
   package Person_Stacks renames CC50A01_3;
288
 
289
 
290
   procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type,
291
                                             FC50A00.TC_Default_Count,
292
                                             Count_Stacks);
293
   Count_Stack : Count_Stacks.Stack;
294
 
295
 
296
   procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type,
297
                                              FC50A00.TC_Default_Person,
298
                                              Person_Stacks);
299
   Person_Stack : Person_Stacks.Stack;
300
 
301
begin
302
   Report.Test ("CC50A01", "Check that a formal parameter of a " &
303
                "library-level generic unit may be a formal tagged " &
304
                "private type");
305
 
306
   Report.Comment ("Testing definite tagged type..");
307
   TC_Count_Test  (Count_Stack,  FC50A00.TC_Count_Item);
308
 
309
   Report.Comment ("Testing indefinite tagged type..");
310
   TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
311
 
312
   Report.Result;
313
end CC50A01;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.