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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc50a02.a] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- 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;

powered by: WebSVN 2.1.0

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