1-- CC3019C2M.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--   CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G.
26--   TO SUPPORT ITERATORS.
27
28--  THIS TEST SPECIFICALLY CHECKS THAT A
29--  NESTING LEVEL OF 3 IS SUPPORTED FOR GENERICS:
30--       INSTANTIATE CC3019C1_NESTED_GENERICS IN THE MAIN
31--       PROCEDURE, THE INSTANTIATION OF CC3019C0_LIST_CLASS
32--       IN GENERIC PACKAGE CC3019C1_NESTED_GENERICS, AND
33--       THE INSTANTIATION OF NEW_LIST_CLASS.ITERATE IN
34--       PROCEDURE ITERATE IN PACKAGE BODY STACK_CLASS.
35--
36--  *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE
37--  *** SOURCE CODE IN FILES CC3019C0.ADA AND CC3019C1.ADA HAVE
38--  *** BEEN COMPILED.
39--
40-- HISTORY:
41--         EDWARD V. BERARD, 31 AUGUST 1990
42
43WITH REPORT ;
44WITH CC3019C1_NESTED_GENERICS ;
45
46PROCEDURE CC3019C2M IS
47
48     TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
49                         SEP, OCT, NOV, DEC) ;
50     TYPE DAY_TYPE IS RANGE 1 .. 31 ;
51     TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
52     TYPE DATE IS RECORD
53          MONTH : MONTH_TYPE ;
54          DAY   : DAY_TYPE ;
55          YEAR  : YEAR_TYPE ;
56     END RECORD ;
57
58     STORE_DATE   : DATE ;
59
60     TODAY        : DATE := (MONTH => AUG,
61                             DAY   => 31,
62                             YEAR  => 1990) ;
63
64     FIRST_DATE   : DATE := (MONTH => JUN,
65                             DAY   => 4,
66                             YEAR  => 1967) ;
67
68     BIRTH_DATE   : DATE := (MONTH => OCT,
69                             DAY   => 3,
70                             YEAR  => 1949) ;
71
72     WALL_DATE    : DATE := (MONTH => NOV,
73                             DAY   => 9,
74                             YEAR  => 1989) ;
75
76     TYPE SEX IS (MALE, FEMALE) ;
77
78     TYPE PERSON IS RECORD
79          BIRTH_DATE : DATE ;
80          GENDER     : SEX ;
81          NAME       : STRING (1 .. 10) ;
82     END RECORD ;
83
84     FIRST_PERSON  : PERSON ;
85     SECOND_PERSON : PERSON ;
86
87     MYSELF      : PERSON := (BIRTH_DATE => BIRTH_DATE,
88                              GENDER     => MALE,
89                              NAME        => "ED        ") ;
90
91     FRIEND      : PERSON := (BIRTH_DATE => DATE'(DEC, 27, 1949),
92                              GENDER     => MALE,
93                              NAME        => "DENNIS    ") ;
94
95     FATHER      : PERSON := (BIRTH_DATE => DATE'(JUL, 5, 1925),
96                              GENDER     => MALE,
97                              NAME        => "EDWARD    ") ;
98
99     DAUGHTER    : PERSON := (BIRTH_DATE => DATE'(DEC, 10, 1980),
100                              GENDER     => FEMALE,
101                              NAME       => "CHRISSY   ") ;
102
103     PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE    : IN OUT DATE ;
104                       TO_THIS_DATE              : IN OUT DATE) ;
105
106     FUNCTION IS_EQUAL (LEFT  : IN DATE ;
107                        RIGHT : IN DATE) RETURN BOOLEAN ;
108
109     PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON  : IN OUT PERSON ;
110                       TO_THIS_PERSON            : IN OUT PERSON) ;
111
112     FUNCTION IS_EQUAL (LEFT  : IN PERSON ;
113                        RIGHT : IN PERSON) RETURN BOOLEAN ;
114
115--  INSTANTIATE OUTER GENERIC PACKAGE
116
117     PACKAGE NEW_NESTED_GENERICS IS NEW
118          CC3019C1_NESTED_GENERICS (ELEMENT => DATE,
119                                    ASSIGN  => ASSIGN,
120                                    "="     => IS_EQUAL) ;
121
122     FIRST_NNG  : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;
123     SECOND_NNG : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;
124
125     FUNCTION "=" (LEFT  : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;
126                   RIGHT : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE)
127                   RETURN BOOLEAN RENAMES NEW_NESTED_GENERICS."=" ;
128
129--  INSTANTIATE NESTED TASK PACKAGE
130
131     PACKAGE NEW_GENERIC_TASK IS NEW
132          NEW_NESTED_GENERICS.GENERIC_TASK (ELEMENT => PERSON,
133                                            ASSIGN  => ASSIGN) ;
134
135     FIRST_GENERIC_TASK  : NEW_GENERIC_TASK.PROTECTED_AREA ;
136     SECOND_GENERIC_TASK : NEW_GENERIC_TASK.PROTECTED_AREA ;
137
138--  INSTANTIATE NESTED STACK PACKAGE
139
140     PACKAGE PERSON_STACK IS NEW
141          NEW_NESTED_GENERICS.STACK_CLASS (ELEMENT => PERSON,
142                                           ASSIGN  => ASSIGN,
143                                           "="     => IS_EQUAL) ;
144
145     FIRST_PERSON_STACK  : PERSON_STACK.STACK ;
146     SECOND_PERSON_STACK : PERSON_STACK.STACK ;
147     THIRD_PERSON_STACK  : PERSON_STACK.STACK ;
148
149     FUNCTION "=" (LEFT  : IN PERSON_STACK.STACK ;
150                   RIGHT : IN PERSON_STACK.STACK) RETURN BOOLEAN
151              RENAMES PERSON_STACK."=" ;
152
153     PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE    : IN OUT DATE ;
154                       TO_THIS_DATE              : IN OUT DATE) IS
155
156     BEGIN -- ASSIGN
157
158          TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ;
159
160     END ASSIGN ;
161
162     FUNCTION IS_EQUAL (LEFT  : IN DATE ;
163                        RIGHT : IN DATE) RETURN BOOLEAN IS
164
165     BEGIN -- IS_EQUAL
166
167          IF (LEFT.MONTH = RIGHT.MONTH) AND (LEFT.DAY = RIGHT.DAY)
168             AND (LEFT.YEAR = RIGHT.YEAR) THEN
169               RETURN TRUE ;
170          ELSE
171               RETURN FALSE ;
172          END IF ;
173
174     END IS_EQUAL ;
175
176     PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON  : IN OUT PERSON ;
177                       TO_THIS_PERSON            : IN OUT PERSON) IS
178
179     BEGIN -- ASSIGN
180
181          TO_THIS_PERSON := THE_VALUE_OF_THIS_PERSON ;
182
183     END ASSIGN ;
184
185     FUNCTION IS_EQUAL (LEFT  : IN PERSON ;
186                        RIGHT : IN PERSON) RETURN BOOLEAN IS
187
188     BEGIN -- IS_EQUAL
189
190          IF (LEFT.BIRTH_DATE = RIGHT.BIRTH_DATE) AND
191             (LEFT.GENDER = RIGHT.GENDER) AND
192             (LEFT.NAME = RIGHT.NAME) THEN
193               RETURN TRUE ;
194          ELSE
195               RETURN FALSE ;
196          END IF ;
197
198     END IS_EQUAL ;
199
200BEGIN  -- CC3019C2M
201
202     REPORT.TEST ("CC3019C2M",
203                  "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " &
204                  "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " &
205                  "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF 3 " &
206                  "IS SUPPORTED FOR GENERICS.") ;
207
208-- CHECK THE OUTERMOST GENERIC (NEW_NESTED_GENERICS)
209
210     NEW_NESTED_GENERICS.SET_ELEMENT (
211          FOR_THIS_NGT_OBJECT => FIRST_NNG,
212          TO_THIS_ELEMENT     => TODAY) ;
213     NEW_NESTED_GENERICS.SET_NUMBER (
214          FOR_THIS_NGT_OBJECT => FIRST_NNG,
215          TO_THIS_NUMBER      => 1) ;
216
217     NEW_NESTED_GENERICS.SET_ELEMENT (
218          FOR_THIS_NGT_OBJECT => SECOND_NNG,
219          TO_THIS_ELEMENT     => FIRST_DATE) ;
220     NEW_NESTED_GENERICS.SET_NUMBER  (
221          FOR_THIS_NGT_OBJECT => SECOND_NNG,
222          TO_THIS_NUMBER      => 2) ;
223
224     IF FIRST_NNG = SECOND_NNG THEN
225          REPORT.FAILED ("PROBLEMS WITH TESTING EQUALITY FOR " &
226                         "OUTERMOST GENERIC") ;
227     END IF ;
228
229     IF (NEW_NESTED_GENERICS.ELEMENT_OF (THIS_NGT_OBJECT => FIRST_NNG)
230             /= TODAY) OR
231        (NEW_NESTED_GENERICS.ELEMENT_OF (
232                THIS_NGT_OBJECT => SECOND_NNG)
233             /= FIRST_DATE) THEN
234             REPORT.FAILED ("PROBLEMS WITH EXTRACTING ELEMENTS IN " &
235                            "OUTERMOST GENERIC") ;
236     END IF ;
237
238     IF (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => FIRST_NNG)
239             /= 1) OR
240        (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => SECOND_NNG)
241             /= 2) THEN
242             REPORT.FAILED ("PROBLEMS WITH EXTRACTING NUMBERS IN " &
243                             "OUTERMOST GENERIC") ;
244     END IF ;
245
246     NEW_NESTED_GENERICS.COPY (SOURCE        => FIRST_NNG,
247                               DESTINATION    => SECOND_NNG) ;
248
249     IF FIRST_NNG /= SECOND_NNG THEN
250          REPORT.FAILED ("PROBLEMS WITH COPYING OR TESTING EQUALITY " &
251                         "IN OUTERMOST GENERIC") ;
252     END IF ;
253
254-- CHECK THE FIRST NESTED GENERIC (GENERIC_TASK)
255
256     FIRST_GENERIC_TASK.STORE  (ITEM => MYSELF) ;
257     SECOND_GENERIC_TASK.STORE (ITEM => FRIEND) ;
258
259     FIRST_GENERIC_TASK.GET  (ITEM => FIRST_PERSON) ;
260     SECOND_GENERIC_TASK.GET (ITEM => SECOND_PERSON) ;
261
262     IF (FIRST_PERSON /= MYSELF) OR (SECOND_PERSON /= FRIEND) THEN
263          REPORT.FAILED ("PROBLEMS WITH NESTED TASK GENERIC") ;
264     END IF ;
265
266-- CHECK THE SECOND NESTED GENERIC (STACK_CLASS)
267
268     PERSON_STACK.CLEAR (THIS_STACK => FIRST_PERSON_STACK) ;
269     IF PERSON_STACK.NUMBER_OF_ELEMENTS
270        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 0 THEN
271          REPORT.FAILED (
272               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ;
273     END IF ;
274
275     PERSON_STACK.PUSH (THIS_ELEMENT     => MYSELF,
276                            ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
277     IF PERSON_STACK.NUMBER_OF_ELEMENTS
278        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 1 THEN
279          REPORT.FAILED (
280               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ;
281     END IF ;
282
283     PERSON_STACK.PUSH (THIS_ELEMENT     => FRIEND,
284                            ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
285     IF PERSON_STACK.NUMBER_OF_ELEMENTS
286        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN
287          REPORT.FAILED (
288               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ;
289     END IF ;
290
291     PERSON_STACK.PUSH (THIS_ELEMENT     => FATHER,
292                            ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
293     IF PERSON_STACK.NUMBER_OF_ELEMENTS
294        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 3 THEN
295          REPORT.FAILED (
296               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ;
297     END IF ;
298
299     PERSON_STACK.POP (THIS_ELEMENT   => FIRST_PERSON,
300                           OFF_THIS_STACK => FIRST_PERSON_STACK) ;
301     IF PERSON_STACK.NUMBER_OF_ELEMENTS
302        (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN
303          REPORT.FAILED (
304               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ;
305     END IF ;
306
307     IF FIRST_PERSON /= FATHER THEN
308          REPORT.FAILED (
309               "IMPROPER VALUE REMOVED FROM STACK - 1") ;
310     END IF ;
311
312     PERSON_STACK.CLEAR (THIS_STACK => SECOND_PERSON_STACK) ;
313     IF PERSON_STACK.NUMBER_OF_ELEMENTS
314        (ON_THIS_STACK => SECOND_PERSON_STACK) /= 0 THEN
315          REPORT.FAILED (
316               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ;
317     END IF ;
318
319     PERSON_STACK.COPY (THIS_STACK    => FIRST_PERSON_STACK,
320                            TO_THIS_STACK => SECOND_PERSON_STACK) ;
321
322     IF FIRST_PERSON_STACK /= SECOND_PERSON_STACK THEN
323          REPORT.FAILED (
324               "PROBLEMS WITH COPY OR TEST FOR EQUALITY (STACK)") ;
325     END IF ;
326
327     PERSON_STACK.POP (THIS_ELEMENT   => FIRST_PERSON,
328                       OFF_THIS_STACK => SECOND_PERSON_STACK) ;
329     PERSON_STACK.PUSH (THIS_ELEMENT     => DAUGHTER,
330                        ON_TO_THIS_STACK => SECOND_PERSON_STACK) ;
331     IF FIRST_PERSON_STACK = SECOND_PERSON_STACK THEN
332          REPORT.FAILED (
333               "PROBLEMS WITH POP OR TEST FOR EQUALITY (STACK)") ;
334     END IF ;
335
336     UNDERFLOW_EXCEPTION_TEST:
337
338     BEGIN  -- UNDERFLOW_EXCEPTION_TEST
339
340          PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ;
341          PERSON_STACK.POP (THIS_ELEMENT    => FIRST_PERSON,
342                            OFF_THIS_STACK  => THIRD_PERSON_STACK) ;
343          REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ;
344
345     EXCEPTION
346
347          WHEN PERSON_STACK.UNDERFLOW => NULL ;  -- CORRECT EXCEPTION
348                                                 -- RAISED
349          WHEN OTHERS =>
350               REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
351                              "UNDERFLOW EXCEPTION TEST") ;
352
353     END UNDERFLOW_EXCEPTION_TEST ;
354
355     OVERFLOW_EXCEPTION_TEST:
356
357     BEGIN  -- OVERFLOW_EXCEPTION_TEST
358
359          PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ;
360          FOR INDEX IN 1 .. 10 LOOP
361               PERSON_STACK.PUSH (
362                    THIS_ELEMENT     => MYSELF,
363                    ON_TO_THIS_STACK => THIRD_PERSON_STACK) ;
364          END LOOP ;
365
366          PERSON_STACK.PUSH (THIS_ELEMENT     => MYSELF,
367                             ON_TO_THIS_STACK => THIRD_PERSON_STACK) ;
368          REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ;
369
370     EXCEPTION
371
372          WHEN PERSON_STACK.OVERFLOW => NULL ;  -- CORRECT EXCEPTION
373                                                -- RAISED
374          WHEN OTHERS =>
375               REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
376                              "OVERFLOW EXCEPTION TEST") ;
377
378     END OVERFLOW_EXCEPTION_TEST ;
379
380     LOCAL_BLOCK:
381
382     DECLARE
383
384          TYPE PERSON_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF PERSON;
385
386          FIRST_PERSON_TABLE : PERSON_TABLE ;
387
388          TABLE_INDEX : POSITIVE := 1 ;
389
390          PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN  PERSON ;
391                                   CONTINUE    : OUT BOOLEAN) ;
392
393          PROCEDURE SHOW_PEOPLE (THIS_PERSON  : IN  PERSON ;
394                                 CONTINUE     : OUT BOOLEAN) ;
395
396          PROCEDURE GATHER_PERSON_ITERATE IS NEW
397               PERSON_STACK.ITERATE (PROCESS => GATHER_PEOPLE) ;
398
399          PROCEDURE SHOW_PERSON_ITERATE IS NEW
400               PERSON_STACK.ITERATE (PROCESS => SHOW_PEOPLE) ;
401
402          PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN  PERSON ;
403                                   CONTINUE    : OUT BOOLEAN) IS
404          BEGIN  -- GATHER_PEOPLE
405
406               FIRST_PERSON_TABLE (TABLE_INDEX) := THIS_PERSON ;
407               TABLE_INDEX := TABLE_INDEX + 1 ;
408
409               CONTINUE := TRUE ;
410
411          END GATHER_PEOPLE ;
412
413          PROCEDURE SHOW_PEOPLE (THIS_PERSON  : IN  PERSON ;
414                                 CONTINUE     : OUT BOOLEAN) IS
415
416          BEGIN  -- SHOW_PEOPLE
417
418               REPORT.COMMENT ("THE BIRTH MONTH IS " &
419                    MONTH_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.MONTH)) ;
420               REPORT.COMMENT ("THE BIRTH DAY IS " &
421                    DAY_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.DAY)) ;
422               REPORT.COMMENT ("THE BIRTH YEAR IS " &
423                    YEAR_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.YEAR)) ;
424               REPORT.COMMENT ("THE GENDER IS " &
425                    SEX'IMAGE (THIS_PERSON.GENDER)) ;
426               REPORT.COMMENT ("THE NAME IS " & THIS_PERSON.NAME) ;
427
428               CONTINUE := TRUE ;
429
430          END SHOW_PEOPLE ;
431
432     BEGIN  -- LOCAL_BLOCK
433
434          REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ;
435          SHOW_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK) ;
436
437          REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ;
438          SHOW_PERSON_ITERATE (OVER_THIS_STACK => SECOND_PERSON_STACK) ;
439
440          GATHER_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK);
441          IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR
442             (FIRST_PERSON_TABLE (2) /= FRIEND) THEN
443               REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ;
444          END IF ;
445
446          TABLE_INDEX := 1 ;
447          GATHER_PERSON_ITERATE(OVER_THIS_STACK => SECOND_PERSON_STACK);
448          IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR
449             (FIRST_PERSON_TABLE (2) /= DAUGHTER) THEN
450               REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ;
451          END IF ;
452
453     END LOCAL_BLOCK ;
454
455     REPORT.RESULT ;
456
457END CC3019C2M ;
458