old-autovect-branch/gcc/testsuite/ada/acats/support/repbody.ada

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