330 lines
12 KiB
Ada
330 lines
12 KiB
Ada
-- 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;
|