1-- C37208A.ADA (RA #534/1) 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-- FOR A TYPE WITH DEFAULT DISCRIMINANT VALUES, CHECK THAT A 26-- DISCRIMINANT CONSTRAINT CAN BE OMITTED IN: 27 28 -- AN OBJECT DECLARATION, AND HENCE ASSIGNMENTS TO THE OBJECT CAN 29 -- CHANGE ITS DISCRIMINANTS; 30 31 -- A COMPONENT_DECLARATION IN A RECORD TYPE DEFINITION, AND HENCE 32 -- ASSIGNMENTS TO THE COMPONENT CAN CHANGE THE VALUE OF ITS 33 -- DISCRIMINANTS; 34 35 -- A SUBTYPE INDICATION IN AN ARRAY TYPE DEFINITION, AND HENCE 36 -- ASSIGNMENTS TO ONE OF THE COMPONENTS CAN CHANGE ITS 37 -- DISCRIMINANT VALUES; 38 39 -- A FORMAL PARAMETER OF A SUBPROGRAM; EXCEPT FOR PARAMETERS OF 40 -- MODE IN, THE 'CONSTRAINED ATTRIBUTE OF THE ACTUAL PARAMETER 41 -- BECOMES THE 'CONSTRAINED ATTRIBUTE OF THE FORMAL PARAMETER; 42 -- FOR IN OUT AND OUT PARAMETERS, IF THE 'CONSTRAINED ATTRIBUTE IS 43 -- FALSE, ASSIGNMENTS TO THE FORMAL PARAMETER CAN CHANGE THE 44 -- DISCRIMINANTS OF THE ACTUAL PARAMETER; IF THE 'CONSTRAINED 45 -- ATTRIBUTE IS TRUE, ASSIGNNMENTS THAT ATTEMPT TO CHANGE THE 46 -- DISCRIMINANTS OF THE ACTUAL PARAMETER RAISE CONSTRAINT_ERROR. 47 48-- ASL 7/23/81 49-- EDS 7/16/98 AVOID OPTIMIZATION 50 51WITH REPORT; 52PROCEDURE C37208A IS 53 54 USE REPORT; 55 56BEGIN 57 TEST ("C37208A","DISCRIMINANT CONSTRAINT CAN BE OMITTED " & 58 "FROM OBJECT DECLARATION, COMPONENT DECLARATION, SUBTYPE " & 59 "INDICATION OR FORMAL SUBPROGRAM PARAMETER, IF THE TYPE " & 60 "HAS DEFAULT DISCRIMINANTS"); 61 62 DECLARE 63 TYPE REC1(DISC : INTEGER := 7) IS 64 RECORD 65 NULL; 66 END RECORD; 67 68 TYPE REC2 IS 69 RECORD 70 COMP : REC1; 71 END RECORD; 72 73 R : REC2; 74 U1,U2,U3 : REC1 := (DISC => 3); 75 C1,C2,C3 : REC1(3) := (DISC => 3); 76 ARR : ARRAY(INTEGER RANGE 1..10) OF REC1; 77 ARR2 : ARRAY (1..10) OF REC1(4); 78 79 PROCEDURE PROC(P_IN : IN REC1; 80 P_OUT : OUT REC1; 81 P_IN_OUT : IN OUT REC1; 82 CONSTR : IN BOOLEAN) IS 83 BEGIN 84 IF P_OUT'CONSTRAINED /= CONSTR 85 OR P_IN_OUT'CONSTRAINED /= CONSTR THEN 86 FAILED ("CONSTRAINED ATTRIBUTES DO NOT MATCH " & 87 "FOR ACTUAL AND FORMAL PARAMETERS"); 88 END IF; 89 90 IF P_IN'CONSTRAINED /= IDENT_BOOL(TRUE) THEN 91 FAILED ("'CONSTRAINED IS FALSE FOR IN " & 92 "PARAMETER"); 93 END IF; 94 95 IF NOT CONSTR THEN -- UNCONSTRAINED ACTUAL PARAM 96 P_OUT := (DISC => IDENT_INT(0)); 97 P_IN_OUT := (DISC => IDENT_INT(0)); 98 ELSE 99 BEGIN 100 P_OUT := (DISC => IDENT_INT(0)); 101 FAILED ("DISCRIMINANT OF CONSTRAINED ACTUAL " & 102 "PARAMETER ILLEGALLY CHANGED - 1"); 103 EXCEPTION 104 WHEN CONSTRAINT_ERROR => 105 NULL; 106 WHEN OTHERS => 107 FAILED ("WRONG EXCEPTION - 1"); 108 END; 109 110 BEGIN 111 P_IN_OUT := (DISC => IDENT_INT(0)); 112 FAILED ("DISCRIMINANT OF CONSTRAINED ACTUAL " & 113 "PARAMETER ILLEGALLY CHANGED - 2"); 114 EXCEPTION 115 WHEN CONSTRAINT_ERROR => NULL; 116 WHEN OTHERS => 117 FAILED ("WRONG EXCEPTION - 2"); 118 END; 119 END IF; 120 END PROC; 121 BEGIN 122 IF U1.DISC /= IDENT_INT(3) THEN 123 FAILED ("INITIAL DISCRIMINANT VALUE WRONG - U1"); 124 END IF; 125 126 U1 := (DISC => IDENT_INT(5)); 127 IF U1.DISC /= 5 THEN 128 FAILED ("ASSIGNMENT FAILED FOR OBJECT"); 129 END IF; 130 131 IF R.COMP.DISC /= IDENT_INT(7) THEN 132 FAILED ("DEFAULT DISCRIMINANT VALUE WRONG - R"); 133 END IF; 134 135 R.COMP := (DISC => IDENT_INT(5)); 136 IF R.COMP.DISC /= 5 THEN 137 FAILED ("ASSIGNMENT FAILED FOR RECORD COMPONENT"); 138 END IF; 139 140 FOR I IN 1..10 LOOP 141 IF ARR(I).DISC /= IDENT_INT(7) THEN 142 FAILED ("DEFAULT DISCRIMINANT VALUE WRONG - ARR"); 143 END IF; 144 END LOOP; 145 146 ARR(3) := (DISC => IDENT_INT(5)); 147 IF ARR(3).DISC /= 5 THEN 148 FAILED ("ASSIGNMENT FAILED FOR ARRAY COMPONENT"); 149 END IF; 150 151 IF ARR /= (1..2|4..10 => (DISC => 7), 3 => (DISC => 5)) THEN 152 FAILED ("MODIFIED WRONG COMPONENTS"); 153 END IF; 154 155 PROC(C1,C2,C3,IDENT_BOOL(TRUE)); 156 PROC(U1,U2,U3,IDENT_BOOL(FALSE)); 157 IF U2.DISC /= 0 OR U3.DISC /= 0 THEN 158 FAILED ("ASSIGNMENT TO UNCONSTRAINED ACTUAL PARAMETER " & 159 "FAILED TO CHANGE DISCRIMINANT"); 160 END IF; 161 162 PROC(ARR(1), ARR(3), ARR(4), FALSE); 163 IF ARR(3).DISC /= 0 OR ARR(4).DISC /= 0 THEN 164 FAILED ("ARRAY COMPONENT ASSIGNMENTS DIDN'T CHANGE " & 165 "DISCRIMINANT OF COMPONENT"); 166 END IF; 167 168 PROC (ARR2(2), ARR2(5), ARR2(10), TRUE); 169 END; 170 171 RESULT; 172END C37208A; 173