old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c39006d.ada

   1 -- C39006D.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 IF A FUNCTION IS USED IN A DEFAULT EXPRESSION FOR A
  26 -- SUBPROGRAM OR FORMAL GENERIC PARAMETER, PROGRAM_ERROR IS RAISED
  27 -- WHEN AN ATTEMPT IS MADE TO EVALUATE THE DEFAULT EXPRESSION,
  28 -- BECAUSE THE FUNCTION'S BODY HAS NOT BEEN ELABORATED YET.
  29
  30 -- TBN  8/20/86
  31
  32 WITH REPORT; USE REPORT;
  33 PROCEDURE C39006D IS
  34
  35 BEGIN
  36      TEST ("C39006D", "CHECK THAT IF A FUNCTION IS USED IN A DEFAULT " &
  37                       "EXPRESSION FOR A SUBPROGRAM OR FORMAL GENERIC " &
  38                       "PARAMETER, PROGRAM_ERROR IS RAISED WHEN AN " &
  39                       "ATTEMPT IS MADE TO EVALUATE THE DEFAULT " &
  40                       "EXPRESSION");
  41      DECLARE
  42           FUNCTION FUN RETURN INTEGER;
  43
  44           PACKAGE P IS
  45                PROCEDURE DEFAULT (A : INTEGER := FUN);
  46           END P;
  47
  48           PACKAGE BODY P IS
  49                PROCEDURE DEFAULT (A : INTEGER := FUN) IS
  50                     B : INTEGER := 1;
  51                BEGIN
  52                     B := B + IDENT_INT(A);
  53                END DEFAULT;
  54           BEGIN
  55                DEFAULT (2);
  56                DEFAULT;
  57                FAILED ("PROGRAM_ERROR NOT RAISED - 1");
  58           EXCEPTION
  59                WHEN PROGRAM_ERROR =>
  60                     NULL;
  61                WHEN OTHERS =>
  62                     FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
  63           END P;
  64
  65           FUNCTION FUN RETURN INTEGER IS
  66           BEGIN
  67                RETURN (IDENT_INT(1));
  68           END FUN;
  69      BEGIN
  70           NULL;
  71      END;
  72
  73      BEGIN
  74           DECLARE
  75                FUNCTION INIT_1 RETURN INTEGER;
  76
  77                GENERIC
  78                     LENGTH : INTEGER := INIT_1;
  79                PACKAGE P IS
  80                     TYPE ARRAY1 IS ARRAY (1 .. LENGTH) OF INTEGER;
  81                END P;
  82
  83                PACKAGE NEW_P1 IS NEW P (4);
  84                PACKAGE NEW_P2 IS NEW P;
  85
  86                FUNCTION INIT_1 RETURN INTEGER IS
  87                BEGIN
  88                     RETURN (IDENT_INT(2));
  89                END INIT_1;
  90
  91           BEGIN
  92                FAILED ("PROGRAM_ERROR NOT RAISED - 2");
  93           END;
  94      EXCEPTION
  95           WHEN PROGRAM_ERROR =>
  96                NULL;
  97           WHEN OTHERS =>
  98                FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
  99      END;
 100
 101      DECLARE
 102           FUNCTION INIT_2 RETURN INTEGER;
 103
 104           GLOBAL_INT : INTEGER := IDENT_INT(1);
 105
 106           GENERIC
 107           PACKAGE Q IS
 108                PROCEDURE ADD1 (A : INTEGER := INIT_2);
 109           END Q;
 110
 111           PACKAGE BODY Q IS
 112                PROCEDURE ADD1 (A : INTEGER := INIT_2) IS
 113                     B : INTEGER;
 114                BEGIN
 115                     B := A;
 116                END ADD1;
 117           BEGIN
 118                IF GLOBAL_INT = IDENT_INT(1) THEN
 119                     ADD1;
 120                     FAILED ("PROGRAM_ERROR NOT RAISED - 3");
 121                ELSE
 122                     ADD1 (2);
 123                END IF;
 124
 125           EXCEPTION
 126                WHEN PROGRAM_ERROR =>
 127                     NULL;
 128                WHEN OTHERS =>
 129                     FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
 130           END Q;
 131
 132           PACKAGE NEW_Q IS NEW Q;
 133
 134           FUNCTION INIT_2 RETURN INTEGER IS
 135           BEGIN
 136                RETURN (IDENT_INT(1));
 137           END INIT_2;
 138
 139      BEGIN
 140           NULL;
 141      END;
 142
 143      RESULT;
 144 END C39006D;