repbody.ada

来自「用于进行gcc测试」· ADA 代码 · 共 330 行

-- 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;