gcc/testsuite/ada/acats/tests/c6/c62003a.ada

   1 -- C62003A.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 SCALAR AND ACCESS PARAMETERS ARE COPIED.
  26 --   SUBTESTS ARE:
  27 --        (A) SCALAR PARAMETERS TO PROCEDURES.
  28 --        (B) SCALAR PARAMETERS TO FUNCTIONS.
  29 --        (C) ACCESS PARAMETERS TO PROCEDURES.
  30 --        (D) ACCESS PARAMETERS TO FUNCTIONS.
  31
  32 -- DAS 01/14/80
  33 -- SPS 10/26/82
  34 -- CPP 05/25/84
  35 -- EG  10/29/85  ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
  36
  37 WITH REPORT;
  38 PROCEDURE C62003A IS
  39
  40      USE REPORT;
  41
  42 BEGIN
  43      TEST ("C62003A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " &
  44                       "COPIED");
  45
  46      --------------------------------------------------
  47
  48      DECLARE  -- (A)
  49
  50           I    : INTEGER;
  51           E    : EXCEPTION;
  52
  53           PROCEDURE P (PI : IN INTEGER;  PO : OUT INTEGER;
  54                        PIO : IN OUT INTEGER) IS
  55
  56                TMP  : INTEGER;
  57
  58           BEGIN
  59
  60                TMP := PI;     -- SAVE VALUE OF PI AT PROC ENTRY.
  61
  62                PO := 10;
  63                IF (PI /= TMP) THEN
  64                     FAILED ("ASSIGNMENT TO SCALAR OUT " &
  65                             "PARAMETER CHANGES THE VALUE OF " &
  66                             "INPUT PARAMETER");
  67                     TMP := PI;     -- RESET TMP FOR NEXT CASE.
  68                END IF;
  69
  70                PIO := PIO + 100;
  71                IF (PI /= TMP) THEN
  72                     FAILED ("ASSIGNMENT TO SCALAR IN OUT " &
  73                             "PARAMETER CHANGES THE VALUE OF " &
  74                             "INPUT PARAMETER");
  75                     TMP := PI;     -- RESET TMP FOR NEXT CASE.
  76                END IF;
  77
  78                I := I + 1;
  79                IF (PI /= TMP) THEN
  80                     FAILED ("ASSIGNMENT TO SCALAR ACTUAL " &
  81                             "PARAMETER CHANGES THE VALUE OF " &
  82                             "INPUT PARAMETER");
  83                END IF;
  84
  85                RAISE E;  -- CHECK EXCEPTION HANDLING.
  86           END P;
  87
  88      BEGIN  -- (A)
  89           I := 0;   -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED.
  90           P (I, I, I);
  91           FAILED ("EXCEPTION NOT RAISED - A");
  92      EXCEPTION
  93           WHEN E =>
  94                IF (I /= 1) THEN
  95                     CASE I IS
  96                          WHEN 11  =>
  97                               FAILED ("OUT ACTUAL SCALAR PARAMETER " &
  98                                       "CHANGED GLOBAL VALUE");
  99                          WHEN 101 =>
 100                               FAILED ("IN OUT ACTUAL SCALAR " &
 101                                       "PARAMETER CHANGED GLOBAL VALUE");
 102                          WHEN 111 =>
 103                               FAILED ("OUT AND IN OUT ACTUAL SCALAR " &
 104                                       "PARAMETERS CHANGED GLOBAL " &
 105                                       "VALUE");
 106                          WHEN OTHERS =>
 107                               FAILED ("UNDETERMINED CHANGE TO GLOBAL " &
 108                                       "VALUE");
 109                     END CASE;
 110                END IF;
 111           WHEN OTHERS =>
 112                FAILED ("WRONG EXCEPTION RAISED - A");
 113      END;  -- (A)
 114
 115      --------------------------------------------------
 116
 117      DECLARE  -- (B)
 118
 119           I,J  : INTEGER;
 120
 121           FUNCTION F (FI : IN INTEGER) RETURN INTEGER IS
 122
 123                TMP  : INTEGER := FI;
 124
 125           BEGIN
 126
 127                I := I + 1;
 128                IF (FI /= TMP) THEN
 129                     FAILED ("ASSIGNMENT TO SCALAR ACTUAL FUNCTION " &
 130                             "PARAMETER CHANGES THE VALUE OF " &
 131                             "INPUT PARAMETER");
 132                END IF;
 133
 134                RETURN (100);
 135           END F;
 136
 137      BEGIN  -- (B)
 138           I := 100;
 139           J := F(I);
 140      END;  -- (B)
 141
 142      --------------------------------------------------
 143
 144      DECLARE  -- (C)
 145
 146           TYPE ACCTYPE IS ACCESS INTEGER;
 147
 148           I    : ACCTYPE;
 149           E    : EXCEPTION;
 150
 151           PROCEDURE P (PI : IN ACCTYPE;  PO : OUT ACCTYPE;
 152                        PIO : IN OUT ACCTYPE) IS
 153
 154                TMP  : ACCTYPE;
 155
 156           BEGIN
 157
 158                TMP := PI;     -- SAVE VALUE OF PI AT PROC ENTRY.
 159
 160                I := NEW INTEGER'(101);
 161                IF (PI /= TMP) THEN
 162                     FAILED ("ASSIGNMENT TO ACCESS ACTUAL " &
 163                             "PARAMETER CHANGES THE VALUE OF " &
 164                             "INPUT PARAMETER");
 165                     TMP := PI;     -- RESET TMP FOR NEXT CASE.
 166                END IF;
 167
 168                PO := NEW INTEGER'(1);
 169                IF (PI /= TMP) THEN
 170                     FAILED ("ASSIGNMENT TO ACCESS OUT " &
 171                             "PARAMETER CHANGES THE VALUE OF " &
 172                             "INPUT PARAMETER");
 173                     TMP := PI;     -- RESET TMP FOR NEXT CASE.
 174                END IF;
 175
 176                PIO := NEW INTEGER'(10);
 177                IF (PI /= TMP) THEN
 178                     FAILED ("ASSIGNMENT TO ACCESS IN OUT " &
 179                             "PARAMETER CHANGES THE VALUE OF " &
 180                             "INPUT PARAMETER");
 181                END IF;
 182
 183                RAISE E;  -- CHECK EXCEPTION HANDLING.
 184           END P;
 185
 186      BEGIN  -- (C)
 187           I := NEW INTEGER'(100);
 188           P (I, I, I);
 189           FAILED ("EXCEPTION NOT RAISED - C");
 190      EXCEPTION
 191           WHEN E =>
 192                IF (I.ALL /= 101) THEN
 193                     FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
 194                             "PARAMETER VALUE CHANGED DESPITE " &
 195                             "RAISED EXCEPTION");
 196                END IF;
 197           WHEN OTHERS =>
 198                FAILED ("WRONG EXCEPTION RAISED - C");
 199      END;  -- (C)
 200
 201      --------------------------------------------------
 202
 203      DECLARE  -- (D)
 204
 205           TYPE ACCTYPE IS ACCESS INTEGER;
 206
 207           I,J  : ACCTYPE;
 208
 209           FUNCTION F (FI : IN ACCTYPE) RETURN ACCTYPE IS
 210
 211                TMP  : ACCTYPE := FI;
 212
 213           BEGIN
 214
 215                I := NEW INTEGER;
 216                IF (FI /= TMP) THEN
 217                     FAILED ("ASSIGNMENT TO ACCESS ACTUAL FUNCTION " &
 218                             "PARAMETER CHANGES THE VALUE OF " &
 219                             "INPUT PARAMETER");
 220                END IF;
 221
 222                RETURN (NULL);
 223           END F;
 224
 225      BEGIN  -- (D)
 226           I := NULL;
 227           J := F(I);
 228      END;  -- (D)
 229
 230      --------------------------------------------------
 231
 232      RESULT;
 233
 234 END C62003A;