llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/c6/c62003a.ada

-- C62003A.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.
--*
-- CHECK THAT SCALAR AND ACCESS PARAMETERS ARE COPIED.
--   SUBTESTS ARE:
--        (A) SCALAR PARAMETERS TO PROCEDURES.
--        (B) SCALAR PARAMETERS TO FUNCTIONS.
--        (C) ACCESS PARAMETERS TO PROCEDURES.
--        (D) ACCESS PARAMETERS TO FUNCTIONS.

-- DAS 01/14/80
-- SPS 10/26/82
-- CPP 05/25/84
-- EG  10/29/85  ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.

WITH REPORT;
PROCEDURE C62003A IS

     USE REPORT;

BEGIN
     TEST ("C62003A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " &
                      "COPIED");

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

     DECLARE  -- (A)

          I    : INTEGER;
          E    : EXCEPTION;

          PROCEDURE P (PI : IN INTEGER;  PO : OUT INTEGER;
                       PIO : IN OUT INTEGER) IS

               TMP  : INTEGER;

          BEGIN

               TMP := PI;     -- SAVE VALUE OF PI AT PROC ENTRY.

               PO := 10;
               IF (PI /= TMP) THEN
                    FAILED ("ASSIGNMENT TO SCALAR OUT " &
                            "PARAMETER CHANGES THE VALUE OF " &
                            "INPUT PARAMETER");
                    TMP := PI;     -- RESET TMP FOR NEXT CASE.
               END IF;

               PIO := PIO + 100;
               IF (PI /= TMP) THEN
                    FAILED ("ASSIGNMENT TO SCALAR IN OUT " &
                            "PARAMETER CHANGES THE VALUE OF " &
                            "INPUT PARAMETER");
                    TMP := PI;     -- RESET TMP FOR NEXT CASE.
               END IF;

               I := I + 1;
               IF (PI /= TMP) THEN
                    FAILED ("ASSIGNMENT TO SCALAR ACTUAL " &
                            "PARAMETER CHANGES THE VALUE OF " &
                            "INPUT PARAMETER");
               END IF;

               RAISE E;  -- CHECK EXCEPTION HANDLING.
          END P;

     BEGIN  -- (A)
          I := 0;   -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED.
          P (I, I, I);
          FAILED ("EXCEPTION NOT RAISED - A");
     EXCEPTION
          WHEN E =>
               IF (I /= 1) THEN
                    CASE I IS
                         WHEN 11  =>
                              FAILED ("OUT ACTUAL SCALAR PARAMETER " &
                                      "CHANGED GLOBAL VALUE");
                         WHEN 101 =>
                              FAILED ("IN OUT ACTUAL SCALAR " &
                                      "PARAMETER CHANGED GLOBAL VALUE");
                         WHEN 111 =>
                              FAILED ("OUT AND IN OUT ACTUAL SCALAR " &
                                      "PARAMETERS CHANGED GLOBAL " &
                                      "VALUE");
                         WHEN OTHERS =>
                              FAILED ("UNDETERMINED CHANGE TO GLOBAL " &
                                      "VALUE");
                    END CASE;
               END IF;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED - A");
     END;  -- (A)

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

     DECLARE  -- (B)

          I,J  : INTEGER;

          FUNCTION F (FI : IN INTEGER) RETURN INTEGER IS

               TMP  : INTEGER := FI;

          BEGIN

               I := I + 1;
               IF (FI /= TMP) THEN
                    FAILED ("ASSIGNMENT TO SCALAR ACTUAL FUNCTION " &
                            "PARAMETER CHANGES THE VALUE OF " &
                            "INPUT PARAMETER");
               END IF;

               RETURN (100);
          END F;

     BEGIN  -- (B)
          I := 100;
          J := F(I);
     END;  -- (B)

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

     DECLARE  -- (C)

          TYPE ACCTYPE IS ACCESS INTEGER;

          I    : ACCTYPE;
          E    : EXCEPTION;

          PROCEDURE P (PI : IN ACCTYPE;  PO : OUT ACCTYPE;
                       PIO : IN OUT ACCTYPE) IS

               TMP  : ACCTYPE;

          BEGIN

               TMP := PI;     -- SAVE VALUE OF PI AT PROC ENTRY.

               I := NEW INTEGER'(101);
               IF (PI /= TMP) THEN
                    FAILED ("ASSIGNMENT TO ACCESS ACTUAL " &
                            "PARAMETER CHANGES THE VALUE OF " &
                            "INPUT PARAMETER");
                    TMP := PI;     -- RESET TMP FOR NEXT CASE.
               END IF;

               PO := NEW INTEGER'(1);
               IF (PI /= TMP) THEN
                    FAILED ("ASSIGNMENT TO ACCESS OUT " &
                            "PARAMETER CHANGES THE VALUE OF " &
                            "INPUT PARAMETER");
                    TMP := PI;     -- RESET TMP FOR NEXT CASE.
               END IF;

               PIO := NEW INTEGER'(10);
               IF (PI /= TMP) THEN
                    FAILED ("ASSIGNMENT TO ACCESS IN OUT " &
                            "PARAMETER CHANGES THE VALUE OF " &
                            "INPUT PARAMETER");
               END IF;

               RAISE E;  -- CHECK EXCEPTION HANDLING.
          END P;

     BEGIN  -- (C)
          I := NEW INTEGER'(100);
          P (I, I, I);
          FAILED ("EXCEPTION NOT RAISED - C");
     EXCEPTION
          WHEN E =>
               IF (I.ALL /= 101) THEN
                    FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
                            "PARAMETER VALUE CHANGED DESPITE " &
                            "RAISED EXCEPTION");
               END IF;
          WHEN OTHERS =>
               FAILED ("WRONG EXCEPTION RAISED - C");
     END;  -- (C)

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

     DECLARE  -- (D)

          TYPE ACCTYPE IS ACCESS INTEGER;

          I,J  : ACCTYPE;

          FUNCTION F (FI : IN ACCTYPE) RETURN ACCTYPE IS

               TMP  : ACCTYPE := FI;

          BEGIN

               I := NEW INTEGER;
               IF (FI /= TMP) THEN
                    FAILED ("ASSIGNMENT TO ACCESS ACTUAL FUNCTION " &
                            "PARAMETER CHANGES THE VALUE OF " &
                            "INPUT PARAMETER");
               END IF;

               RETURN (NULL);
          END F;

     BEGIN  -- (D)
          I := NULL;
          J := F(I);
     END;  -- (D)

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

     RESULT;

END C62003A;