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