1-- C34005I.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-- CHARACTER 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/15/86 CREATED ORIGINAL TEST. 36 37WITH REPORT; USE REPORT; 38 39PROCEDURE C34005I IS 40 41 TYPE COMPONENT IS NEW CHARACTER; 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 => 'B'); 68 Y : S := (OTHERS => 'B'); 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 := COMPONENT'SUCC (B); 84 END LOOP; 85 RETURN A; 86 END CREATE; 87 88 END PKG; 89 90BEGIN 91 TEST ("C34005I", "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 CHARACTER TYPE"); 99 100 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 101 102 BEGIN 103 IF CREATE (2, 3, 'D', X) /= "DE" OR 104 CREATE (2, 3, 'D', Y) /= "DE" 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 & "CD" /= "BBBCD" OR 116 Y & "CD" /= "BBBCD" 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 := "ABC"; 129 Y := "ABC"; 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 := "AB"; 140 FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := ""AB"""); 141 IF X = "AB" THEN -- USE X. 142 COMMENT ("X ALTERED -- X := ""AB"""); 143 END IF; 144 EXCEPTION 145 WHEN CONSTRAINT_ERROR => 146 NULL; 147 WHEN OTHERS => 148 FAILED ("WRONG EXCEPTION RAISED -- X := ""AB"""); 149 END; 150 151 BEGIN 152 X := "ABCD"; 153 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 154 "X := ""ABCD"""); 155 IF X = "ABCD" THEN -- USE X. 156 COMMENT ("X ALTERED -- X := ""ABCD"""); 157 END IF; 158 EXCEPTION 159 WHEN CONSTRAINT_ERROR => 160 NULL; 161 WHEN OTHERS => 162 FAILED ("WRONG EXCEPTION RAISED -- " & 163 "X := ""ABCD"""); 164 END; 165 166 BEGIN 167 Y := "AB"; 168 FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := ""AB"""); 169 IF Y = "AB" THEN -- USE Y. 170 COMMENT ("Y ALTERED -- Y := ""AB"""); 171 END IF; 172 EXCEPTION 173 WHEN CONSTRAINT_ERROR => 174 NULL; 175 WHEN OTHERS => 176 FAILED ("WRONG EXCEPTION RAISED -- Y := ""AB"""); 177 END; 178 179 BEGIN 180 Y := "ABCD"; 181 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 182 "Y := ""ABCD"""); 183 IF Y = "ABCD" THEN -- USE Y. 184 COMMENT ("Y ALTERED -- Y := ""ABCD"""); 185 END IF; 186 EXCEPTION 187 WHEN CONSTRAINT_ERROR => 188 NULL; 189 WHEN OTHERS => 190 FAILED ("WRONG EXCEPTION RAISED -- " & 191 "Y := ""ABCD"""); 192 END; 193 194 RESULT; 195END C34005I; 196