1-- C34001F.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 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 C34001F IS 39 40 SUBTYPE PARENT IS BOOLEAN; 41 42 TYPE T IS NEW PARENT RANGE 43 PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))) .. 44 PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))); 45 46 SUBTYPE SUBPARENT IS PARENT RANGE TRUE .. TRUE; 47 48 TYPE S IS NEW SUBPARENT; 49 50 X : T; 51 Y : S; 52 53BEGIN 54 TEST ("C34001F", "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 "BOOLEAN TYPES"); 61 62 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 63 64 IF T'BASE'FIRST /= FALSE OR T'BASE'LAST /= TRUE OR 65 S'BASE'FIRST /= FALSE OR S'BASE'LAST /= TRUE THEN 66 FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST"); 67 END IF; 68 69 IF T'PRED (TRUE) /= FALSE OR T'SUCC (FALSE) /= TRUE OR 70 S'PRED (TRUE) /= FALSE OR S'SUCC (FALSE) /= TRUE THEN 71 FAILED ("INCORRECT 'PRED OR 'SUCC"); 72 END IF; 73 74 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 75 76 IF T'FIRST /= FALSE OR T'LAST /= FALSE OR 77 S'FIRST /= TRUE OR S'LAST /= TRUE THEN 78 FAILED ("INCORRECT 'FIRST OR 'LAST"); 79 END IF; 80 81 BEGIN 82 X := FALSE; 83 Y := TRUE; 84 IF NOT PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. 85 FAILED ("INCORRECT CONVERSION TO PARENT"); 86 END IF; 87 EXCEPTION 88 WHEN OTHERS => 89 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); 90 END; 91 92 BEGIN 93 X := TRUE; 94 FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := TRUE"); 95 IF X = TRUE THEN -- USE X. 96 COMMENT ("X ALTERED -- X := TRUE"); 97 END IF; 98 EXCEPTION 99 WHEN CONSTRAINT_ERROR => 100 NULL; 101 WHEN OTHERS => 102 FAILED ("WRONG EXCEPTION RAISED -- X := TRUE"); 103 END; 104 105 BEGIN 106 Y := FALSE; 107 FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := FALSE"); 108 IF Y = FALSE THEN -- USE Y. 109 COMMENT ("Y ALTERED -- Y := FALSE"); 110 END IF; 111 EXCEPTION 112 WHEN CONSTRAINT_ERROR => 113 NULL; 114 WHEN OTHERS => 115 FAILED ("WRONG EXCEPTION RAISED -- Y := FALSE"); 116 END; 117 118 RESULT; 119END C34001F; 120