1-- CC1221C.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 A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC 27-- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE 28-- WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, 'VAL, 'PRED, 'SUCC, 29-- 'IMAGE, AND 'VALUE. 30 31-- HISTORY: 32-- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA 33 34WITH SYSTEM; USE SYSTEM; 35WITH REPORT; USE REPORT; 36PROCEDURE CC1221C IS 37 38 SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; 39 TYPE NEWINT IS NEW INTEGER; 40 TYPE INT IS RANGE -300 .. 300; 41 SUBTYPE SINT1 IS INT 42 RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4)); 43 TYPE INT1 IS RANGE -6 .. 6; 44 45BEGIN 46 TEST ( "CC1221C", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & 47 "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & 48 "DECLARED AND ARE THEREFORE AVAILABLE " & 49 "WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, " & 50 "'VAL, 'PRED, 'SUCC, 'IMAGE, AND 'VALUE"); 51 52 DECLARE -- (C1) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. 53 -- PART III. 54 55 GENERIC 56 TYPE T IS RANGE <>; 57 F : INTEGER; 58 PROCEDURE P (STR : STRING); 59 60 PROCEDURE P (STR : STRING) IS 61 I : INTEGER; 62 Y : T; 63 64 FUNCTION IDENT (X : T) RETURN T IS 65 BEGIN 66 IF EQUAL (3, 3) THEN 67 RETURN X; 68 ELSE 69 RETURN T'SUCC (T'FIRST); 70 END IF; 71 END IDENT; 72 73 BEGIN 74 I := F; 75 FOR X IN T LOOP 76 IF T'VAL (I) /= X THEN 77 FAILED ( "WRONG VALUE FOR " & STR & 78 "'VAL OF " & INTEGER'IMAGE (I)); 79 END IF; 80 81 IF T'POS (X) /= I THEN 82 FAILED ( "WRONG VALUE FOR " & STR & 83 "'POS OF " & T'IMAGE (X)); 84 END IF; 85 86 I := I + 1; 87 END LOOP; 88 89 FOR X IN T LOOP 90 IF T'SUCC (X) /= T'VAL (T'POS (X) + 1) THEN 91 FAILED ( "WRONG VALUE FOR " & STR & 92 "'SUCC OF " & T'IMAGE (X)); 93 END IF; 94 95 IF T'PRED (X) /= T'VAL (T'POS (X) - 1) THEN 96 FAILED ( "WRONG VALUE FOR " & STR & 97 "'PRED OF " & T'IMAGE (X)); 98 END IF; 99 END LOOP; 100 101 BEGIN 102 Y := T'SUCC (IDENT (T'BASE'LAST)); 103 FAILED ( "NO EXCEPTION RAISED FOR " & 104 STR & "'SUCC (IDENT (" & STR & 105 "'BASE'LAST))" ); 106 EXCEPTION 107 WHEN CONSTRAINT_ERROR => 108 NULL; 109 WHEN OTHERS => 110 FAILED ( "WRONG EXCEPTION RAISED FOR " & 111 STR & "'SUCC (IDENT (" & STR & 112 "'BASE'LAST))" ); 113 END; 114 115 BEGIN 116 Y := T'PRED (IDENT (T'BASE'FIRST)); 117 FAILED ( "NO EXCEPTION RAISED FOR " & 118 STR & "'PRED (IDENT (" & STR & 119 "'BASE'FIRST))" ); 120 EXCEPTION 121 WHEN CONSTRAINT_ERROR => 122 NULL; 123 WHEN OTHERS => 124 FAILED ( "WRONG EXCEPTION RAISED FOR " & 125 STR & "'PRED (IDENT (" & STR & 126 "'BASE'FIRST))" ); 127 END; 128 129 END P; 130 131 PROCEDURE P1 IS NEW P (SUBINT, -100); 132 PROCEDURE P2 IS NEW P (SINT1, -4); 133 PROCEDURE P3 IS NEW P (INT1, -6); 134 135 BEGIN 136 P1 ( "SUBINT" ); 137 P2 ( "SINT" ); 138 P3 ( "INT1" ); 139 END; -- (C1). 140 141 DECLARE -- (C2) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. 142 -- PART IV. 143 144 GENERIC 145 TYPE T IS RANGE <>; 146 STR : STRING; 147 PACKAGE PKG IS END PKG; 148 149 PACKAGE BODY PKG IS 150 PROCEDURE P (IM : STRING; VA : T) IS 151 BEGIN 152 IF T'IMAGE (VA) /= IM THEN 153 FAILED ( "INCORRECT RESULTS FOR " & STR & 154 "'IMAGE OF " & 155 INTEGER'IMAGE (INTEGER (VA))); 156 END IF; 157 END P; 158 159 PROCEDURE Q (IM : STRING; VA : T) IS 160 BEGIN 161 IF T'VALUE (IM) /= VA THEN 162 FAILED ( "INCORRECT RESULTS FOR " & STR & 163 "'VALUE OF " & IM); 164 END IF; 165 EXCEPTION 166 WHEN CONSTRAINT_ERROR => 167 FAILED ( "CONSTRAINT_ERROR RAISED FOR " & 168 STR &"'VALUE OF " & IM); 169 WHEN OTHERS => 170 FAILED ( "OTHER EXCEPTION RAISED FOR " & 171 STR &"'VALUE OF " & IM); 172 173 END Q; 174 175 BEGIN 176 P (" 2", 2); 177 P ("-1", -1); 178 179 Q (" 2", 2); 180 Q ("-1", -1); 181 Q (" 2", 2); 182 Q ("-1 ", -1); 183 END PKG; 184 185 PACKAGE PKG1 IS NEW PKG (SUBINT, "SUBINT"); 186 PACKAGE PKG2 IS NEW PKG (SINT1, "SINT1"); 187 PACKAGE PKG3 IS NEW PKG (INT1, "INT1"); 188 PACKAGE PKG4 IS NEW PKG (NEWINT, "NEWINT"); 189 190 BEGIN 191 NULL; 192 END; -- (C2). 193 194 RESULT; 195END CC1221C; 196