1-- CC3019B2M.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. THIS TEST SPECIFICALLY CHECKS THAT A
27--  NESTING LEVEL OF 2 IS SUPPORTED FOR GENERICS.
28--
29--  *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE
30--  *** SOURCE CODE IN FILES CC3019B0.ADA AND CC3019B1.ADA HAVE
31--  *** BEEN COMPILED.
32--
33-- HISTORY:
34--         EDWARD V. BERARD, 31 AUGUST 1990
35
36WITH REPORT ;
37WITH CC3019B1_STACK_CLASS ;
38
39PROCEDURE CC3019B2M IS
40
41     TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
42                         SEP, OCT, NOV, DEC) ;
43     TYPE DAY_TYPE IS RANGE 1 .. 31 ;
44     TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
45     TYPE DATE IS RECORD
46          MONTH : MONTH_TYPE ;
47          DAY   : DAY_TYPE ;
48          YEAR  : YEAR_TYPE ;
49     END RECORD ;
50
51     STORE_DATE     : DATE ;
52
53     TODAY        : DATE := (MONTH => AUG,
54                             DAY   => 31,
55                             YEAR  => 1990) ;
56
57     FIRST_DATE   : DATE := (MONTH => JUN,
58                             DAY   => 4,
59                             YEAR  => 1967) ;
60
61     BIRTH_DATE   : DATE := (MONTH => OCT,
62                             DAY   => 3,
63                             YEAR  => 1949) ;
64
65     WALL_DATE    : DATE := (MONTH => NOV,
66                             DAY   => 9,
67                             YEAR  => 1989) ;
68
69     PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE    : IN OUT DATE ;
70                       TO_THIS_DATE              : IN OUT DATE) ;
71
72     FUNCTION IS_EQUAL (LEFT  : IN DATE ;
73                        RIGHT : IN DATE) RETURN BOOLEAN ;
74
75     PACKAGE DATE_STACK IS
76          NEW CC3019B1_STACK_CLASS (ELEMENT => DATE,
77                                    ASSIGN  => ASSIGN,
78                                    "="     => IS_EQUAL) ;
79
80     FIRST_DATE_STACK    : DATE_STACK.STACK ;
81     SECOND_DATE_STACK   : DATE_STACK.STACK ;
82     THIRD_DATE_STACK    : DATE_STACK.STACK ;
83
84     FUNCTION "=" (LEFT  : IN DATE_STACK.STACK ;
85                   RIGHT : IN DATE_STACK.STACK) RETURN BOOLEAN
86                   RENAMES DATE_STACK."=" ;
87
88     PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE    : IN OUT DATE ;
89                       TO_THIS_DATE              : IN OUT DATE) IS
90
91     BEGIN -- ASSIGN
92
93          TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ;
94
95     END ASSIGN ;
96
97     FUNCTION IS_EQUAL (LEFT  : IN DATE ;
98                        RIGHT : IN DATE) RETURN BOOLEAN IS
99
100     BEGIN -- IS_EQUAL
101
102          RETURN (LEFT.MONTH = RIGHT.MONTH) AND
103                 (LEFT.DAY = RIGHT.DAY) AND
104                 (LEFT.YEAR = RIGHT.YEAR) ;
105
106     END IS_EQUAL ;
107
108BEGIN  -- CC3019B2M
109
110     REPORT.TEST ("CC3019B2M",
111                  "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " &
112                  "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " &
113                  "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF " &
114                  "2 IS SUPPORTED FOR GENERICS.") ;
115
116     DATE_STACK.CLEAR (THIS_STACK => FIRST_DATE_STACK) ;
117     IF DATE_STACK.NUMBER_OF_ELEMENTS
118        (ON_THIS_STACK => FIRST_DATE_STACK) /= 0 THEN
119          REPORT.FAILED (
120               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ;
121     END IF ;
122
123     DATE_STACK.PUSH (THIS_ELEMENT     => TODAY,
124                      ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
125     IF DATE_STACK.NUMBER_OF_ELEMENTS
126        (ON_THIS_STACK => FIRST_DATE_STACK) /= 1 THEN
127          REPORT.FAILED (
128               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ;
129     END IF ;
130
131     DATE_STACK.PUSH (THIS_ELEMENT     => FIRST_DATE,
132                      ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
133     IF DATE_STACK.NUMBER_OF_ELEMENTS
134        (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN
135          REPORT.FAILED (
136               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ;
137     END IF ;
138
139     DATE_STACK.PUSH (THIS_ELEMENT     => BIRTH_DATE,
140                      ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
141     IF DATE_STACK.NUMBER_OF_ELEMENTS
142        (ON_THIS_STACK => FIRST_DATE_STACK) /= 3 THEN
143          REPORT.FAILED (
144               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ;
145     END IF ;
146
147     DATE_STACK.POP (THIS_ELEMENT   => STORE_DATE,
148                           OFF_THIS_STACK => FIRST_DATE_STACK) ;
149     IF DATE_STACK.NUMBER_OF_ELEMENTS
150        (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN
151          REPORT.FAILED (
152               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ;
153     END IF ;
154
155     IF STORE_DATE /= BIRTH_DATE THEN
156          REPORT.FAILED (
157               "IMPROPER VALUE REMOVED FROM STACK - 1") ;
158     END IF ;
159
160     DATE_STACK.CLEAR (THIS_STACK => SECOND_DATE_STACK) ;
161     IF DATE_STACK.NUMBER_OF_ELEMENTS
162        (ON_THIS_STACK => SECOND_DATE_STACK) /= 0 THEN
163          REPORT.FAILED (
164               "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ;
165     END IF ;
166
167     DATE_STACK.COPY (THIS_STACK    => FIRST_DATE_STACK,
168                      TO_THIS_STACK => SECOND_DATE_STACK) ;
169
170     IF FIRST_DATE_STACK /= SECOND_DATE_STACK THEN
171          REPORT.FAILED (
172               "PROBLEMS WITH COPY OR TEST FOR EQUALITY") ;
173     END IF ;
174
175     DATE_STACK.POP (THIS_ELEMENT   => STORE_DATE,
176                     OFF_THIS_STACK => SECOND_DATE_STACK) ;
177     DATE_STACK.PUSH (THIS_ELEMENT     => WALL_DATE,
178                      ON_TO_THIS_STACK => SECOND_DATE_STACK) ;
179     IF FIRST_DATE_STACK = SECOND_DATE_STACK THEN
180          REPORT.FAILED (
181               "PROBLEMS WITH POP OR TEST FOR EQUALITY") ;
182     END IF ;
183
184     UNDERFLOW_EXCEPTION_TEST:
185
186     BEGIN  -- UNDERFLOW_EXCEPTION_TEST
187
188          DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ;
189          DATE_STACK.POP (THIS_ELEMENT      => STORE_DATE,
190                          OFF_THIS_STACK    => THIRD_DATE_STACK) ;
191          REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ;
192
193     EXCEPTION
194
195          WHEN DATE_STACK.UNDERFLOW => NULL ;  -- CORRECT EXCEPTION
196                                               -- RAISED
197          WHEN OTHERS =>
198               REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
199                              "UNDERFLOW EXCEPTION TEST") ;
200
201     END UNDERFLOW_EXCEPTION_TEST ;
202
203     OVERFLOW_EXCEPTION_TEST:
204
205     BEGIN  -- OVERFLOW_EXCEPTION_TEST
206
207          DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ;
208          FOR INDEX IN 1 .. 10 LOOP
209               DATE_STACK.PUSH ( THIS_ELEMENT     => TODAY,
210                                 ON_TO_THIS_STACK => THIRD_DATE_STACK) ;
211          END LOOP ;
212
213          DATE_STACK.PUSH (THIS_ELEMENT     => TODAY,
214                           ON_TO_THIS_STACK => THIRD_DATE_STACK) ;
215          REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ;
216
217     EXCEPTION
218
219          WHEN DATE_STACK.OVERFLOW => NULL ;  -- CORRECT EXCEPTION
220                                              -- RAISED
221          WHEN OTHERS =>
222               REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
223                              "OVERFLOW EXCEPTION TEST") ;
224
225     END OVERFLOW_EXCEPTION_TEST ;
226
227     LOCAL_BLOCK:
228
229     DECLARE
230
231          TYPE DATE_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF DATE ;
232
233          FIRST_DATE_TABLE : DATE_TABLE ;
234
235          TABLE_INDEX : POSITIVE := 1 ;
236
237          PROCEDURE SHOW_DATES (THIS_DATE : IN  DATE ;
238                                CONTINUE  : OUT BOOLEAN) ;
239
240          PROCEDURE STORE_DATES (THIS_DATE : IN DATE ;
241                                 CONTINUE  : OUT BOOLEAN) ;
242
243          PROCEDURE SHOW_DATE_ITERATE IS NEW
244               DATE_STACK.ITERATE (PROCESS => SHOW_DATES) ;
245
246          PROCEDURE STORE_DATE_ITERATE IS NEW
247               DATE_STACK.ITERATE (PROCESS => STORE_DATES) ;
248
249          PROCEDURE SHOW_DATES (THIS_DATE : IN  DATE ;
250                                CONTINUE  : OUT BOOLEAN) IS
251          BEGIN  -- SHOW_DATES
252
253                REPORT.COMMENT ("THE MONTH IS " &
254                           MONTH_TYPE'IMAGE (THIS_DATE.MONTH)) ;
255                REPORT.COMMENT ("THE DAY IS " &
256                           DAY_TYPE'IMAGE (THIS_DATE.DAY)) ;
257                REPORT.COMMENT ("THE YEAR IS " &
258                           YEAR_TYPE'IMAGE (THIS_DATE.YEAR)) ;
259
260                CONTINUE := TRUE ;
261
262          END SHOW_DATES ;
263
264          PROCEDURE STORE_DATES (THIS_DATE : IN  DATE ;
265                                       CONTINUE  : OUT BOOLEAN) IS
266          BEGIN  -- STORE_DATES
267
268                FIRST_DATE_TABLE (TABLE_INDEX) := THIS_DATE ;
269                TABLE_INDEX := TABLE_INDEX + 1 ;
270
271                CONTINUE := TRUE ;
272
273          END STORE_DATES ;
274
275     BEGIN  -- LOCAL_BLOCK
276
277          REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ;
278          SHOW_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ;
279
280          REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ;
281          SHOW_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ;
282
283          STORE_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ;
284          IF (FIRST_DATE_TABLE (1) /= TODAY) OR
285               (FIRST_DATE_TABLE (2) /= FIRST_DATE) THEN
286                     REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ;
287          END IF ;
288
289          TABLE_INDEX := 1 ;
290          STORE_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ;
291          IF (FIRST_DATE_TABLE (1) /= TODAY) OR
292               (FIRST_DATE_TABLE (2) /= WALL_DATE) THEN
293                     REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ;
294          END IF ;
295
296     END LOCAL_BLOCK ;
297
298     REPORT.RESULT ;
299
300END CC3019B2M ;
301