gcc/testsuite/ada/acats/tests/c3/c35508e.ada

   1 -- C35508E.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 -- OBJECTIVE:
  26 --     CHECK THAT THE ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT
  27 --     RESULTS WHEN THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE
  28 --     ACTUAL ARGUMENT IS A BOOLEAN TYPE.
  29
  30 --     SUBTESTS ARE:
  31 --         (A). TESTS FOR IMAGE.
  32 --         (B). TESTS FOR VALUE.
  33
  34 -- HISTORY:
  35 --     RJW 03/19/86 CREATED ORIGINAL TEST.
  36 --     DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
  37
  38 WITH REPORT; USE REPORT;
  39
  40 PROCEDURE  C35508E  IS
  41
  42 BEGIN
  43
  44      TEST( "C35508E" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " &
  45                        "'VALUE' YIELD THE CORRECT RESULTS  WHEN THE " &
  46                        "PREFIX IS A GENERIC FORMAL DISCRETE TYPE " &
  47                        "WHOSE ACTUAL ARGUMENT IS A BOOLEAN TYPE" );
  48 -- PART (A).
  49
  50      DECLARE
  51           TYPE NEWBOOL IS NEW BOOLEAN;
  52
  53           GENERIC
  54                TYPE BOOL IS (<>);
  55           PROCEDURE P (B : BOOL; STR : STRING );
  56
  57           PROCEDURE P (B : BOOL; STR : STRING) IS
  58                SUBTYPE SUBBOOL IS BOOL
  59                     RANGE BOOL'VAL (IDENT_INT(0)) ..
  60                                                BOOL'VAL (IDENT_INT(0));
  61           BEGIN
  62
  63                IF BOOL'IMAGE (B) /= STR THEN
  64                     FAILED ( "INCORRECT BOOL'IMAGE OF " & STR );
  65                END IF;
  66                IF BOOL'IMAGE (B)'FIRST /= 1 THEN
  67                     FAILED ( "INCORRECT BOOL'FIRST FOR " & STR );
  68                END IF;
  69
  70                IF SUBBOOL'IMAGE (B) /= STR THEN
  71                     FAILED ( "INCORRECT SUBBOOL'IMAGE OF " & STR );
  72                END IF;
  73                IF SUBBOOL'IMAGE (B)'FIRST /= 1 THEN
  74                     FAILED ( "INCORRECT SUBBOOL'FIRST FOR " & STR );
  75                END IF;
  76           END P;
  77
  78           PROCEDURE NP1 IS NEW P ( BOOLEAN );
  79           PROCEDURE NP2 IS NEW P ( NEWBOOL );
  80      BEGIN
  81           NP1 ( TRUE, "TRUE" );
  82           NP2 ( FALSE, "FALSE" );
  83
  84      END;
  85
  86 -----------------------------------------------------------------------
  87
  88 -- PART (B).
  89
  90      DECLARE
  91           TYPE NEWBOOL IS NEW BOOLEAN;
  92
  93           GENERIC
  94                TYPE BOOL IS (<>);
  95           PROCEDURE P (STR : STRING; B : BOOL );
  96
  97           PROCEDURE P (STR : STRING; B : BOOL) IS
  98                SUBTYPE SUBBOOL IS BOOL
  99                     RANGE BOOL'VAL (IDENT_INT(0)) ..
 100                                                BOOL'VAL (IDENT_INT(0));
 101
 102           BEGIN
 103                BEGIN
 104                     IF BOOL'VALUE (STR) /= B THEN
 105                          FAILED ( "INCORRECT BOOL'VALUE OF """ &
 106                                   STR & """" );
 107                     END IF;
 108                EXCEPTION
 109                     WHEN OTHERS =>
 110                          FAILED ( "EXCEPTION RAISED BOOL'VALUE OF """ &
 111                                   STR & """" );
 112                END;
 113                BEGIN
 114                     IF SUBBOOL'VALUE (STR) /= B THEN
 115                          FAILED ( "INCORRECT SUBBOOL'VALUE OF """ &
 116                                   STR & """" );
 117                     END IF;
 118                EXCEPTION
 119                     WHEN OTHERS =>
 120                          FAILED ( "EXCEPTION RAISED SUBBOOL'VALUE " &
 121                                   "OF """ & STR & """" );
 122                END;
 123           END P;
 124
 125           PROCEDURE NP1 IS NEW P ( BOOLEAN );
 126           PROCEDURE NP2 IS NEW P ( NEWBOOL );
 127
 128      BEGIN
 129           NP1 ( "TRUE", TRUE );
 130           NP2 ( "FALSE", FALSE );
 131           NP2 ( "true", TRUE );
 132           NP1 ( "false", FALSE );
 133           NP1 ( "         TRUE", TRUE );
 134           NP2 ( "FALSE        ", FALSE );
 135      END;
 136
 137      DECLARE
 138           GENERIC
 139                TYPE BOOL IS (<>);
 140           PROCEDURE P (STR1 : STRING; B : BOOL; STR2 : STRING);
 141
 142           PROCEDURE P (STR1 : STRING; B : BOOL; STR2 : STRING) IS
 143                SUBTYPE SUBBOOL IS BOOL
 144                     RANGE BOOL'VAL (IDENT_INT(0)) ..
 145                                                 BOOL'VAL (IDENT_INT(0));
 146
 147           BEGIN
 148                BEGIN
 149                     IF BOOL'VALUE (STR1) = B THEN
 150                          FAILED ( "NO EXCEPTION RAISED - " &
 151                                   "BOOL'VALUE WITH " & STR2 &
 152                                   "- EQUAL " );
 153                     ELSE
 154                          FAILED ( "NO EXCEPTION RAISED - " &
 155                                   "BOOL'VALUE WITH " & STR2 &
 156                                   " - NOT EQUAL" );
 157                     END IF;
 158                EXCEPTION
 159                     WHEN CONSTRAINT_ERROR =>
 160                          NULL;
 161                     WHEN OTHERS =>
 162                          FAILED ( "WRONG EXCEPTION RAISED - " &
 163                                   "BOOL'VALUE WITH " & STR2 );
 164                END;
 165                BEGIN
 166                     IF SUBBOOL'VALUE (STR1) /= B THEN
 167                          FAILED ( "NO EXCEPTION RAISED - " &
 168                                   "SUBBOOL'VALUE WITH " &
 169                                   STR2 & " - EQUAL");
 170                     ELSE
 171                          FAILED ( "NO EXCEPTION RAISED - " &
 172                                   "SUBBOOL'VALUE WITH " &
 173                                   STR2 & " - NOT EQUAL");
 174                     END IF;
 175                EXCEPTION
 176                     WHEN CONSTRAINT_ERROR =>
 177                          NULL;
 178                     WHEN OTHERS =>
 179                          FAILED ( "WRONG EXCEPTION RAISED - " &
 180                                   "SUBBOOL'VALUE WITH " & STR2 );
 181                END;
 182           END P;
 183
 184           PROCEDURE NP IS NEW P ( BOOLEAN );
 185      BEGIN
 186           NP ( "MAYBE", TRUE, "NON-BOOLEAN VALUE");
 187           NP ( ASCII.HT & "TRUE", TRUE, "LEADING 'HT'" );
 188           NP ( "FALSE" & ASCII.HT , FALSE, "TRAILING 'HT'" );
 189      END;
 190
 191      RESULT;
 192 END C35508E;