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

   1 -- C36202C.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 'LENGTH DOES NOT RAISE AN EXCEPTION
  26 -- WHEN APPLIED TO A NULL ARRAY A, EVEN IF A'LAST - A'FIRST
  27 -- WOULD RAISE CONSTRAINT_ERROR.
  28
  29 -- *** NOTE: This test has been modified since ACVC version 1.11 to    -- 9X
  30 -- ***       remove incompatibilities associated with the transition   -- 9X
  31 -- ***       to Ada 9X.                                                -- 9X
  32
  33 -- L.BROWN  07/29/86
  34 -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
  35
  36 WITH REPORT; USE REPORT;
  37 WITH SYSTEM; USE SYSTEM;
  38
  39 PROCEDURE C36202C IS
  40
  41      TYPE LRG_INT IS RANGE MIN_INT .. MAX_INT;
  42
  43      BEGIN
  44           TEST("C36202C", "NO EXCEPTION IS RAISED FOR 'LENGTH "&
  45                           "WHEN APPLIED TO A NULL ARRAY");
  46
  47           DECLARE
  48                TYPE LRG_ARR IS ARRAY
  49                               (LRG_INT RANGE MAX_INT .. MIN_INT)
  50                                      OF INTEGER;
  51                LRG_OBJ : LRG_ARR;
  52
  53           BEGIN
  54                IF LRG_OBJ'LENGTH /= 0  THEN
  55                     FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
  56                            "FOR ONE-DIM NULL ARRAY");
  57                END IF;
  58           EXCEPTION
  59                WHEN CONSTRAINT_ERROR =>
  60                     FAILED("CONSTRAINT_ERROR WAS RAISED " &
  61                            "FOR ONE-DIM NULL ARRAY");
  62                WHEN OTHERS =>
  63                     FAILED("EXCEPTION RAISED FOR ONE-DIM " &
  64                            "NULL ARRAY");
  65           END;
  66
  67           DECLARE
  68                TYPE LRG2_ARR IS ARRAY (LRG_INT RANGE 1 .. 3 ,
  69                                 LRG_INT RANGE MAX_INT .. MIN_INT)
  70                                 OF INTEGER;
  71           BEGIN
  72                IF LRG2_ARR'LENGTH(2) /= 0  THEN
  73                     FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
  74                            "FOR TWO-DIM NULL ARRAY");
  75                END IF;
  76           EXCEPTION
  77                WHEN CONSTRAINT_ERROR =>
  78                     FAILED("CONSTRAINT_ERROR WAS RAISED " &
  79                            "FOR TWO-DIM NULL ARRAY");
  80                WHEN OTHERS =>
  81                     FAILED("EXCEPTION RAISED FOR TWO-DIM " &
  82                            "NULL ARRAY");
  83           END;
  84
  85      RESULT;
  86
  87      END C36202C;