c64005c.ada

用于进行gcc测试

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