1-- C34001C.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-- FOR DERIVED ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES: 26 27-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE 28-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS 29-- CONSTRAINED. 30 31-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO 32-- IMPOSED ON THE DERIVED SUBTYPE. 33 34-- JRK 8/20/86 35 36WITH REPORT; USE REPORT; 37 38PROCEDURE C34001C IS 39 40 TYPE PARENT IS (E1, E2, E3, 'A', E4, E5, E6); 41 42 TYPE T IS NEW PARENT RANGE 43 PARENT'VAL (IDENT_INT (PARENT'POS (E3))) .. 44 PARENT'VAL (IDENT_INT (PARENT'POS (E4))); 45 46 SUBTYPE SUBPARENT IS PARENT RANGE E3 .. E4; 47 48 TYPE S IS NEW SUBPARENT; 49 50 X : T; 51 Y : S; 52 53BEGIN 54 TEST ("C34001C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 55 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 56 "WHEN THE DERIVED TYPE DEFINITION IS " & 57 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 58 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 59 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 60 "ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES"); 61 62 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 63 64 IF T'BASE'FIRST /= E1 OR T'BASE'LAST /= E6 OR 65 S'BASE'FIRST /= E1 OR S'BASE'LAST /= E6 THEN 66 FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST"); 67 END IF; 68 69 IF T'PRED (E2) /= E1 OR T'SUCC (E1) /= E2 OR 70 S'PRED (E2) /= E1 OR S'SUCC (E1) /= E2 THEN 71 FAILED ("INCORRECT 'PRED OR 'SUCC"); 72 END IF; 73 74 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 75 76 IF T'FIRST /= E3 OR T'LAST /= E4 OR 77 S'FIRST /= E3 OR S'LAST /= E4 THEN 78 FAILED ("INCORRECT 'FIRST OR 'LAST"); 79 END IF; 80 81 BEGIN 82 X := E3; 83 Y := E3; 84 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. 85 FAILED ("INCORRECT CONVERSION TO PARENT - 1"); 86 END IF; 87 X := E4; 88 Y := E4; 89 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. 90 FAILED ("INCORRECT CONVERSION TO PARENT - 2"); 91 END IF; 92 EXCEPTION 93 WHEN OTHERS => 94 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); 95 END; 96 97 BEGIN 98 X := E2; 99 FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E2"); 100 IF X = E2 THEN -- USE X. 101 COMMENT ("X ALTERED -- X := E2"); 102 END IF; 103 EXCEPTION 104 WHEN CONSTRAINT_ERROR => 105 NULL; 106 WHEN OTHERS => 107 FAILED ("WRONG EXCEPTION RAISED -- X := E2"); 108 END; 109 110 BEGIN 111 X := E5; 112 FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E5"); 113 IF X = E5 THEN -- USE X. 114 COMMENT ("X ALTERED -- X := E5"); 115 END IF; 116 EXCEPTION 117 WHEN CONSTRAINT_ERROR => 118 NULL; 119 WHEN OTHERS => 120 FAILED ("WRONG EXCEPTION RAISED -- X := E5"); 121 END; 122 123 BEGIN 124 Y := E2; 125 FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E2"); 126 IF Y = E2 THEN -- USE Y. 127 COMMENT ("Y ALTERED -- Y := E2"); 128 END IF; 129 EXCEPTION 130 WHEN CONSTRAINT_ERROR => 131 NULL; 132 WHEN OTHERS => 133 FAILED ("WRONG EXCEPTION RAISED -- Y := E2"); 134 END; 135 136 BEGIN 137 Y := E5; 138 FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E5"); 139 IF Y = E5 THEN -- USE Y. 140 COMMENT ("Y ALTERED -- Y := E5"); 141 END IF; 142 EXCEPTION 143 WHEN CONSTRAINT_ERROR => 144 NULL; 145 WHEN OTHERS => 146 FAILED ("WRONG EXCEPTION RAISED -- Y := E5"); 147 END; 148 149 RESULT; 150END C34001C; 151