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

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