gcc/testsuite/ada/acats/tests/c9/c95089a.ada

   1 -- C95089A.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 ALL PERMITTED FORMS OF VARIABLE NAMES ARE PERMITTED
  26 -- AS ACTUAL PARAMETERS.
  27
  28 -- GLH 7/25/85
  29
  30 WITH REPORT; USE REPORT;
  31 PROCEDURE C95089A IS
  32
  33      SUBTYPE INT IS INTEGER RANGE 1..3;
  34
  35      TYPE REC (N : INT) IS
  36           RECORD
  37                S : STRING (1..N);
  38           END RECORD;
  39
  40      TYPE PTRSTR IS ACCESS STRING;
  41
  42      R1, R2, R3 : REC (3);
  43      S1, S2, S3 : STRING (1..3);
  44      PTRTBL     : ARRAY (1..3) OF PTRSTR;
  45
  46      TASK T1 IS
  47           ENTRY E1 (S1 : IN STRING; S2: IN OUT STRING;
  48                     S3 : OUT STRING);
  49      END T1;
  50
  51      TASK BODY T1 IS
  52      BEGIN
  53           LOOP
  54                SELECT
  55                     ACCEPT E1 (S1 : IN STRING; S2: IN OUT STRING;
  56                                S3 : OUT STRING) DO
  57                          S3 := S2;
  58                          S2 := S1;
  59                     END E1;
  60                OR
  61                     TERMINATE;
  62                END SELECT;
  63           END LOOP;
  64      END T1;
  65
  66      TASK T2 IS
  67           ENTRY E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER;
  68                     C3 : OUT CHARACTER);
  69      END T2;
  70
  71      TASK BODY T2 IS
  72      BEGIN
  73           LOOP
  74                SELECT
  75                     ACCEPT E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER;
  76                                C3 : OUT CHARACTER) DO
  77                          C3 := C2;
  78                          C2 := C1;
  79                     END E2;
  80                OR
  81                     TERMINATE;
  82                END SELECT;
  83           END LOOP;
  84      END T2;
  85
  86      FUNCTION F1 (X : INT) RETURN PTRSTR IS
  87      BEGIN
  88           RETURN PTRTBL (X);
  89      END F1;
  90
  91      FUNCTION "+" (S1, S2 : STRING) RETURN PTRSTR IS
  92      BEGIN
  93           RETURN PTRTBL (CHARACTER'POS(S1(1))-CHARACTER'POS('A')+1);
  94      END "+";
  95
  96 BEGIN
  97
  98      TEST ("C95089A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE " &
  99                       "NAMES ARE PERMITTED AS ACTUAL PARAMETERS");
 100
 101      S1 := "AAA";
 102      S2 := "BBB";
 103      T1.E1 (S1, S2, S3);
 104      IF S2 /= "AAA" OR S3 /= "BBB" THEN
 105           FAILED ("SIMPLE VARIABLE AS AN ACTUAL PARAMETER NOT WORKING");
 106      END IF;
 107
 108      S1 := "AAA";
 109      S2 := "BBB";
 110      S3 := IDENT_STR ("CCC");
 111      T2.E2 (S1(1), S2(IDENT_INT(1)), S3(1));
 112      IF S2 /= "ABB" OR S3 /= "BCC" THEN
 113           FAILED ("INDEXED COMPONENT AS AN ACTUAL PARAMETER NOT " &
 114                   "WORKING");
 115      END IF;
 116
 117      R1.S := "AAA";
 118      R2.S := "BBB";
 119      T1.E1 (R1.S, R2.S, R3.S);
 120      IF R2.S /= "AAA" OR R3.S /= "BBB" THEN
 121           FAILED ("SELECTED COMPONENT AS AN ACTUAL PARAMETER " &
 122                   "NOT WORKING");
 123      END IF;
 124
 125      S1 := "AAA";
 126      S2 := "BBB";
 127      T1.E1 (S1(1..IDENT_INT(2)), S2(1..2),
 128             S3(IDENT_INT(1)..IDENT_INT(2)));
 129      IF S2 /= "AAB" OR S3 /= "BBC" THEN
 130           FAILED ("SLICE AS AN ACTUAL PARAMETER NOT WORKING");
 131      END IF;
 132
 133      PTRTBL(1) := NEW STRING'("AAA");
 134      PTRTBL(2) := NEW STRING'("BBB");
 135      PTRTBL(3) := NEW STRING'("CCC");
 136      T1.E1 (F1(1).ALL, F1(2).ALL, F1(IDENT_INT(3)).ALL);
 137      IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN
 138           FAILED ("SELECTED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " &
 139                   "PARAMETER NOT WORKING");
 140      END IF;
 141
 142      PTRTBL(1) := NEW STRING'("AAA");
 143      PTRTBL(2) := NEW STRING'("BBB");
 144      PTRTBL(3) := NEW STRING'("CCC");
 145      S1 := IDENT_STR("AAA");
 146      S2 := IDENT_STR("BBB");
 147      S3 := IDENT_STR("CCC");
 148      T1.E1 ("+"(S1,S1).ALL, "+"(S2,S2).ALL, "+"(S3,S3).ALL);
 149      IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN
 150           FAILED ("SELECTED COMPONENT OF OVERLOADED OPERATOR " &
 151                   "FUNCTION VALUE AS AN ACTUAL PARAMETER NOT WORKING");
 152      END IF;
 153
 154      PTRTBL(1) := NEW STRING'("AAA");
 155      PTRTBL(2) := NEW STRING'("BBB");
 156      PTRTBL(3) := NEW STRING'("CCC");
 157      T2.E2 (F1(1)(1), F1(IDENT_INT(2))(1), F1(3)(IDENT_INT(1)));
 158      IF PTRTBL(2).ALL /= "ABB" OR PTRTBL(3).ALL /= "BCC" THEN
 159           FAILED ("INDEXED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " &
 160                   "PARAMETER NOT WORKING");
 161      END IF;
 162
 163      PTRTBL(1) := NEW STRING'("AAA");
 164      PTRTBL(2) := NEW STRING'("BBB");
 165      PTRTBL(3) := NEW STRING'("CCC");
 166      T1.E1 (F1(1)(2..3), F1(2)(IDENT_INT(2)..3),
 167             F1(3)(2..IDENT_INT(3)));
 168      IF PTRTBL(2).ALL /= "BAA" OR PTRTBL(3).ALL /= "CBB" THEN
 169           FAILED ("SLICE OF FUNCTION VALUE AS AN ACTUAL PARAMETER " &
 170                   "NOT WORKING");
 171      END IF;
 172
 173      RESULT;
 174
 175 END C95089A;