diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/support/repbody.ada')
| -rw-r--r-- | gcc/testsuite/ada/acats/support/repbody.ada | 329 |
1 files changed, 329 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/support/repbody.ada b/gcc/testsuite/ada/acats/support/repbody.ada new file mode 100644 index 000000000..dd5c53b90 --- /dev/null +++ b/gcc/testsuite/ada/acats/support/repbody.ada @@ -0,0 +1,329 @@ +-- 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; |