c35507e.ada

来自「Mac OS X 10.4.9 for x86 Source Code gcc」· ADA 代码 · 共 195 行

-- C35507E.ADA

--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
--     CHECK THAT THE ATTRIBUTES 'IMAGE' AND 'VALUE YIELD THE CORRECT
--     RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL
--     PARAMETER IS A CHARACTER TYPE.
--     SUBTESTS ARE:
--         (A). TESTS FOR IMAGE.
--         (B). TESTS FOR VALUE.

-- HISTORY:
--     RJW  05/29/86  CREATED ORIGINAL TEST.
--     VCL  10/23/87  MODIFIED THIS HEADER, CHANGED THE CALLS TO
--                    PROCEDURE 'PCH', IN THE SECOND PART OF SUBTEST B,
--                    TO INCLUDE ANOTHER CALL TO PROCEDURE 'PCHAR' AND
--                    CALLS TO PROCEDURE 'PNCHAR'.

WITH REPORT; USE REPORT;
PROCEDURE  C35507E  IS

     TYPE CHAR IS ('A', 'a');

     TYPE NEWCHAR IS NEW CHAR;

     PROCEDURE CHECK_LOWER_BOUND (STR1, STR2 : STRING) IS
     BEGIN
          IF STR1'FIRST /= 1 THEN
               FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 & "'(" &
                        STR1 & ")" );
          END IF;
     END CHECK_LOWER_BOUND;

BEGIN

     TEST( "C35507E" , "THE ATTRIBUTES 'IMAGE' AND " &
                       "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " &
                       "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
                       "ACTUAL PARAMETER IS A CHARACTER TYPE" );

     DECLARE -- (A).
          GENERIC
               TYPE CHTYPE IS (<>);
               STR1 : STRING;
          PROCEDURE P (CH : CHTYPE; STR2 : STRING);

          PROCEDURE P (CH : CHTYPE; STR2 : STRING) IS
               SUBTYPE SUBCH IS CHTYPE;
          BEGIN
               IF SUBCH'IMAGE (CH) /= STR2 THEN
                    FAILED ( "INCORRECT IMAGE FOR " & STR1 & "'(" &
                              STR2 & ")" );
               END IF;

               CHECK_LOWER_BOUND (SUBCH'IMAGE (CH), STR1);
          END P;

          PROCEDURE PCHAR  IS NEW P (CHAR, "CHAR");
          PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR");
          PROCEDURE PCH    IS NEW P (CHARACTER, "CHARACTER");

     BEGIN
          PCHAR ('A', "'A'");
          PCHAR ('a', "'a'");
          PNCHAR ('A', "'A'");
          PNCHAR ('a', "'a'");

          FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP
               PCH (CH, ("'" & CH) & "'" );
          END LOOP;
     END;

     DECLARE

          GENERIC
               TYPE CHTYPE IS (<>);
          PROCEDURE P (CH : CHTYPE; STR : STRING);

          PROCEDURE P (CH : CHTYPE; STR : STRING) IS
               SUBTYPE SUBCH IS CHTYPE;
          BEGIN
               CHECK_LOWER_BOUND (CHTYPE'IMAGE (CH), "CHARACTER");
          END P;

          PROCEDURE PN IS NEW P (CHARACTER);

     BEGIN

          FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP
               PN (CH, CHARACTER'IMAGE (CH));
          END LOOP;

          PN (ASCII.DEL, CHARACTER'IMAGE (ASCII.DEL));
     END;

     ---------------------------------------------------------------

     DECLARE -- (B).

          GENERIC
               TYPE CHTYPE IS (<>);
               STR1 : STRING;
          PROCEDURE P (STR2 : STRING; CH : CHTYPE);

          PROCEDURE P (STR2 : STRING; CH : CHTYPE) IS
               SUBTYPE SUBCH IS CHTYPE;
          BEGIN
               IF SUBCH'VALUE (STR2) /= CH THEN
                    FAILED ( "INCORRECT " & STR1 & "'VALUE FOR " &
                              STR2 );
               END IF;
          END P;

          PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER");
          PROCEDURE PCHAR IS NEW P (CHAR, "CHAR");
          PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR");

     BEGIN
          FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP
                PCH (CHARACTER'IMAGE (CH), CH );
          END LOOP;

          PCH (CHARACTER'IMAGE (CHARACTER'VAL (127)),
               CHARACTER'VAL (127));

          PCHAR ("'A'", 'A');
          PCHAR ("'a'", 'a' );
          PNCHAR ("'A'", 'A');
          PNCHAR ("'a'", 'a');
     END;

     DECLARE
          GENERIC
               TYPE CHTYPE IS (<>);
               STR1 : STRING;
          PROCEDURE P (STR2 : STRING);

          PROCEDURE P (STR2 : STRING) IS
               SUBTYPE SUBCH IS CHTYPE;
          BEGIN
               IF SUBCH'VALUE (STR2) = SUBCH'VAL (0) THEN
                    FAILED ( "NO EXCEPTION RAISED FOR " &
                              STR1 & "'VALUE (" & STR2 & ") - 1" );
               ELSE
                    FAILED ( "NO EXCEPTION RAISED FOR " &
                              STR1 & "'VALUE (" & STR2 & ") - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED " &
                             "FOR " & STR1 & "'VALUE (" & STR2 & ")" );
          END P;

          PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER");
          PROCEDURE PCHAR IS NEW P (CHAR, "CHAR");
          PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR");

     BEGIN
          PCHAR ("'B'");
          PCH (ASCII.HT & "'A'");
          PCH ("'B'" & ASCII.HT);
          PCH ("'C'" & ASCII.BEL);
          PCH ("'");
          PNCHAR ("''");
          PCHAR ("'A");
          PNCHAR ("A'");
          PCH ("'AB'");
     END;

     RESULT;
END C35507E;