gcc/testsuite/ada/acats/tests/cc/cc1301a.ada

   1 -- CC1301A.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 DEFAULT GENERIC SUBPROGRAM PARAMETERS WORK CORRECTLY,
  26 -- INCLUDING OVERLOADED AND PREDEFINED OPERATOR_SYMBOLS,
  27 -- AND SUBPROGRAMS HIDDEN AT THE INSTANTIATION.
  28 -- BOTH KINDS OF DEFAULTS ARE TESTED, FOR BOTH PROCEDURES
  29 -- AND FUNCTIONS.
  30
  31 -- DAT 8/14/81
  32 -- JBG 5/5/83
  33 -- JBG 8/3/83
  34
  35 WITH REPORT; USE REPORT;
  36
  37 PROCEDURE CC1301A IS
  38
  39      FUNCTION "-" (R, S : INTEGER) RETURN INTEGER;
  40
  41      FUNCTION NEXT (X : INTEGER) RETURN INTEGER;
  42
  43      PROCEDURE BUMP (X : IN OUT INTEGER);
  44
  45      GENERIC
  46           WITH FUNCTION "*" (A, B : INTEGER) RETURN INTEGER IS "-";
  47           WITH FUNCTION "+" (R, S: INTEGER) RETURN INTEGER IS
  48                                                        STANDARD."+";
  49           WITH FUNCTION "-" (A, B : INTEGER) RETURN INTEGER IS <> ;
  50           WITH FUNCTION NEXTO (Q : INTEGER) RETURN INTEGER IS NEXT ;
  51           WITH PROCEDURE BUMPO (A : IN OUT INTEGER) IS BUMP;
  52           WITH FUNCTION NEXT (Q : INTEGER) RETURN INTEGER  IS <> ;
  53           WITH PROCEDURE BUMP (Q : IN OUT INTEGER) IS <> ;
  54           TYPE INTEGER IS RANGE <> ;
  55           WITH FUNCTION "*" (A , B : INTEGER) RETURN INTEGER IS <> ;
  56           WITH FUNCTION "-" (A, B : INTEGER) RETURN INTEGER IS <> ;
  57           WITH FUNCTION NEXT (Q : INTEGER) RETURN INTEGER IS <> ;
  58           WITH PROCEDURE BUMP (Z : IN OUT INTEGER) IS <> ;
  59      PACKAGE PKG IS
  60           SUBTYPE INT IS STANDARD.INTEGER;
  61           DIFF : INT := -999;
  62      END PKG;
  63
  64      TYPE NEWINT IS NEW INTEGER RANGE -1000 .. 1000;
  65
  66      FUNCTION PLUS (Q1, Q2 : INTEGER) RETURN INTEGER RENAMES "+";
  67
  68      FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER IS
  69      BEGIN
  70           RETURN PLUS (X, PLUS (Y, -10));
  71           -- (X + Y - 10)
  72      END "+";
  73
  74      FUNCTION "-" (R, S : INTEGER) RETURN INTEGER IS
  75      BEGIN
  76           RETURN - R + S;
  77           -- (-R + S - 10)
  78      END "-";
  79
  80      FUNCTION NEXT (X : INTEGER) RETURN INTEGER IS
  81      BEGIN
  82           RETURN X + 1;
  83           -- (X + 1 - 10)
  84           -- (X - 9)
  85      END NEXT;
  86
  87      PROCEDURE BUMP (X : IN OUT INTEGER) IS
  88      BEGIN
  89           X := NEXT (X);
  90           -- (X := X - 9)
  91      END BUMP;
  92
  93      PACKAGE BODY PKG IS
  94           W : INTEGER;
  95           WI : INT;
  96      BEGIN
  97           W := NEXT (INTEGER'(3) * 4 - 2);
  98           -- (W := (4 ** 3 - 2) - 1)
  99           -- (W := 61)
 100           BUMP (W);
 101           -- (W := 61 + 7)
 102           -- (W := 68)
 103           WI := NEXT (INT'(3) * 4 - 2 + NEXTO (0));
 104           -- (3 * 4) => (3 - 4) => (-3 + 4 - 10) = -9
 105           -- ((-9) - 2) => (2 + 2 - (-9) - 20) = -7
 106           -- (-7 + (-9)) => -16
 107           -- (WI := 7 - (-16)) => (WI := 23)
 108           BUMPO (WI);
 109           -- (WI := 23 - 9) (= 14)
 110           BUMP (WI);
 111           -- (WI := 14 - 9) (= 5)
 112           DIFF := STANDARD."-" (INT(W), WI);
 113           -- (DIFF := 68 - 5) (= 63)
 114      END PKG;
 115
 116      FUNCTION "*" (Y, X : NEWINT) RETURN NEWINT IS
 117      BEGIN
 118           RETURN X ** INTEGER(Y);
 119           -- (X,Y) (Y ** X)
 120      END "*";
 121
 122      FUNCTION NEXT (Z : NEWINT) RETURN NEWINT IS
 123      BEGIN
 124           RETURN Z - 1;
 125           -- (Z - 1)
 126      END NEXT;
 127
 128      PROCEDURE BUMP (ZZ : IN OUT NEWINT) IS
 129      BEGIN
 130           FAILED ("WRONG PROCEDURE CALLED");
 131      END BUMP;
 132 BEGIN
 133      TEST ("CC1301A", "DEFAULT GENERIC SUBPROGRAM PARAMETERS");
 134
 135      DECLARE
 136           PROCEDURE BUMP (QQQ : IN OUT NEWINT) IS
 137           BEGIN
 138                QQQ := QQQ + 7;
 139                -- (QQQ + 7)
 140           END BUMP;
 141
 142           FUNCTION NEXT (Q7 : INTEGER) RETURN INTEGER IS
 143           BEGIN
 144                RETURN Q7 - 17;
 145                -- (-Q7 + 17 - 10)
 146                -- (7 - Q7)
 147           END NEXT;
 148
 149           FUNCTION "-" (Q3, Q4 : INTEGER) RETURN INTEGER IS
 150           BEGIN
 151                RETURN -Q3 + Q4 + Q4;
 152                -- (-Q3 + Q4 - 10 + Q4 - 10) = (Q4 + Q4 - Q3 - 20)
 153           END "-";
 154
 155           PACKAGE P1 IS NEW PKG (INTEGER => NEWINT);
 156
 157      BEGIN
 158           IF P1.DIFF /= 63 THEN
 159                FAILED ("WRONG DEFAULT SUBPROGRAM PARAMETERS");
 160           END IF;
 161      END;
 162
 163      RESULT;
 164 END CC1301A;