1-- REPBODY.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--
26-- HISTORY:
27--      DCB 04/27/80
28--      JRK 6/10/80
29--      JRK 11/12/80
30--      JRK 8/6/81
31--      JRK 10/27/82
32--      JRK 6/1/84
33--      JRK 11/18/85  ADDED PRAGMA ELABORATE.
34--      PWB 07/29/87  ADDED STATUS ACTION_REQUIRED AND
35--                    PROCEDURE SPECIAL_ACTION.
36--      TBN 08/20/87  ADDED FUNCTION LEGAL_FILE_NAME.
37--      BCB 05/17/90  MODIFIED TO ALLOW OUTPUT TO DIRECT_IO FILE.
38--                    ADDED TIME-STAMP.
39--      LDC 05/17/90  REMOVED OUTPUT TO DIRECT_IO FILE.
40--      WMC 08/11/92  UPDATED ACVC VERSION STRING TO "9X BASIC".
41--      DTN 07/05/92  UPDATED ACVC VERSION STRING TO
42--                    "ACVC 2.0 JULY 6 1993 DRAFT".
43--      WMC 01/24/94  MODIFIED LEGAL_FILE_NAME TO ALLOW FIVE POSSIBLE
44--                    FILE NAMES (INCREASED RANGE OF TYPE FILE_NUM TO 1..5).
45--      WMC 11/06/94  UPDATED ACVC VERSION STRING TO
46--                    "ACVC 2.0 NOVEMBER 6 1994 DRAFT".
47--      DTN 12/04/94  UPDATED ACVC VERSION STRING TO
48--                    "ACVC 2.0".
49--      KAS 06/19/95  ADDED FUNCTION IDENT_WIDE_CHAR.
50--      KAS 06/19/95  ADDED FUNCTION IDENT_WIDE_STR.
51--      DTN 11/21/95  UPDATED ACVC VERSION STRING TO
52--                    "ACVC 2.0.1".
53--      DTN 12/14/95  UPDATED ACVC VERSION STRING TO
54--                    "ACVC 2.1".
55--      EDS 12/17/97  UPDATED ACVC VERSION STRING TO
56--                    "2.2".
57--      RLB  3/16/00  UPDATED ACATS VERSION STRING TO "2.3".
58--                    CHANGED VARIOUS STRINGS TO READ "ACATS".
59--      RLB  3/22/01  UPDATED ACATS VERSION STRING TO "2.4".
60--      RLB  3/29/02  UPDATED ACATS VERSION STRING TO "2.5".
61--      RLB  3/06/07  UPDATED ACATS VERSION STRING TO "2.6".
62
63WITH TEXT_IO, CALENDAR;
64USE TEXT_IO, CALENDAR;
65PRAGMA ELABORATE (TEXT_IO, CALENDAR);
66
67PACKAGE BODY REPORT IS
68
69     TYPE STATUS IS (PASS, FAIL, DOES_NOT_APPLY, ACTION_REQUIRED,
70                     UNKNOWN);
71
72     TYPE TIME_INTEGER IS RANGE 0 .. 86_400;
73
74     TEST_STATUS : STATUS := FAIL;
75
76     MAX_NAME_LEN : CONSTANT := 15;     -- MAXIMUM TEST NAME LENGTH.
77     TEST_NAME : STRING (1..MAX_NAME_LEN);
78
79     NO_NAME : CONSTANT STRING (1..7) := "NO_NAME";
80     TEST_NAME_LEN : INTEGER RANGE 0..MAX_NAME_LEN := 0;
81
82
83
84     ACATS_VERSION : CONSTANT STRING := "2.6";
85                                       -- VERSION OF ACATS BEING RUN (X.XX).
86
87     PROCEDURE PUT_MSG (MSG : STRING) IS
88          -- WRITE MESSAGE.  LONG MESSAGES ARE FOLDED (AND INDENTED).
89          MAX_LEN : CONSTANT INTEGER RANGE 50..150 := 72;  -- MAXIMUM
90                                        -- OUTPUT LINE LENGTH.
91          INDENT : CONSTANT INTEGER := TEST_NAME_LEN + 9;  -- AMOUNT TO
92                                        -- INDENT CONTINUATION LINES.
93          I : INTEGER := 0;             -- CURRENT INDENTATION.
94          M : INTEGER := MSG'FIRST;     -- START OF MESSAGE SLICE.
95          N : INTEGER;                  -- END OF MESSAGE SLICE.
96     BEGIN
97          LOOP
98               IF I + (MSG'LAST-M+1) > MAX_LEN THEN
99                    N := M + (MAX_LEN-I) - 1;
100                    IF MSG (N) /= ' ' THEN
101                         WHILE N >= M AND THEN MSG (N+1) /= ' ' LOOP
102                              N := N - 1;
103                         END LOOP;
104                         IF N < M THEN
105                              N := M + (MAX_LEN-I) - 1;
106                         END IF;
107                    END IF;
108               ELSE N := MSG'LAST;
109               END IF;
110               SET_COL (STANDARD_OUTPUT, TEXT_IO.COUNT (I+1));
111               PUT_LINE (STANDARD_OUTPUT, MSG (M..N));
112               I := INDENT;
113               M := N + 1;
114               WHILE M <= MSG'LAST AND THEN MSG (M) = ' ' LOOP
115                    M := M + 1;
116               END LOOP;
117               EXIT WHEN M > MSG'LAST;
118          END LOOP;
119     END PUT_MSG;
120
121     FUNCTION TIME_STAMP RETURN STRING IS
122          TIME_NOW : CALENDAR.TIME;
123          YEAR,
124          MONTH,
125          DAY,
126          HOUR,
127          MINUTE,
128          SECOND : TIME_INTEGER := 1;
129
130          FUNCTION CONVERT (NUMBER : TIME_INTEGER) RETURN STRING IS
131               STR : STRING (1..2) := (OTHERS => '0');
132               DEC_DIGIT : CONSTANT STRING := "0123456789";
133               NUM : TIME_INTEGER := NUMBER;
134          BEGIN
135               IF NUM = 0 THEN
136                    RETURN STR;
137               ELSE
138                    NUM := NUM MOD 100;
139                    STR (2) := DEC_DIGIT (INTEGER (NUM MOD 10 + 1));
140                    NUM := NUM / 10;
141                    STR (1) := DEC_DIGIT (INTEGER (NUM + 1));
142                    RETURN STR;
143               END IF;
144          END CONVERT;
145     BEGIN
146          TIME_NOW := CALENDAR.CLOCK;
147          SPLIT (TIME_NOW, YEAR_NUMBER (YEAR), MONTH_NUMBER (MONTH),
148                  DAY_NUMBER (DAY), DAY_DURATION (SECOND));
149          HOUR := SECOND / 3600;
150          SECOND := SECOND MOD 3600;
151          MINUTE := SECOND / 60;
152          SECOND := SECOND MOD 60;
153          RETURN (CONVERT (TIME_INTEGER (YEAR)) & "-" &
154                  CONVERT (TIME_INTEGER (MONTH)) & "-" &
155                  CONVERT (TIME_INTEGER (DAY)) & " " &
156                  CONVERT (TIME_INTEGER (HOUR)) & ":" &
157                  CONVERT (TIME_INTEGER (MINUTE)) & ":" &
158                  CONVERT (TIME_INTEGER (SECOND)));
159     END TIME_STAMP;
160
161     PROCEDURE TEST (NAME : STRING; DESCR : STRING) IS
162     BEGIN
163          TEST_STATUS := PASS;
164          IF NAME'LENGTH <= MAX_NAME_LEN THEN
165               TEST_NAME_LEN := NAME'LENGTH;
166          ELSE TEST_NAME_LEN := MAX_NAME_LEN;
167          END IF;
168          TEST_NAME (1..TEST_NAME_LEN) :=
169                    NAME (NAME'FIRST .. NAME'FIRST+TEST_NAME_LEN-1);
170
171          PUT_MSG ("");
172          PUT_MSG (",.,. " & TEST_NAME (1..TEST_NAME_LEN) & " " &
173                   "ACATS " & ACATS_VERSION & " " & TIME_STAMP);
174          PUT_MSG ("---- " & TEST_NAME (1..TEST_NAME_LEN) & " " &
175                   DESCR & ".");
176     END TEST;
177
178     PROCEDURE COMMENT (DESCR : STRING) IS
179     BEGIN
180          PUT_MSG ("   - " & TEST_NAME (1..TEST_NAME_LEN) & " " &
181                   DESCR & ".");
182     END COMMENT;
183
184     PROCEDURE FAILED (DESCR : STRING) IS
185     BEGIN
186          TEST_STATUS := FAIL;
187          PUT_MSG ("   * " & TEST_NAME (1..TEST_NAME_LEN) & " " &
188                   DESCR & ".");
189     END FAILED;
190
191     PROCEDURE NOT_APPLICABLE (DESCR : STRING) IS
192     BEGIN
193          IF TEST_STATUS = PASS OR TEST_STATUS = ACTION_REQUIRED THEN
194               TEST_STATUS := DOES_NOT_APPLY;
195          END IF;
196          PUT_MSG ("   + " & TEST_NAME (1..TEST_NAME_LEN) & " " &
197                   DESCR & ".");
198     END NOT_APPLICABLE;
199
200     PROCEDURE SPECIAL_ACTION (DESCR : STRING) IS
201     BEGIN
202          IF TEST_STATUS = PASS THEN
203               TEST_STATUS := ACTION_REQUIRED;
204          END IF;
205          PUT_MSG ("   ! " & TEST_NAME (1..TEST_NAME_LEN) & " " &
206                   DESCR & ".");
207     END SPECIAL_ACTION;
208
209     PROCEDURE RESULT IS
210     BEGIN
211          CASE TEST_STATUS IS
212          WHEN PASS =>
213               PUT_MSG ("==== " & TEST_NAME (1..TEST_NAME_LEN) &
214                        " PASSED ============================.");
215          WHEN DOES_NOT_APPLY =>
216               PUT_MSG ("++++ " & TEST_NAME (1..TEST_NAME_LEN) &
217                        " NOT-APPLICABLE ++++++++++++++++++++.");
218          WHEN ACTION_REQUIRED =>
219               PUT_MSG ("!!!! " & TEST_NAME (1..TEST_NAME_LEN) &
220                        " TENTATIVELY PASSED !!!!!!!!!!!!!!!!.");
221               PUT_MSG ("!!!! " & (1..TEST_NAME_LEN => ' ') &
222                        " SEE '!' COMMENTS FOR SPECIAL NOTES!!");
223          WHEN OTHERS =>
224               PUT_MSG ("**** " & TEST_NAME (1..TEST_NAME_LEN) &
225                        " FAILED ****************************.");
226          END CASE;
227          TEST_STATUS := FAIL;
228          TEST_NAME_LEN := NO_NAME'LENGTH;
229          TEST_NAME (1..TEST_NAME_LEN) := NO_NAME;
230     END RESULT;
231
232     FUNCTION IDENT_INT (X : INTEGER) RETURN INTEGER IS
233     BEGIN
234          IF EQUAL (X, X) THEN          -- ALWAYS EQUAL.
235               RETURN X;                -- ALWAYS EXECUTED.
236          END IF;
237          RETURN 0;                     -- NEVER EXECUTED.
238     END IDENT_INT;
239
240     FUNCTION IDENT_CHAR (X : CHARACTER) RETURN CHARACTER IS
241     BEGIN
242          IF EQUAL (CHARACTER'POS(X), CHARACTER'POS(X)) THEN  -- ALWAYS
243                                        -- EQUAL.
244               RETURN X;                -- ALWAYS EXECUTED.
245          END IF;
246          RETURN '0';                   -- NEVER EXECUTED.
247     END IDENT_CHAR;
248
249     FUNCTION IDENT_WIDE_CHAR (X : WIDE_CHARACTER) RETURN WIDE_CHARACTER IS
250     BEGIN
251          IF EQUAL (WIDE_CHARACTER'POS(X), WIDE_CHARACTER'POS(X)) THEN
252                                        -- ALWAYS EQUAL.
253               RETURN X;                -- ALWAYS EXECUTED.
254          END IF;
255          RETURN '0';                   -- NEVER EXECUTED.
256     END IDENT_WIDE_CHAR;
257
258     FUNCTION IDENT_BOOL (X : BOOLEAN) RETURN BOOLEAN IS
259     BEGIN
260          IF EQUAL (BOOLEAN'POS(X), BOOLEAN'POS(X)) THEN  -- ALWAYS
261                                        -- EQUAL.
262               RETURN X;                -- ALWAYS EXECUTED.
263          END IF;
264          RETURN FALSE;                 -- NEVER EXECUTED.
265     END IDENT_BOOL;
266
267     FUNCTION IDENT_STR (X : STRING) RETURN STRING IS
268     BEGIN
269          IF EQUAL (X'LENGTH, X'LENGTH) THEN  -- ALWAYS EQUAL.
270               RETURN X;                -- ALWAYS EXECUTED.
271          END IF;
272          RETURN "";                    -- NEVER EXECUTED.
273     END IDENT_STR;
274
275     FUNCTION IDENT_WIDE_STR (X : WIDE_STRING) RETURN WIDE_STRING IS
276     BEGIN
277          IF EQUAL (X'LENGTH, X'LENGTH) THEN  -- ALWAYS EQUAL.
278               RETURN X;                -- ALWAYS EXECUTED.
279          END IF;
280          RETURN "";                    -- NEVER EXECUTED.
281     END IDENT_WIDE_STR;
282
283     FUNCTION EQUAL (X, Y : INTEGER) RETURN BOOLEAN IS
284          REC_LIMIT : CONSTANT INTEGER RANGE 1..100 := 3;  -- RECURSION
285                                        -- LIMIT.
286          Z : BOOLEAN;                  -- RESULT.
287     BEGIN
288          IF X < 0 THEN
289               IF Y < 0 THEN
290                    Z := EQUAL (-X, -Y);
291               ELSE Z := FALSE;
292               END IF;
293          ELSIF X > REC_LIMIT THEN
294               Z := EQUAL (REC_LIMIT, Y-X+REC_LIMIT);
295          ELSIF X > 0 THEN
296               Z := EQUAL (X-1, Y-1);
297          ELSE Z := Y = 0;
298          END IF;
299          RETURN Z;
300     EXCEPTION
301          WHEN OTHERS =>
302               RETURN X = Y;
303     END EQUAL;
304
305     FUNCTION LEGAL_FILE_NAME (X : FILE_NUM := 1;
306                               NAM : STRING := "")
307                              RETURN STRING IS
308          SUFFIX : STRING (2..6);
309     BEGIN
310          IF NAM = "" THEN
311               SUFFIX := TEST_NAME(3..7);
312          ELSE
313               SUFFIX := NAM(3..7);
314          END IF;
315
316          CASE X IS
317               WHEN 1 => RETURN ('X' & SUFFIX);
318               WHEN 2 => RETURN ('Y' & SUFFIX);
319               WHEN 3 => RETURN ('Z' & SUFFIX);
320               WHEN 4 => RETURN ('V' & SUFFIX);
321               WHEN 5 => RETURN ('W' & SUFFIX);
322          END CASE;
323     END LEGAL_FILE_NAME;
324
325BEGIN
326
327     TEST_NAME_LEN := NO_NAME'LENGTH;
328     TEST_NAME (1..TEST_NAME_LEN) := NO_NAME;
329
330END REPORT;
331