old-autovect-branch/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada

   1 -- C64005D0M.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 -- CHECK THAT NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT
  26 -- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM
  27 -- WITHIN RECURSIVE INVOCATIONS.  THIS TEST CHECKS THAT EVERY DISPLAY OR
  28 -- STATIC CHAIN LEVEL CAN BE ACCESSED.
  29
  30 -- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES (SEPARATELY
  31 -- COMPILED AS SUBUNITS).
  32
  33 -- SEPARATE FILES ARE:
  34 --   C64005D0M THE MAIN PROCEDURE.
  35 --   C64005DA  A RECURSIVE PROCEDURE SUBUNIT OF C64005D0M.
  36 --   C64005DB  A RECURSIVE PROCEDURE SUBUNIT OF C64005DA.
  37 --   C64005DC  A RECURSIVE PROCEDURE SUBUNIT OF C64005DB.
  38
  39 -- JRK 7/30/84
  40
  41 WITH REPORT; USE REPORT;
  42
  43 PROCEDURE C64005D0M IS
  44
  45      SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C';
  46      SUBTYPE CALL IS CHARACTER RANGE '1' .. '3';
  47
  48      MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) -
  49                            LEVEL'POS (LEVEL'FIRST) + 1;
  50      T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV +
  51                                        MAX_LEV*(MAX_LEV+1)/2*2)) + 1;
  52      G_LEN : CONSTANT := 2 + 4 * MAX_LEV;
  53
  54      TYPE TRACE IS
  55           RECORD
  56                E : NATURAL := 0;
  57                S : STRING (1 .. T_LEN);
  58           END RECORD;
  59
  60      V : CHARACTER := IDENT_CHAR ('<');
  61      L : CHARACTER := IDENT_CHAR ('>');
  62      T : TRACE;
  63      G : STRING (1 .. G_LEN);
  64
  65      PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
  66           SEPARATE;
  67
  68 BEGIN
  69      TEST ("C64005D", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " &
  70                       "PARAMETERS AT ALL LEVELS OF NESTED " &
  71                       "RECURSIVE PROCEDURES ARE ACCESSIBLE (FOR " &
  72                       "3 LEVELS OF SEPARATELY COMPILED SUBUNITS)");
  73
  74      -- APPEND V TO T.
  75      T.S (T.E+1) := V;
  76      T.E := T.E + 1;
  77
  78      C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T);
  79
  80      -- APPEND L TO T.
  81      T.S (T.E+1) := L;
  82      T.E := T.E + 1;
  83
  84      COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E));
  85      COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E));
  86      COMMENT ("GLOBAL SNAPSHOT IS: " & G);
  87
  88      -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY.
  89
  90      DECLARE
  91           SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A ..
  92                CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1);
  93
  94           CT : TRACE;
  95           CG : STRING (1 .. G_LEN);
  96      BEGIN
  97           COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " &
  98                    INTEGER'IMAGE(T_LEN));
  99
 100           IF T.E /= IDENT_INT (T_LEN) THEN
 101                FAILED ("WRONG FINAL CALL TRACE LENGTH");
 102
 103           ELSE CT.S (CT.E+1) := '<';
 104                CT.E := CT.E + 1;
 105
 106                FOR I IN LC_LEVEL LOOP
 107                     CT.S (CT.E+1) := '<';
 108                     CT.E := CT.E + 1;
 109
 110                     FOR J IN LC_LEVEL'FIRST .. I LOOP
 111                          CT.S (CT.E+1) := J;
 112                          CT.S (CT.E+2) := '1';
 113                          CT.E := CT.E + 2;
 114                     END LOOP;
 115                END LOOP;
 116
 117                FOR I IN LC_LEVEL LOOP
 118                     CT.S (CT.E+1) := '<';
 119                     CT.E := CT.E + 1;
 120
 121                     FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP
 122                          CT.S (CT.E+1) := J;
 123                          CT.S (CT.E+2) := '3';
 124                          CT.E := CT.E + 2;
 125                     END LOOP;
 126
 127                     CT.S (CT.E+1) := I;
 128                     CT.S (CT.E+2) := '2';
 129                     CT.E := CT.E + 2;
 130
 131                     CT.S (CT.E+1) := '<';
 132                     CT.E := CT.E + 1;
 133
 134                     FOR J IN LC_LEVEL'FIRST .. I LOOP
 135                          CT.S (CT.E+1) := J;
 136                          CT.S (CT.E+2) := '3';
 137                          CT.E := CT.E + 2;
 138                     END LOOP;
 139                END LOOP;
 140
 141                CT.S (CT.E+1) := '=';
 142                CT.E := CT.E + 1;
 143
 144                FOR I IN REVERSE LEVEL LOOP
 145                     FOR J IN REVERSE LEVEL'FIRST .. I LOOP
 146                          CT.S (CT.E+1) := J;
 147                          CT.S (CT.E+2) := '3';
 148                          CT.E := CT.E + 2;
 149                     END LOOP;
 150
 151                     CT.S (CT.E+1) := '>';
 152                     CT.E := CT.E + 1;
 153
 154                     CT.S (CT.E+1) := I;
 155                     CT.S (CT.E+2) := '2';
 156                     CT.E := CT.E + 2;
 157
 158                     FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP
 159                          CT.S (CT.E+1) := J;
 160                          CT.S (CT.E+2) := '3';
 161                          CT.E := CT.E + 2;
 162                     END LOOP;
 163
 164                     CT.S (CT.E+1) := '>';
 165                     CT.E := CT.E + 1;
 166                END LOOP;
 167
 168                FOR I IN REVERSE LEVEL LOOP
 169                     FOR J IN REVERSE LEVEL'FIRST .. I LOOP
 170                          CT.S (CT.E+1) := J;
 171                          CT.S (CT.E+2) := '1';
 172                          CT.E := CT.E + 2;
 173                     END LOOP;
 174
 175                     CT.S (CT.E+1) := '>';
 176                     CT.E := CT.E + 1;
 177                END LOOP;
 178
 179                CT.S (CT.E+1) := '>';
 180                CT.E := CT.E + 1;
 181
 182                IF CT.E /= IDENT_INT (T_LEN) THEN
 183                     FAILED ("WRONG ITERATIVE TRACE LENGTH");
 184
 185                ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S);
 186
 187                     IF T.S /= CT.S THEN
 188                          FAILED ("WRONG FINAL CALL TRACE");
 189                     END IF;
 190                END IF;
 191           END IF;
 192
 193           DECLARE
 194                E : NATURAL := 0;
 195           BEGIN
 196                CG (1..2) := "<>";
 197                E := E + 2;
 198
 199                FOR I IN LEVEL LOOP
 200                     CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) -
 201                                               LEVEL'POS(LEVEL'FIRST) +
 202                                               LC_LEVEL'POS
 203                                                       (LC_LEVEL'FIRST));
 204                     CG (E+2) := '3';
 205                     CG (E+3) := I;
 206                     CG (E+4) := '3';
 207                     E := E + 4;
 208                END LOOP;
 209
 210                COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG);
 211
 212                IF G /= CG THEN
 213                     FAILED ("WRONG GLOBAL SNAPSHOT");
 214                END IF;
 215           END;
 216      END;
 217
 218      RESULT;
 219 END C64005D0M;