URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [support/] [repbody.ada] - Rev 816
Compare with Previous | Blame | View Log
-- 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;