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/] [cc3019c1.ada] - Blame information for rev 149

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- CC3019C1.ADA
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
--  THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF
26
--  NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED
27
--  BY MAIN PROCEDURE CC3019C2M.ADA.
28
--
29
-- HISTORY:
30
--         EDWARD V. BERARD, 31 AUGUST 1990
31
 
32
WITH CC3019C0_LIST_CLASS ;
33
 
34
GENERIC
35
 
36
     TYPE ELEMENT IS LIMITED PRIVATE ;
37
 
38
     WITH PROCEDURE ASSIGN (SOURCE        : IN OUT ELEMENT ;
39
                            DESTINATION   : IN OUT ELEMENT) ;
40
 
41
     WITH FUNCTION "=" (LEFT  : IN ELEMENT ;
42
                        RIGHT : IN ELEMENT) RETURN BOOLEAN ;
43
 
44
PACKAGE CC3019C1_NESTED_GENERICS IS
45
 
46
     TYPE NESTED_GENERICS_TYPE IS LIMITED PRIVATE ;
47
 
48
     PROCEDURE COPY (SOURCE        : IN OUT NESTED_GENERICS_TYPE ;
49
                     DESTINATION   : IN OUT NESTED_GENERICS_TYPE) ;
50
 
51
     PROCEDURE SET_ELEMENT
52
                    (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ;
53
                     TO_THIS_ELEMENT     : IN OUT ELEMENT) ;
54
 
55
     PROCEDURE SET_NUMBER
56
                    (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ;
57
                     TO_THIS_NUMBER      : IN NATURAL) ;
58
 
59
     FUNCTION "=" (LEFT  : IN NESTED_GENERICS_TYPE ;
60
                   RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN ;
61
 
62
     FUNCTION ELEMENT_OF (THIS_NGT_OBJECT    : IN NESTED_GENERICS_TYPE)
63
          RETURN ELEMENT ;
64
 
65
     FUNCTION NUMBER_OF  (THIS_NGT_OBJECT    : IN NESTED_GENERICS_TYPE)
66
          RETURN NATURAL ;
67
 
68
     GENERIC
69
 
70
          TYPE ELEMENT IS LIMITED PRIVATE ;
71
 
72
          WITH PROCEDURE ASSIGN (SOURCE        : IN OUT ELEMENT ;
73
                                 DESTINATION   : IN OUT ELEMENT) ;
74
 
75
     PACKAGE GENERIC_TASK IS
76
 
77
          TASK TYPE PROTECTED_AREA IS
78
 
79
                    ENTRY STORE (ITEM    : IN OUT ELEMENT) ;
80
                    ENTRY GET   (ITEM    : IN OUT ELEMENT) ;
81
 
82
          END PROTECTED_AREA ;
83
 
84
     END GENERIC_TASK ;
85
 
86
     GENERIC
87
 
88
          TYPE ELEMENT IS LIMITED PRIVATE ;
89
 
90
          WITH PROCEDURE ASSIGN (SOURCE        : IN OUT ELEMENT ;
91
                                 DESTINATION   : IN OUT ELEMENT) ;
92
 
93
          WITH FUNCTION "=" (LEFT  : IN ELEMENT ;
94
                             RIGHT : IN ELEMENT) RETURN BOOLEAN ;
95
 
96
     PACKAGE STACK_CLASS IS
97
 
98
          TYPE STACK IS LIMITED PRIVATE ;
99
 
100
          OVERFLOW    : EXCEPTION ;
101
          UNDERFLOW   : EXCEPTION ;
102
 
103
          PROCEDURE PUSH (THIS_ELEMENT        : IN OUT ELEMENT ;
104
                          ON_TO_THIS_STACK    : IN OUT STACK) ;
105
 
106
          PROCEDURE POP  (THIS_ELEMENT        : IN OUT ELEMENT ;
107
                          OFF_THIS_STACK      : IN OUT STACK) ;
108
 
109
          PROCEDURE COPY  (THIS_STACK        : IN OUT STACK ;
110
                           TO_THIS_STACK    : IN OUT STACK) ;
111
 
112
          PROCEDURE CLEAR (THIS_STACK        : IN OUT STACK) ;
113
 
114
          GENERIC
115
 
116
               WITH PROCEDURE PROCESS (THIS_ELEMENT    : IN  ELEMENT ;
117
                                       CONTINUE        : OUT BOOLEAN) ;
118
 
119
          PROCEDURE ITERATE (OVER_THIS_STACK    : IN STACK) ;
120
 
121
          FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK    : IN STACK)
122
                    RETURN NATURAL ;
123
 
124
          FUNCTION "=" (LEFT  : IN STACK ;
125
                        RIGHT : IN STACK) RETURN BOOLEAN ;
126
 
127
     PRIVATE
128
 
129
          PACKAGE NEW_LIST_CLASS IS NEW
130
               CC3019C0_LIST_CLASS (ELEMENT => ELEMENT,
131
                                    ASSIGN  => ASSIGN,
132
                                    "="     => "=") ;
133
 
134
          TYPE STACK IS NEW NEW_LIST_CLASS.LIST ;
135
 
136
     END STACK_CLASS ;
137
 
138
PRIVATE
139
 
140
     TYPE NESTED_GENERICS_TYPE IS RECORD
141
          FIRST    : ELEMENT ;
142
          SECOND   : NATURAL ;
143
     END RECORD ;
144
 
145
END CC3019C1_NESTED_GENERICS ;
146
 
147
PACKAGE BODY CC3019C1_NESTED_GENERICS IS
148
 
149
     PROCEDURE COPY (SOURCE        : IN OUT NESTED_GENERICS_TYPE ;
150
                     DESTINATION   : IN OUT NESTED_GENERICS_TYPE) IS
151
 
152
     BEGIN  -- COPY
153
 
154
          ASSIGN (SOURCE        => SOURCE.FIRST,
155
                  DESTINATION   => DESTINATION.FIRST) ;
156
 
157
          DESTINATION.SECOND := SOURCE.SECOND ;
158
 
159
     END COPY ;
160
 
161
     PROCEDURE SET_ELEMENT
162
          (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ;
163
          TO_THIS_ELEMENT     : IN OUT ELEMENT) IS
164
 
165
     BEGIN  -- SET_ELEMENT
166
 
167
          ASSIGN (SOURCE        => TO_THIS_ELEMENT,
168
                  DESTINATION   => FOR_THIS_NGT_OBJECT.FIRST) ;
169
 
170
     END SET_ELEMENT ;
171
 
172
     PROCEDURE SET_NUMBER
173
          (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ;
174
          TO_THIS_NUMBER      : IN NATURAL) IS
175
 
176
     BEGIN  -- SET_NUMBER
177
 
178
          FOR_THIS_NGT_OBJECT.SECOND := TO_THIS_NUMBER ;
179
 
180
     END SET_NUMBER ;
181
 
182
     FUNCTION "=" (LEFT  : IN NESTED_GENERICS_TYPE ;
183
                   RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN IS
184
 
185
     BEGIN  -- "="
186
 
187
          IF (LEFT.FIRST = RIGHT.FIRST) AND
188
             (LEFT.SECOND = RIGHT.SECOND) THEN
189
                       RETURN TRUE ;
190
          ELSE
191
                    RETURN FALSE ;
192
          END IF ;
193
 
194
     END "=" ;
195
 
196
     FUNCTION ELEMENT_OF (THIS_NGT_OBJECT    : IN NESTED_GENERICS_TYPE)
197
          RETURN ELEMENT IS
198
 
199
     BEGIN  -- ELEMENT_OF
200
 
201
          RETURN THIS_NGT_OBJECT.FIRST ;
202
 
203
     END ELEMENT_OF ;
204
 
205
     FUNCTION NUMBER_OF (THIS_NGT_OBJECT    : IN NESTED_GENERICS_TYPE)
206
          RETURN NATURAL IS
207
 
208
     BEGIN  -- NUMBER_OF
209
 
210
          RETURN THIS_NGT_OBJECT.SECOND ;
211
 
212
     END NUMBER_OF ;
213
 
214
     PACKAGE BODY GENERIC_TASK IS
215
 
216
          TASK BODY PROTECTED_AREA IS
217
 
218
               LOCAL_STORE : ELEMENT ;
219
 
220
          BEGIN  -- PROTECTED_AREA
221
 
222
               LOOP
223
                    SELECT
224
                         ACCEPT STORE (ITEM    : IN OUT ELEMENT) DO
225
                              ASSIGN (SOURCE        => ITEM,
226
                                      DESTINATION   => LOCAL_STORE) ;
227
                         END STORE ;
228
                    OR
229
                         ACCEPT GET   (ITEM    : IN OUT ELEMENT) DO
230
                              ASSIGN (SOURCE        => LOCAL_STORE,
231
                                      DESTINATION   => ITEM) ;
232
                         END GET ;
233
                    OR
234
                         TERMINATE ;
235
                    END SELECT ;
236
               END LOOP ;
237
 
238
          END PROTECTED_AREA ;
239
 
240
     END GENERIC_TASK ;
241
 
242
     PACKAGE BODY STACK_CLASS IS
243
 
244
          PROCEDURE PUSH (THIS_ELEMENT        : IN OUT ELEMENT ;
245
                          ON_TO_THIS_STACK    : IN OUT STACK) IS
246
 
247
          BEGIN  -- PUSH
248
 
249
              NEW_LIST_CLASS.ADD (
250
                    THIS_ELEMENT    => THIS_ELEMENT,
251
                    TO_THIS_LIST    =>
252
                         NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ;
253
 
254
          EXCEPTION
255
 
256
              WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ;
257
 
258
          END PUSH ;
259
 
260
          PROCEDURE POP  (THIS_ELEMENT        : IN OUT ELEMENT ;
261
                          OFF_THIS_STACK      : IN OUT STACK) IS
262
 
263
          BEGIN  -- POP
264
 
265
               NEW_LIST_CLASS.DELETE (
266
                    THIS_ELEMENT     => THIS_ELEMENT,
267
                    FROM_THIS_LIST   =>
268
                        NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ;
269
 
270
          EXCEPTION
271
 
272
                    WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ;
273
 
274
          END POP ;
275
 
276
          PROCEDURE COPY  (THIS_STACK       : IN OUT STACK ;
277
                           TO_THIS_STACK    : IN OUT STACK) IS
278
 
279
          BEGIN  -- COPY
280
 
281
              NEW_LIST_CLASS.COPY (
282
                    THIS_LIST    => NEW_LIST_CLASS.LIST (THIS_STACK),
283
                    TO_THIS_LIST =>
284
                         NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ;
285
 
286
          END COPY ;
287
 
288
          PROCEDURE CLEAR (THIS_STACK        : IN OUT STACK) IS
289
 
290
          BEGIN  -- CLEAR
291
 
292
               NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ;
293
 
294
          END CLEAR ;
295
 
296
          PROCEDURE ITERATE (OVER_THIS_STACK  : IN STACK) IS
297
 
298
               PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE
299
                                        (PROCESS => PROCESS) ;
300
 
301
          BEGIN  -- ITERATE
302
 
303
               STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ;
304
 
305
          END ITERATE ;
306
 
307
          FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK    : IN STACK)
308
                    RETURN NATURAL IS
309
 
310
          BEGIN  -- NUMBER_OF_ELEMENTS
311
 
312
               RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS
313
                    (IN_THIS_LIST =>
314
                         NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ;
315
 
316
          END NUMBER_OF_ELEMENTS ;
317
 
318
          FUNCTION "=" (LEFT  : IN STACK ;
319
                        RIGHT : IN STACK) RETURN BOOLEAN IS
320
 
321
          BEGIN  -- "="
322
 
323
               RETURN NEW_LIST_CLASS."=" (
324
                    LEFT  => NEW_LIST_CLASS.LIST (LEFT),
325
                   RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ;
326
 
327
          END "=" ;
328
 
329
     END STACK_CLASS ;
330
 
331
END CC3019C1_NESTED_GENERICS ;

powered by: WebSVN 2.1.0

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