1-- C34005L.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-- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A 27-- BOOLEAN TYPE: 28-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR 29-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS 30-- CONSTRAINED. 31-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO 32-- IMPOSED ON THE DERIVED SUBTYPE. 33 34-- HISTORY: 35-- JRK 9/16/86 CREATED ORIGINAL TEST. 36 37WITH REPORT; USE REPORT; 38 39PROCEDURE C34005L IS 40 41 SUBTYPE COMPONENT IS BOOLEAN; 42 43 PACKAGE PKG IS 44 45 FIRST : CONSTANT := 0; 46 LAST : CONSTANT := 100; 47 48 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; 49 50 TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; 51 52 FUNCTION CREATE ( F, L : INDEX; 53 C : COMPONENT; 54 DUMMY : PARENT -- TO RESOLVE OVERLOADING. 55 ) RETURN PARENT; 56 57 END PKG; 58 59 USE PKG; 60 61 TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); 62 63 SUBTYPE SUBPARENT IS PARENT (5 .. 7); 64 65 TYPE S IS NEW SUBPARENT; 66 67 X : T := (OTHERS => TRUE); 68 Y : S := (OTHERS => TRUE); 69 70 PACKAGE BODY PKG IS 71 72 FUNCTION CREATE 73 ( F, L : INDEX; 74 C : COMPONENT; 75 DUMMY : PARENT 76 ) RETURN PARENT 77 IS 78 A : PARENT (F .. L); 79 B : COMPONENT := C; 80 BEGIN 81 FOR I IN F .. L LOOP 82 A (I) := B; 83 B := NOT B; 84 END LOOP; 85 RETURN A; 86 END CREATE; 87 88 END PKG; 89 90BEGIN 91 TEST ("C34005L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 92 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 93 "WHEN THE DERIVED TYPE DEFINITION IS " & 94 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 95 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 96 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 97 "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & 98 "TYPE IS A BOOLEAN TYPE"); 99 100 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 101 102 BEGIN 103 IF CREATE (2, 3, FALSE, X) /= (FALSE, TRUE) OR 104 CREATE (2, 3, FALSE, Y) /= (FALSE, TRUE) THEN 105 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & 106 "SUBTYPE"); 107 END IF; 108 EXCEPTION 109 WHEN CONSTRAINT_ERROR => 110 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); 111 WHEN OTHERS => 112 FAILED ("CALL TO CREATE RAISED EXCEPTION"); 113 END; 114 115 IF X & (FALSE, TRUE) /= (TRUE, TRUE, TRUE, FALSE, TRUE) OR 116 Y & (FALSE, TRUE) /= (TRUE, TRUE, TRUE, FALSE, TRUE) THEN 117 FAILED ("INCORRECT &"); 118 END IF; 119 120 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 121 122 IF T'FIRST /= 5 OR T'LAST /= 7 OR 123 S'FIRST /= 5 OR S'LAST /= 7 THEN 124 FAILED ("INCORRECT 'FIRST OR 'LAST"); 125 END IF; 126 127 BEGIN 128 X := (TRUE, FALSE, TRUE); 129 Y := (TRUE, FALSE, TRUE); 130 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. 131 FAILED ("INCORRECT CONVERSION TO PARENT"); 132 END IF; 133 EXCEPTION 134 WHEN OTHERS => 135 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); 136 END; 137 138 BEGIN 139 X := (TRUE, FALSE); 140 FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (TRUE, FALSE)"); 141 IF X = (TRUE, FALSE) THEN -- USE X. 142 COMMENT ("X ALTERED -- X := (TRUE, FALSE)"); 143 END IF; 144 EXCEPTION 145 WHEN CONSTRAINT_ERROR => 146 NULL; 147 WHEN OTHERS => 148 FAILED ("WRONG EXCEPTION RAISED -- X := (TRUE, FALSE)"); 149 END; 150 151 BEGIN 152 X := (TRUE, FALSE, TRUE, FALSE); 153 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 154 "X := (TRUE, FALSE, TRUE, FALSE)"); 155 IF X = (TRUE, FALSE, TRUE, FALSE) THEN -- USE X. 156 COMMENT ("X ALTERED -- X := (TRUE, FALSE, TRUE, FALSE)"); 157 END IF; 158 EXCEPTION 159 WHEN CONSTRAINT_ERROR => 160 NULL; 161 WHEN OTHERS => 162 FAILED ("WRONG EXCEPTION RAISED -- " & 163 "X := (TRUE, FALSE, TRUE, FALSE)"); 164 END; 165 166 BEGIN 167 Y := (TRUE, FALSE); 168 FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (TRUE, FALSE)"); 169 IF Y = (TRUE, FALSE) THEN -- USE Y. 170 COMMENT ("Y ALTERED -- Y := (TRUE, FALSE)"); 171 END IF; 172 EXCEPTION 173 WHEN CONSTRAINT_ERROR => 174 NULL; 175 WHEN OTHERS => 176 FAILED ("WRONG EXCEPTION RAISED -- Y := (TRUE, FALSE)"); 177 END; 178 179 BEGIN 180 Y := (TRUE, FALSE, TRUE, FALSE); 181 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 182 "Y := (TRUE, FALSE, TRUE, FALSE)"); 183 IF Y = (TRUE, FALSE, TRUE, FALSE) THEN -- USE Y. 184 COMMENT ("Y ALTERED -- Y := (TRUE, FALSE, TRUE, FALSE)"); 185 END IF; 186 EXCEPTION 187 WHEN CONSTRAINT_ERROR => 188 NULL; 189 WHEN OTHERS => 190 FAILED ("WRONG EXCEPTION RAISED -- " & 191 "Y := (TRUE, FALSE, TRUE, FALSE)"); 192 END; 193 194 RESULT; 195END C34005L; 196