Subversion Repositories openrisc_me

-- C37207A.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:

--     FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK

--     THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING

--     CONTEXTS AND HAS THE PROPER EFFECT:

--     IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR

--     3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE,

--     ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT

--     VALUES WITHOUT RAISING CONSTRAINT_ERROR

--     4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES

--     OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES

--     DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES.

--     5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED

--     DISCRIMINANT VALUES.

--     6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND

--     HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO

--     CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR,

--     CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT

--     VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS

--     RAISED.

-- HISTORY:

--     ASL 07/24/81

--     RJW 08/28/86  CORRECTED SYNTAX ERRORS.

--     JLH 08/07/87  ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION.

--     EDS 07/16/98  AVOID OPTIMIZATION

WITH REPORT; USE REPORT;

PROCEDURE C37207A IS

BEGIN

     TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " &

          "DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " &

          "DEFAULT DISCRIMINANT VALUES");

     DECLARE

          TYPE REC1 (DISC : INTEGER := 5) IS

               RECORD

                    NULL;

               END RECORD;

          TYPE REC2 (DISC : INTEGER) IS

               RECORD

                    NULL;

                END RECORD;

          OBJ1 : REC1(6);                     -- 1.

          OBJ2 : REC2(6);                     -- 1.

          BADOBJ1 : REC1(7);                  -- 1.

          BADOBJ2 : REC2(7);                  -- 1.

          TYPE REC3 IS

               RECORD

                    COMP1 : REC1(6);          -- 2.

                    COMP2 : REC2(6);          -- 2.

               END RECORD;

          OBJ3 : REC3;

          TYPE ARR1 IS ARRAY (1..10) OF REC1(6);  -- 3.

          TYPE ARR2 IS ARRAY (1..10) OF REC2(6);  -- 3.

          A1 : ARR1;

          A2 : ARR2;

          TYPE REC1_NAME IS ACCESS REC1(6);   -- 4.

          TYPE REC2_NAME IS ACCESS REC2(6);   -- 4.

          ACC1 : REC1_NAME;

          ACC2 : REC2_NAME;

          SUBTYPE REC16 IS REC1(6);

          SUBTYPE REC26 IS REC2(6);

          PROCEDURE PROC (P1 : IN OUT REC16;     -- 6.

                         P2 : IN OUT REC26) IS  -- 6.

          BEGIN

               IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN  -- 6.

                    FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " &

                            "CONSTRAINED FORMAL PARAMETERS");

               END IF;

               BEGIN

                    P1 := (DISC => 7);         -- 6.

                    FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &

                            "ATTEMPT TO CHANGE DISCRIMINANT OF " &

                            "CONSTRAINED FORMAL PARAMETER " &

                            INTEGER'IMAGE(P1.DISC));

               EXCEPTION

                    WHEN CONSTRAINT_ERROR => NULL;

                    WHEN OTHERS => FAILED ("WRONG EXCEPTION     (1)");

               END;

               BEGIN

                    P2 := (DISC => 7);         -- 6.

                    FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &

                            "ATTEMPT TO CHANGE DISCRIMINANT OF " &

                            "CONSTRAINED FORMAL PARAMETER " &

                            INTEGER'IMAGE(P2.DISC));

               EXCEPTION

                    WHEN CONSTRAINT_ERROR => NULL;

                    WHEN OTHERS => FAILED ("WRONG EXCEPTION     (2)");

               END;

          END PROC;

     BEGIN

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

          BEGIN

               OBJ1 := (DISC => IDENT_INT(7));           -- 1.

               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &

                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &

                       "CONSTRAINED OBJECT");

               IF OBJ1 = (DISC => 7) THEN

                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");

               END IF;

          EXCEPTION

               WHEN CONSTRAINT_ERROR => NULL;

               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (3)");

          END;

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

          BEGIN

               OBJ3 := ((DISC => IDENT_INT(7)),      -- 2.

                        (DISC => IDENT_INT(7)));     -- 2.

               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &

                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &

                       "CONSTRAINED RECORD COMPONENT");

               IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN

                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");

               END IF;

          EXCEPTION

               WHEN CONSTRAINT_ERROR => NULL;

               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (4)");

          END;

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

          BEGIN

               A2(2) := (DISC => IDENT_INT(7));          -- 3.

               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &

                       "ATTEMPT TO CHANGE DISCRIMINANT OF " &

                       "CONSTRAINED ARRAY COMPONENT");

               IF A2(2) = (DISC => 7) THEN

                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");

               END IF;

          EXCEPTION

               WHEN CONSTRAINT_ERROR => NULL;

               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (5)");

          END;

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

          BEGIN

               ACC1 := NEW REC1(DISC => IDENT_INT(7));   -- 4.

               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &

                       "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &

                       "TO ACCESS VARIABLE");

               IF ACC1 =  NEW REC1(DISC => 7) THEN

                    COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");

               END IF;

         EXCEPTION

               WHEN CONSTRAINT_ERROR => NULL;

               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (6)");

          END;

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

               ACC1 := NEW REC1(DISC => IDENT_INT(6));  -- OK.

          BEGIN

               ACC1.ALL := BADOBJ1;           -- 5.

               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &

                       "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &

                       "TO ACCESSED OBJECT");

               IF ACC1.ALL = BADOBJ1 THEN

                    COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION");

               END IF;

          EXCEPTION

               WHEN CONSTRAINT_ERROR => NULL;

               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (7)");

          END;

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

               PROC (OBJ1,OBJ2);              -- OK.

          BEGIN

               PROC (BADOBJ1,BADOBJ2);        -- 6.

               FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &

                       "PASSING OF CONSTRAINED ACTUAL " &

                       "PARAMETERS TO DIFFERENTLY CONSTRAINED " &

                       "FORMAL PARAMETERS");

          EXCEPTION

               WHEN CONSTRAINT_ERROR => NULL;

               WHEN OTHERS => FAILED ("WRONG EXCEPTION     (8)");

          END;

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

     END;

     RESULT;

END C37207A;