1-- C34006F.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 RECORD TYPES WITH DISCRIMINANTS AND WITH NON-LIMITED 27-- COMPONENT TYPES: 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/22/86 CREATED ORIGINAL TEST. 36 37WITH REPORT; USE REPORT; 38 39PROCEDURE C34006F IS 40 41 SUBTYPE COMPONENT IS INTEGER; 42 43 PACKAGE PKG IS 44 45 MAX_LEN : CONSTANT := 10; 46 47 SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; 48 49 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS 50 RECORD 51 I : INTEGER; 52 CASE B IS 53 WHEN TRUE => 54 S : STRING (1 .. L); 55 C : COMPONENT; 56 WHEN FALSE => 57 F : FLOAT := 5.0; 58 END CASE; 59 END RECORD; 60 61 FUNCTION CREATE ( B : BOOLEAN; 62 L : LENGTH; 63 I : INTEGER; 64 S : STRING; 65 C : COMPONENT; 66 F : FLOAT; 67 X : PARENT -- TO RESOLVE OVERLOADING. 68 ) RETURN PARENT; 69 70 END PKG; 71 72 USE PKG; 73 74 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); 75 76 SUBTYPE SUBPARENT IS PARENT (TRUE, 3); 77 78 TYPE S IS NEW SUBPARENT; 79 80 X : T := (TRUE, 3, 2, "AAA", 2); 81 Y : S := (TRUE, 3, 2, "AAA", 2); 82 83 PACKAGE BODY PKG IS 84 85 FUNCTION CREATE 86 ( B : BOOLEAN; 87 L : LENGTH; 88 I : INTEGER; 89 S : STRING; 90 C : COMPONENT; 91 F : FLOAT; 92 X : PARENT 93 ) RETURN PARENT 94 IS 95 BEGIN 96 CASE B IS 97 WHEN TRUE => 98 RETURN (TRUE, L, I, S, C); 99 WHEN FALSE => 100 RETURN (FALSE, L, I, F); 101 END CASE; 102 END CREATE; 103 104 END PKG; 105 106BEGIN 107 TEST ("C34006F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 108 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 109 "WHEN THE DERIVED TYPE DEFINITION IS " & 110 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 111 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 112 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 113 "RECORD TYPES WITH DISCRIMINANTS AND WITH " & 114 "NON-LIMITED COMPONENT TYPES"); 115 116 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 117 118 BEGIN 119 IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /= 120 (FALSE, 2, 3, 6.0) OR 121 CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /= 122 (FALSE, 2, 3, 6.0) THEN 123 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & 124 "SUBTYPE"); 125 END IF; 126 EXCEPTION 127 WHEN CONSTRAINT_ERROR => 128 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); 129 WHEN OTHERS => 130 FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); 131 END; 132 133 BEGIN 134 IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR 135 CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN 136 FAILED ("INCORRECT ""IN"""); 137 END IF; 138 EXCEPTION 139 WHEN CONSTRAINT_ERROR => 140 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); 141 WHEN OTHERS => 142 FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); 143 END; 144 145 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 146 147 IF X.B /= TRUE OR X.L /= 3 OR 148 Y.B /= TRUE OR Y.L /= 3 THEN 149 FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); 150 END IF; 151 152 IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN 153 FAILED ("INCORRECT 'CONSTRAINED"); 154 END IF; 155 156 BEGIN 157 X := (TRUE, 3, 1, "ABC", 4); 158 Y := (TRUE, 3, 1, "ABC", 4); 159 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. 160 FAILED ("INCORRECT CONVERSION TO PARENT"); 161 END IF; 162 EXCEPTION 163 WHEN OTHERS => 164 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); 165 END; 166 167 BEGIN 168 X := (FALSE, 3, 2, 6.0); 169 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 170 "X := (FALSE, 3, 2, 6.0)"); 171 IF X = (FALSE, 3, 2, 6.0) THEN -- USE X. 172 COMMENT ("X ALTERED -- X := (FALSE, 3, 2, 6.0)"); 173 END IF; 174 EXCEPTION 175 WHEN CONSTRAINT_ERROR => 176 NULL; 177 WHEN OTHERS => 178 FAILED ("WRONG EXCEPTION RAISED -- " & 179 "X := (FALSE, 3, 2, 6.0)"); 180 END; 181 182 BEGIN 183 X := (TRUE, 4, 2, "ZZZZ", 6); 184 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 185 "X := (TRUE, 4, 2, ""ZZZZ"", 6)"); 186 IF X = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. 187 COMMENT ("X ALTERED -- X := (TRUE, 4, 2, ""ZZZZ"", 6)"); 188 END IF; 189 EXCEPTION 190 WHEN CONSTRAINT_ERROR => 191 NULL; 192 WHEN OTHERS => 193 FAILED ("WRONG EXCEPTION RAISED -- " & 194 "X := (TRUE, 4, 2, ""ZZZZ"", 6)"); 195 END; 196 197 BEGIN 198 Y := (FALSE, 3, 2, 6.0); 199 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 200 "Y := (FALSE, 3, 2, 6.0)"); 201 IF Y = (FALSE, 3, 2, 6.0) THEN -- USE Y. 202 COMMENT ("Y ALTERED -- Y := (FALSE, 3, 2, 6.0)"); 203 END IF; 204 EXCEPTION 205 WHEN CONSTRAINT_ERROR => 206 NULL; 207 WHEN OTHERS => 208 FAILED ("WRONG EXCEPTION RAISED -- " & 209 "Y := (FALSE, 3, 2, 6.0)"); 210 END; 211 212 BEGIN 213 Y := (TRUE, 4, 2, "ZZZZ", 6); 214 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 215 "Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); 216 IF Y = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. 217 COMMENT ("Y ALTERED -- Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); 218 END IF; 219 EXCEPTION 220 WHEN CONSTRAINT_ERROR => 221 NULL; 222 WHEN OTHERS => 223 FAILED ("WRONG EXCEPTION RAISED -- " & 224 "Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); 225 END; 226 227 RESULT; 228END C34006F; 229