old-autovect-branch/gcc/testsuite/ada/acats/tests/c9/c95072b.ada

   1 -- C95072B.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 PRIVATE TYPES IMPLEMENTED AS SCALAR OR ACCESS TYPES ARE
  26 -- PASSED BY COPY FOR ALL MODES.
  27 -- SUBTESTS ARE:
  28 --   (A)  PRIVATE SCALAR PARAMETERS TO ENTRIES.
  29 --   (B)  PRIVATE ACCESS PARAMETERS TO ENTRIES.
  30
  31 -- JWC 7/22/85
  32
  33 WITH REPORT; USE REPORT;
  34 PROCEDURE C95072B IS
  35
  36 BEGIN
  37      TEST("C95072B", "CHECK THAT PRIVATE SCALAR AND ACCESS " &
  38                      "PARAMETERS ARE COPIED");
  39
  40      ---------------------------------------------------
  41
  42      DECLARE  -- (A)
  43
  44           PACKAGE SCALAR_PKG IS
  45
  46                TYPE T IS PRIVATE;
  47                C0 : CONSTANT T;
  48                C1 : CONSTANT T;
  49                C10 : CONSTANT T;
  50                C100 : CONSTANT T;
  51
  52                FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T;
  53                FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER;
  54
  55           PRIVATE
  56
  57                TYPE T IS NEW INTEGER;
  58                C0 : CONSTANT T := 0;
  59                C1 : CONSTANT T := 1;
  60                C10 : CONSTANT T := 10;
  61                C100 : CONSTANT T := 100;
  62
  63           END SCALAR_PKG;
  64
  65           PACKAGE BODY SCALAR_PKG IS
  66
  67                FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T IS
  68                BEGIN
  69                     RETURN T (INTEGER(OLD) + INTEGER(INCREMENT));
  70                END "+";
  71
  72                FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER IS
  73                BEGIN
  74                     RETURN INTEGER (OLD_PRIVATE);
  75                END CONVERT;
  76
  77           END SCALAR_PKG;
  78
  79           USE SCALAR_PKG;
  80
  81      BEGIN  -- (A)
  82
  83           DECLARE  -- (A1)
  84
  85                I : T;
  86                E : EXCEPTION;
  87
  88                TASK TA IS
  89                     ENTRY EA (EI : IN T; EO : OUT T;
  90                               EIO : IN OUT T);
  91                END TA;
  92
  93                TASK BODY TA IS
  94
  95                     TEMP : T;
  96
  97                BEGIN
  98
  99                     ACCEPT EA (EI : IN T; EO : OUT T;
 100                                EIO : IN OUT T) DO
 101
 102                          TEMP := EI;    -- SAVE VALUE OF EI AT ACCEPT.
 103
 104                          EO := C10;
 105                          IF EI /= TEMP THEN
 106                               FAILED ("ASSIGNMENT TO PRIVATE " &
 107                                       "(SCALAR) OUT PARAMETER " &
 108                                       "CHANGES THE VALUE OF INPUT " &
 109                                       "PARAMETER");
 110                               TEMP := EI;   -- RESET TEMP FOR NEXT CASE.
 111                          END IF;
 112
 113                          EIO := EIO + C100;
 114                          IF EI /= TEMP THEN
 115                               FAILED ("ASSIGNMENT TO PRIVATE " &
 116                                       "(SCALAR) IN OUT PARAMETER " &
 117                                       "CHANGES THE VALUE OF INPUT " &
 118                                       "PARAMETER");
 119                               TEMP := EI;   -- RESET TEMP FOR NEXT CASE.
 120                          END IF;
 121
 122                          I := I + C1;
 123                          IF EI /= TEMP THEN
 124                               FAILED ("ASSIGNMENT TO PRIVATE " &
 125                                       "(SCALAR) ACTUAL PARAMETER " &
 126                                       "CHANGES THE VALUE OF " &
 127                                       "INPUT PARAMETER");
 128                          END IF;
 129
 130                          RAISE E;              -- CHECK EXCEPTION
 131                                                -- HANDLING.
 132                     END EA;
 133
 134                EXCEPTION
 135                     WHEN OTHERS => NULL;
 136                END TA;
 137
 138           BEGIN    -- (A1)
 139
 140                I := C0;  -- INITIALIZE I SO VARIOUS CASES CAN BE
 141                          -- DETECTED.
 142                TA.EA (I, I, I);
 143                FAILED ("EXCEPTION NOT RAISED - A");
 144
 145           EXCEPTION
 146                WHEN E =>
 147                     IF I /= C1 THEN
 148                          CASE CONVERT (I) IS
 149                               WHEN 11 =>
 150                                    FAILED ("OUT ACTUAL PRIVATE " &
 151                                            "(SCALAR) PARAMETER " &
 152                                            "CHANGED GLOBAL VALUE");
 153                               WHEN 101 =>
 154                                    FAILED ("IN OUT ACTUAL PRIVATE " &
 155                                            "(SCALAR) PARAMETER " &
 156                                            "CHANGED GLOBAL VALUE");
 157                               WHEN 111 =>
 158                                    FAILED ("OUT AND IN OUT ACTUAL " &
 159                                            "PRIVATE (SCALAR) " &
 160                                            "PARAMETER CHANGED " &
 161                                            "GLOBAL VALUE");
 162                               WHEN OTHERS =>
 163                                    FAILED ("UNDETERMINED CHANGE TO " &
 164                                            "GLOBAL VALUE");
 165                          END CASE;
 166                     END IF;
 167                WHEN OTHERS =>
 168                     FAILED ("WRONG EXCEPTION RAISED - A");
 169           END;  -- (A1)
 170
 171      END;  -- (A)
 172
 173      ---------------------------------------------------
 174
 175      DECLARE  -- (B)
 176
 177           PACKAGE ACCESS_PKG IS
 178
 179                TYPE T IS PRIVATE;
 180                C_NULL : CONSTANT T;
 181                C1 : CONSTANT T;
 182                C10 : CONSTANT T;
 183                C100 : CONSTANT T;
 184                C101 : CONSTANT T;
 185
 186           PRIVATE
 187
 188                TYPE T IS ACCESS INTEGER;
 189                C_NULL : CONSTANT T := NULL;
 190                C1 : CONSTANT T := NEW INTEGER'(1);
 191                C10 : CONSTANT T := NEW INTEGER'(10);
 192                C100 : CONSTANT T := NEW INTEGER'(100);
 193                C101 : CONSTANT T := NEW INTEGER'(101);
 194
 195           END ACCESS_PKG;
 196
 197           USE ACCESS_PKG;
 198
 199      BEGIN    -- (B)
 200
 201           DECLARE  -- (B1)
 202
 203                I : T;
 204                E : EXCEPTION;
 205
 206                TASK TB IS
 207                     ENTRY EB (EI : IN T; EO : OUT T;
 208                               EIO : IN OUT T);
 209                END TB;
 210
 211                TASK BODY TB IS
 212
 213                     TEMP : T;
 214
 215                BEGIN
 216
 217                     ACCEPT EB (EI : IN T; EO : OUT T;
 218                                EIO : IN OUT T) DO
 219
 220                          TEMP := EI;  -- SAVE VALUE OF EI AT ACCEPT.
 221
 222                          I := C101;
 223                          IF EI /= TEMP THEN
 224                               FAILED ("ASSIGNMENT TO PRIVATE " &
 225                                       "(ACCESS) ACTUAL VARIABLE " &
 226                                       "CHANGES THE VALUE OF INPUT " &
 227                                       "PARAMETER");
 228                               TEMP := EI;   -- RESET TEMP FOR NEXT CASE.
 229                          END IF;
 230
 231                          EO := C1;
 232                          IF EI /= TEMP THEN
 233                               FAILED ("ASSIGNMENT TO PRIVATE " &
 234                                       "(ACCESS) OUT PARAMETER " &
 235                                       "CHANGES THE VALUE OF INPUT " &
 236                                       "PARAMETER");
 237                               TEMP := EI;   -- RESET TEMP FOR NEXT CASE.
 238                          END IF;
 239
 240                          EIO := C10;
 241                          IF EI /= TEMP THEN
 242                               FAILED ("ASSIGNMENT TO PRIVATE " &
 243                                       "(ACCESS) IN OUT PARAMETER " &
 244                                       "CHANGES THE VALUE OF INPUT " &
 245                                       "PARAMETER");
 246                          END IF;
 247
 248                          RAISE E;                 -- CHECK EXCEPTION
 249                                                   -- HANDLING.
 250                     END EB;
 251
 252                EXCEPTION
 253                     WHEN OTHERS => NULL;
 254                END TB;
 255
 256           BEGIN     -- (B1)
 257
 258                I := C100;
 259                TB.EB (I, I, I);
 260                FAILED ("EXCEPTION NOT RAISED - B");
 261
 262           EXCEPTION
 263                WHEN E =>
 264                     IF I /= C101 THEN
 265                          FAILED ("OUT OR IN OUT ACTUAL ENTRY " &
 266                                  "PARAMETER VALUE CHANGED DESPITE " &
 267                                  "RAISED EXCEPTION");
 268                     END IF;
 269                WHEN OTHERS =>
 270                     FAILED ("WRONG EXCEPTION RAISED - B");
 271           END;  -- (B1)
 272
 273      END;  -- (B)
 274
 275      ---------------------------------------------------
 276
 277      RESULT;
 278 END C95072B;