| -- REPBODY.ADA |
| -- |
| -- Grant of Unlimited Rights |
| -- |
| -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, |
| -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained |
| -- unlimited rights in the software and documentation contained herein. |
| -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making |
| -- this public release, the Government intends to confer upon all |
| -- recipients unlimited rights equal to those held by the Government. |
| -- These rights include rights to use, duplicate, release or disclose the |
| -- released technical data and computer software in whole or in part, in |
| -- any manner and for any purpose whatsoever, and to have or permit others |
| -- to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- |
| -- HISTORY: |
| -- DCB 04/27/80 |
| -- JRK 6/10/80 |
| -- JRK 11/12/80 |
| -- JRK 8/6/81 |
| -- JRK 10/27/82 |
| -- JRK 6/1/84 |
| -- JRK 11/18/85 ADDED PRAGMA ELABORATE. |
| -- PWB 07/29/87 ADDED STATUS ACTION_REQUIRED AND |
| -- PROCEDURE SPECIAL_ACTION. |
| -- TBN 08/20/87 ADDED FUNCTION LEGAL_FILE_NAME. |
| -- BCB 05/17/90 MODIFIED TO ALLOW OUTPUT TO DIRECT_IO FILE. |
| -- ADDED TIME-STAMP. |
| -- LDC 05/17/90 REMOVED OUTPUT TO DIRECT_IO FILE. |
| -- WMC 08/11/92 UPDATED ACVC VERSION STRING TO "9X BASIC". |
| -- DTN 07/05/92 UPDATED ACVC VERSION STRING TO |
| -- "ACVC 2.0 JULY 6 1993 DRAFT". |
| -- WMC 01/24/94 MODIFIED LEGAL_FILE_NAME TO ALLOW FIVE POSSIBLE |
| -- FILE NAMES (INCREASED RANGE OF TYPE FILE_NUM TO 1..5). |
| -- WMC 11/06/94 UPDATED ACVC VERSION STRING TO |
| -- "ACVC 2.0 NOVEMBER 6 1994 DRAFT". |
| -- DTN 12/04/94 UPDATED ACVC VERSION STRING TO |
| -- "ACVC 2.0". |
| -- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_CHAR. |
| -- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_STR. |
| -- DTN 11/21/95 UPDATED ACVC VERSION STRING TO |
| -- "ACVC 2.0.1". |
| -- DTN 12/14/95 UPDATED ACVC VERSION STRING TO |
| -- "ACVC 2.1". |
| -- EDS 12/17/97 UPDATED ACVC VERSION STRING TO |
| -- "2.2". |
| -- RLB 3/16/00 UPDATED ACATS VERSION STRING TO "2.3". |
| -- CHANGED VARIOUS STRINGS TO READ "ACATS". |
| -- RLB 3/22/01 UPDATED ACATS VERSION STRING TO "2.4". |
| -- RLB 3/29/01 UPDATED ACATS VERSION STRING TO "2.5". |
| |
| WITH TEXT_IO, CALENDAR; |
| USE TEXT_IO, CALENDAR; |
| PRAGMA ELABORATE (TEXT_IO, CALENDAR); |
| |
| PACKAGE BODY REPORT IS |
| |
| TYPE STATUS IS (PASS, FAIL, DOES_NOT_APPLY, ACTION_REQUIRED, |
| UNKNOWN); |
| |
| TYPE TIME_INTEGER IS RANGE 0 .. 86_400; |
| |
| TEST_STATUS : STATUS := FAIL; |
| |
| MAX_NAME_LEN : CONSTANT := 15; -- MAXIMUM TEST NAME LENGTH. |
| TEST_NAME : STRING (1..MAX_NAME_LEN); |
| |
| NO_NAME : CONSTANT STRING (1..7) := "NO_NAME"; |
| TEST_NAME_LEN : INTEGER RANGE 0..MAX_NAME_LEN := 0; |
| |
| |
| |
| ACATS_VERSION : CONSTANT STRING := "2.5"; |
| -- VERSION OF ACATS BEING RUN (X.XX). |
| |
| PROCEDURE PUT_MSG (MSG : STRING) IS |
| -- WRITE MESSAGE. LONG MESSAGES ARE FOLDED (AND INDENTED). |
| MAX_LEN : CONSTANT INTEGER RANGE 50..150 := 72; -- MAXIMUM |
| -- OUTPUT LINE LENGTH. |
| INDENT : CONSTANT INTEGER := TEST_NAME_LEN + 9; -- AMOUNT TO |
| -- INDENT CONTINUATION LINES. |
| I : INTEGER := 0; -- CURRENT INDENTATION. |
| M : INTEGER := MSG'FIRST; -- START OF MESSAGE SLICE. |
| N : INTEGER; -- END OF MESSAGE SLICE. |
| BEGIN |
| LOOP |
| IF I + (MSG'LAST-M+1) > MAX_LEN THEN |
| N := M + (MAX_LEN-I) - 1; |
| IF MSG (N) /= ' ' THEN |
| WHILE N >= M AND THEN MSG (N+1) /= ' ' LOOP |
| N := N - 1; |
| END LOOP; |
| IF N < M THEN |
| N := M + (MAX_LEN-I) - 1; |
| END IF; |
| END IF; |
| ELSE N := MSG'LAST; |
| END IF; |
| SET_COL (STANDARD_OUTPUT, TEXT_IO.COUNT (I+1)); |
| PUT_LINE (STANDARD_OUTPUT, MSG (M..N)); |
| I := INDENT; |
| M := N + 1; |
| WHILE M <= MSG'LAST AND THEN MSG (M) = ' ' LOOP |
| M := M + 1; |
| END LOOP; |
| EXIT WHEN M > MSG'LAST; |
| END LOOP; |
| END PUT_MSG; |
| |
| FUNCTION TIME_STAMP RETURN STRING IS |
| TIME_NOW : CALENDAR.TIME; |
| YEAR, |
| MONTH, |
| DAY, |
| HOUR, |
| MINUTE, |
| SECOND : TIME_INTEGER := 1; |
| |
| FUNCTION CONVERT (NUMBER : TIME_INTEGER) RETURN STRING IS |
| STR : STRING (1..2) := (OTHERS => '0'); |
| DEC_DIGIT : CONSTANT STRING := "0123456789"; |
| NUM : TIME_INTEGER := NUMBER; |
| BEGIN |
| IF NUM = 0 THEN |
| RETURN STR; |
| ELSE |
| NUM := NUM MOD 100; |
| STR (2) := DEC_DIGIT (INTEGER (NUM MOD 10 + 1)); |
| NUM := NUM / 10; |
| STR (1) := DEC_DIGIT (INTEGER (NUM + 1)); |
| RETURN STR; |
| END IF; |
| END CONVERT; |
| BEGIN |
| TIME_NOW := CALENDAR.CLOCK; |
| SPLIT (TIME_NOW, YEAR_NUMBER (YEAR), MONTH_NUMBER (MONTH), |
| DAY_NUMBER (DAY), DAY_DURATION (SECOND)); |
| HOUR := SECOND / 3600; |
| SECOND := SECOND MOD 3600; |
| MINUTE := SECOND / 60; |
| SECOND := SECOND MOD 60; |
| RETURN (CONVERT (TIME_INTEGER (YEAR)) & "-" & |
| CONVERT (TIME_INTEGER (MONTH)) & "-" & |
| CONVERT (TIME_INTEGER (DAY)) & " " & |
| CONVERT (TIME_INTEGER (HOUR)) & ":" & |
| CONVERT (TIME_INTEGER (MINUTE)) & ":" & |
| CONVERT (TIME_INTEGER (SECOND))); |
| END TIME_STAMP; |
| |
| PROCEDURE TEST (NAME : STRING; DESCR : STRING) IS |
| BEGIN |
| TEST_STATUS := PASS; |
| IF NAME'LENGTH <= MAX_NAME_LEN THEN |
| TEST_NAME_LEN := NAME'LENGTH; |
| ELSE TEST_NAME_LEN := MAX_NAME_LEN; |
| END IF; |
| TEST_NAME (1..TEST_NAME_LEN) := |
| NAME (NAME'FIRST .. NAME'FIRST+TEST_NAME_LEN-1); |
| |
| PUT_MSG (""); |
| PUT_MSG (",.,. " & TEST_NAME (1..TEST_NAME_LEN) & " " & |
| "ACATS " & ACATS_VERSION & " " & TIME_STAMP); |
| PUT_MSG ("---- " & TEST_NAME (1..TEST_NAME_LEN) & " " & |
| DESCR & "."); |
| END TEST; |
| |
| PROCEDURE COMMENT (DESCR : STRING) IS |
| BEGIN |
| PUT_MSG (" - " & TEST_NAME (1..TEST_NAME_LEN) & " " & |
| DESCR & "."); |
| END COMMENT; |
| |
| PROCEDURE FAILED (DESCR : STRING) IS |
| BEGIN |
| TEST_STATUS := FAIL; |
| PUT_MSG (" * " & TEST_NAME (1..TEST_NAME_LEN) & " " & |
| DESCR & "."); |
| END FAILED; |
| |
| PROCEDURE NOT_APPLICABLE (DESCR : STRING) IS |
| BEGIN |
| IF TEST_STATUS = PASS OR TEST_STATUS = ACTION_REQUIRED THEN |
| TEST_STATUS := DOES_NOT_APPLY; |
| END IF; |
| PUT_MSG (" + " & TEST_NAME (1..TEST_NAME_LEN) & " " & |
| DESCR & "."); |
| END NOT_APPLICABLE; |
| |
| PROCEDURE SPECIAL_ACTION (DESCR : STRING) IS |
| BEGIN |
| IF TEST_STATUS = PASS THEN |
| TEST_STATUS := ACTION_REQUIRED; |
| END IF; |
| PUT_MSG (" ! " & TEST_NAME (1..TEST_NAME_LEN) & " " & |
| DESCR & "."); |
| END SPECIAL_ACTION; |
| |
| PROCEDURE RESULT IS |
| BEGIN |
| CASE TEST_STATUS IS |
| WHEN PASS => |
| PUT_MSG ("==== " & TEST_NAME (1..TEST_NAME_LEN) & |
| " PASSED ============================."); |
| WHEN DOES_NOT_APPLY => |
| PUT_MSG ("++++ " & TEST_NAME (1..TEST_NAME_LEN) & |
| " NOT-APPLICABLE ++++++++++++++++++++."); |
| WHEN ACTION_REQUIRED => |
| PUT_MSG ("!!!! " & TEST_NAME (1..TEST_NAME_LEN) & |
| " TENTATIVELY PASSED !!!!!!!!!!!!!!!!."); |
| PUT_MSG ("!!!! " & (1..TEST_NAME_LEN => ' ') & |
| " SEE '!' COMMENTS FOR SPECIAL NOTES!!"); |
| WHEN OTHERS => |
| PUT_MSG ("**** " & TEST_NAME (1..TEST_NAME_LEN) & |
| " FAILED ****************************."); |
| END CASE; |
| TEST_STATUS := FAIL; |
| TEST_NAME_LEN := NO_NAME'LENGTH; |
| TEST_NAME (1..TEST_NAME_LEN) := NO_NAME; |
| END RESULT; |
| |
| FUNCTION IDENT_INT (X : INTEGER) RETURN INTEGER IS |
| BEGIN |
| IF EQUAL (X, X) THEN -- ALWAYS EQUAL. |
| RETURN X; -- ALWAYS EXECUTED. |
| END IF; |
| RETURN 0; -- NEVER EXECUTED. |
| END IDENT_INT; |
| |
| FUNCTION IDENT_CHAR (X : CHARACTER) RETURN CHARACTER IS |
| BEGIN |
| IF EQUAL (CHARACTER'POS(X), CHARACTER'POS(X)) THEN -- ALWAYS |
| -- EQUAL. |
| RETURN X; -- ALWAYS EXECUTED. |
| END IF; |
| RETURN '0'; -- NEVER EXECUTED. |
| END IDENT_CHAR; |
| |
| FUNCTION IDENT_WIDE_CHAR (X : WIDE_CHARACTER) RETURN WIDE_CHARACTER IS |
| BEGIN |
| IF EQUAL (WIDE_CHARACTER'POS(X), WIDE_CHARACTER'POS(X)) THEN |
| -- ALWAYS EQUAL. |
| RETURN X; -- ALWAYS EXECUTED. |
| END IF; |
| RETURN '0'; -- NEVER EXECUTED. |
| END IDENT_WIDE_CHAR; |
| |
| FUNCTION IDENT_BOOL (X : BOOLEAN) RETURN BOOLEAN IS |
| BEGIN |
| IF EQUAL (BOOLEAN'POS(X), BOOLEAN'POS(X)) THEN -- ALWAYS |
| -- EQUAL. |
| RETURN X; -- ALWAYS EXECUTED. |
| END IF; |
| RETURN FALSE; -- NEVER EXECUTED. |
| END IDENT_BOOL; |
| |
| FUNCTION IDENT_STR (X : STRING) RETURN STRING IS |
| BEGIN |
| IF EQUAL (X'LENGTH, X'LENGTH) THEN -- ALWAYS EQUAL. |
| RETURN X; -- ALWAYS EXECUTED. |
| END IF; |
| RETURN ""; -- NEVER EXECUTED. |
| END IDENT_STR; |
| |
| FUNCTION IDENT_WIDE_STR (X : WIDE_STRING) RETURN WIDE_STRING IS |
| BEGIN |
| IF EQUAL (X'LENGTH, X'LENGTH) THEN -- ALWAYS EQUAL. |
| RETURN X; -- ALWAYS EXECUTED. |
| END IF; |
| RETURN ""; -- NEVER EXECUTED. |
| END IDENT_WIDE_STR; |
| |
| FUNCTION EQUAL (X, Y : INTEGER) RETURN BOOLEAN IS |
| REC_LIMIT : CONSTANT INTEGER RANGE 1..100 := 3; -- RECURSION |
| -- LIMIT. |
| Z : BOOLEAN; -- RESULT. |
| BEGIN |
| IF X < 0 THEN |
| IF Y < 0 THEN |
| Z := EQUAL (-X, -Y); |
| ELSE Z := FALSE; |
| END IF; |
| ELSIF X > REC_LIMIT THEN |
| Z := EQUAL (REC_LIMIT, Y-X+REC_LIMIT); |
| ELSIF X > 0 THEN |
| Z := EQUAL (X-1, Y-1); |
| ELSE Z := Y = 0; |
| END IF; |
| RETURN Z; |
| EXCEPTION |
| WHEN OTHERS => |
| RETURN X = Y; |
| END EQUAL; |
| |
| FUNCTION LEGAL_FILE_NAME (X : FILE_NUM := 1; |
| NAM : STRING := "") |
| RETURN STRING IS |
| SUFFIX : STRING (2..6); |
| BEGIN |
| IF NAM = "" THEN |
| SUFFIX := TEST_NAME(3..7); |
| ELSE |
| SUFFIX := NAM(3..7); |
| END IF; |
| |
| CASE X IS |
| WHEN 1 => RETURN ('X' & SUFFIX); |
| WHEN 2 => RETURN ('Y' & SUFFIX); |
| WHEN 3 => RETURN ('Z' & SUFFIX); |
| WHEN 4 => RETURN ('V' & SUFFIX); |
| WHEN 5 => RETURN ('W' & SUFFIX); |
| END CASE; |
| END LEGAL_FILE_NAME; |
| |
| BEGIN |
| |
| TEST_NAME_LEN := NO_NAME'LENGTH; |
| TEST_NAME (1..TEST_NAME_LEN) := NO_NAME; |
| |
| END REPORT; |
