URL
https://opencores.org/ocsvn/scarts/scarts/trunk
Subversion Repositories scarts
[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c6/] [c64005c.ada] - Rev 12
Compare with Previous | Blame | View Log
-- C64005C.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. --* -- CHECK THAT NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT -- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM -- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR -- STATIC CHAIN LEVEL CAN BE ACCESSED. -- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES. -- JRK 7/26/84 WITH REPORT; USE REPORT; PROCEDURE C64005C IS SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C'; SUBTYPE CALL IS CHARACTER RANGE '1' .. '3'; MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) - LEVEL'POS (LEVEL'FIRST) + 1; T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV + MAX_LEV*(MAX_LEV+1)/2*2)) + 1; G_LEN : CONSTANT := 2 + 4 * MAX_LEV; TYPE TRACE IS RECORD E : NATURAL := 0; S : STRING (1 .. T_LEN); END RECORD; V : CHARACTER := IDENT_CHAR ('<'); L : CHARACTER := IDENT_CHAR ('>'); T : TRACE; G : STRING (1 .. G_LEN); PROCEDURE C64005CA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS V : STRING (1..2); M : CONSTANT NATURAL := LEVEL'POS (L) - LEVEL'POS (LEVEL'FIRST) + 1; N : CONSTANT NATURAL := 2 * M + 1; PROCEDURE C64005CB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS V : STRING (1..2); M : CONSTANT NATURAL := LEVEL'POS (L) - LEVEL'POS (LEVEL'FIRST) + 1; N : CONSTANT NATURAL := 2 * M + 1; PROCEDURE C64005CC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS V : STRING (1..2); M : CONSTANT NATURAL := LEVEL'POS (L) - LEVEL'POS (LEVEL'FIRST) + 1; N : CONSTANT NATURAL := 2 * M + 1; BEGIN V (1) := IDENT_CHAR (ASCII.LC_C); V (2) := C; -- APPEND ALL V TO T. T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V & C64005CB.V & C64005CC.V; T.E := T.E + N; CASE C IS WHEN '1' => C64005CA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('2'), T); WHEN '2' => C64005CC (L, IDENT_CHAR('3'), T); WHEN '3' => -- APPEND MID-POINT SYMBOL TO T. T.S (T.E+1) := IDENT_CHAR ('='); T.E := T.E + 1; -- G := CATENATE ALL V, L, C; G := C64005C.V & C64005C.L & C64005CA.V & C64005CA.L & C64005CA.C & C64005CB.V & C64005CB.L & C64005CB.C & C64005CC.V & C64005CC.L & C64005CC.C; END CASE; -- APPEND ALL L AND C TO T IN REVERSE ORDER. T.S (T.E+1 .. T.E+N) := C64005CC.L & C64005CC.C & C64005CB.L & C64005CB.C & C64005CA.L & C64005CA.C & C64005C.L; T.E := T.E + N; END C64005CC; BEGIN V (1) := IDENT_CHAR (ASCII.LC_B); V (2) := C; -- APPEND ALL V TO T. T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V & C64005CB.V; T.E := T.E + N; CASE C IS WHEN '1' => C64005CC (LEVEL'SUCC(L), IDENT_CHAR('1'), T); WHEN '2' => C64005CB (L, IDENT_CHAR('3'), T); WHEN '3' => C64005CC (LEVEL'SUCC(L), IDENT_CHAR('2'), T); END CASE; -- APPEND ALL L AND C TO T IN REVERSE ORDER. T.S (T.E+1 .. T.E+N) := C64005CB.L & C64005CB.C & C64005CA.L & C64005CA.C & C64005C.L; T.E := T.E + N; END C64005CB; BEGIN V (1) := IDENT_CHAR (ASCII.LC_A); V (2) := C; -- APPEND ALL V TO T. T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V; T.E := T.E + N; CASE C IS WHEN '1' => C64005CB (LEVEL'SUCC(L), IDENT_CHAR('1'), T); WHEN '2' => C64005CA (L, IDENT_CHAR('3'), T); WHEN '3' => C64005CB (LEVEL'SUCC(L), IDENT_CHAR('2'), T); END CASE; -- APPEND ALL L AND C TO T IN REVERSE ORDER. T.S (T.E+1 .. T.E+N) := C64005CA.L & C64005CA.C & C64005C.L; T.E := T.E + N; END C64005CA; BEGIN TEST ("C64005C", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " & "PARAMETERS AT ALL LEVELS OF NESTED " & "RECURSIVE PROCEDURES ARE ACCESSIBLE"); -- APPEND V TO T. T.S (T.E+1) := V; T.E := T.E + 1; C64005CA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T); -- APPEND L TO T. T.S (T.E+1) := L; T.E := T.E + 1; COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E)); COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E)); COMMENT ("GLOBAL SNAPSHOT IS: " & G); -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY. DECLARE SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A .. CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1); CT : TRACE; CG : STRING (1 .. G_LEN); BEGIN COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T_LEN)); IF T.E /= IDENT_INT (T_LEN) THEN FAILED ("WRONG FINAL CALL TRACE LENGTH"); ELSE CT.S (CT.E+1) := '<'; CT.E := CT.E + 1; FOR I IN LC_LEVEL LOOP CT.S (CT.E+1) := '<'; CT.E := CT.E + 1; FOR J IN LC_LEVEL'FIRST .. I LOOP CT.S (CT.E+1) := J; CT.S (CT.E+2) := '1'; CT.E := CT.E + 2; END LOOP; END LOOP; FOR I IN LC_LEVEL LOOP CT.S (CT.E+1) := '<'; CT.E := CT.E + 1; FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP CT.S (CT.E+1) := J; CT.S (CT.E+2) := '3'; CT.E := CT.E + 2; END LOOP; CT.S (CT.E+1) := I; CT.S (CT.E+2) := '2'; CT.E := CT.E + 2; CT.S (CT.E+1) := '<'; CT.E := CT.E + 1; FOR J IN LC_LEVEL'FIRST .. I LOOP CT.S (CT.E+1) := J; CT.S (CT.E+2) := '3'; CT.E := CT.E + 2; END LOOP; END LOOP; CT.S (CT.E+1) := '='; CT.E := CT.E + 1; FOR I IN REVERSE LEVEL LOOP FOR J IN REVERSE LEVEL'FIRST .. I LOOP CT.S (CT.E+1) := J; CT.S (CT.E+2) := '3'; CT.E := CT.E + 2; END LOOP; CT.S (CT.E+1) := '>'; CT.E := CT.E + 1; CT.S (CT.E+1) := I; CT.S (CT.E+2) := '2'; CT.E := CT.E + 2; FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP CT.S (CT.E+1) := J; CT.S (CT.E+2) := '3'; CT.E := CT.E + 2; END LOOP; CT.S (CT.E+1) := '>'; CT.E := CT.E + 1; END LOOP; FOR I IN REVERSE LEVEL LOOP FOR J IN REVERSE LEVEL'FIRST .. I LOOP CT.S (CT.E+1) := J; CT.S (CT.E+2) := '1'; CT.E := CT.E + 2; END LOOP; CT.S (CT.E+1) := '>'; CT.E := CT.E + 1; END LOOP; CT.S (CT.E+1) := '>'; CT.E := CT.E + 1; IF CT.E /= IDENT_INT (T_LEN) THEN FAILED ("WRONG ITERATIVE TRACE LENGTH"); ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S); IF T.S /= CT.S THEN FAILED ("WRONG FINAL CALL TRACE"); END IF; END IF; END IF; DECLARE E : NATURAL := 0; BEGIN CG (1..2) := "<>"; E := E + 2; FOR I IN LEVEL LOOP CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) - LEVEL'POS(LEVEL'FIRST) + LC_LEVEL'POS (LC_LEVEL'FIRST)); CG (E+2) := '3'; CG (E+3) := I; CG (E+4) := '3'; E := E + 4; END LOOP; COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG); IF G /= CG THEN FAILED ("WRONG GLOBAL SNAPSHOT"); END IF; END; END; RESULT; END C64005C;