1-- CE3906D.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-- CHECK THAT CONSTRAINT_ERROR IS RAISED BY PUT FOR ENUMERATION 27-- TYPES WHEN THE VALUE OF WIDTH IS NEGATIVE, WHEN WIDTH IS 28-- GREATER THAN FIELD'LAST, OR WHEN THE VALUE OF ITEM IS OUTSIDE 29-- THE RANGE OF THE SUBTYPE USED TO INSTANTIATE ENUMERATION_IO. 30 31-- HISTORY: 32-- SPS 10/08/82 33-- DWC 09/17/87 ADDED CASES FOR CONSTRAINT_ERROR. 34-- JRL 06/07/96 Added call to Ident_Int in expressions involving 35-- Field'Last, to make the expressions non-static and 36-- prevent compile-time rejection. 37 38WITH REPORT; 39USE REPORT; 40WITH TEXT_IO; 41USE TEXT_IO; 42 43PROCEDURE CE3906D IS 44BEGIN 45 46 TEST ("CE3906D", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY PUT " & 47 "FOR ENUMERATION TYPES WHEN THE VALUE OF " & 48 "WIDTH IS NEGATIVE, WHEN WIDTH IS GREATER " & 49 "THAN FIELD'LAST, OR WHEN THE VALUE OF ITEM " & 50 "IS OUTSIDE THE RANGE OF THE SUBTYPE USED TO " & 51 "INSTANTIATE ENUMERATION_IO"); 52 53 DECLARE 54 FT : FILE_TYPE; 55 TYPE DAY IS (SUNDAY, MONDAY, TUESDAY, WEDNESDAY, 56 THURSDAY, FRIDAY, SATURDAY); 57 TODAY : DAY := FRIDAY; 58 SUBTYPE WEEKDAY IS DAY RANGE MONDAY .. FRIDAY; 59 PACKAGE DAY_IO IS NEW ENUMERATION_IO (WEEKDAY); 60 USE DAY_IO; 61 BEGIN 62 63 BEGIN 64 PUT (FT, TODAY, -1); 65 FAILED ("CONSTRAINT_ERROR NOT RAISED; NEGATIVE " & 66 "WIDTH - FILE"); 67 EXCEPTION 68 WHEN CONSTRAINT_ERROR => 69 NULL; 70 WHEN STATUS_ERROR => 71 FAILED ("RAISED STATUS_ERROR"); 72 WHEN OTHERS => 73 FAILED ("WRONG EXCEPTION RAISED; NEGATIVE " & 74 "WIDTH - FILE"); 75 END; 76 77 IF FIELD'LAST < INTEGER'LAST THEN 78 BEGIN 79 PUT (FT, TODAY, FIELD'LAST + Ident_Int(1)); 80 FAILED ("CONSTRAINT_ERROR NOT RAISED; WIDTH " & 81 "GREATER THAN FIELD'LAST + 1- FILE"); 82 EXCEPTION 83 WHEN CONSTRAINT_ERROR => 84 NULL; 85 WHEN OTHERS => 86 FAILED ("WRONG EXCEPTION RAISED; WIDTH " & 87 "GREATER THAN FIELD'LAST + 1 - FILE"); 88 END; 89 90 BEGIN 91 PUT (TODAY, FIELD'LAST + Ident_Int(1)); 92 FAILED ("CONSTRAINT_ERROR NOT RAISED; WIDTH " & 93 "GREATER THAN FIELD'LAST + 1 - DEFAULT"); 94 EXCEPTION 95 WHEN CONSTRAINT_ERROR => 96 NULL; 97 WHEN OTHERS => 98 FAILED ("WRONG EXCEPTION RAISED; WIDTH " & 99 "GREATER THAN FIELD'LAST + 1 " & 100 "- DEFAULT"); 101 END; 102 103 END IF; 104 105 TODAY := SATURDAY; 106 107 BEGIN 108 PUT (FT, TODAY); 109 FAILED ("CONSTRAINT_ERROR NOT RAISED; ITEM VALUE " & 110 "OUT OF RANGE - FILE"); 111 EXCEPTION 112 WHEN CONSTRAINT_ERROR => 113 NULL; 114 WHEN OTHERS => 115 FAILED ("WRONG EXCEPTION RAISED; ITEM VALUE " & 116 "OUT OF RANGE - FILE"); 117 END; 118 119 TODAY := FRIDAY; 120 121 BEGIN 122 PUT (TODAY, -3); 123 FAILED ("CONSTRAINT_ERROR NOT RAISED; NEGATIVE " & 124 "WIDTH - DEFAULT"); 125 EXCEPTION 126 WHEN CONSTRAINT_ERROR => 127 NULL; 128 WHEN STATUS_ERROR => 129 FAILED ("RAISED STATUS_ERROR"); 130 WHEN OTHERS => 131 FAILED ("WRONG EXCEPTION RAISED; NEGATIVE " & 132 "WIDTH - DEFAULT"); 133 END; 134 135 TODAY := SATURDAY; 136 137 BEGIN 138 PUT (TODAY); 139 FAILED ("CONSTRAINT_ERROR NOT RAISED; ITEM VALUE " & 140 "OUT OF RANGE - DEFAULT"); 141 EXCEPTION 142 WHEN CONSTRAINT_ERROR => 143 NULL; 144 WHEN OTHERS => 145 FAILED ("WRONG EXCEPTION RAISED; ITEM VALUE " & 146 "OUT OF RANGE - DEFAULT"); 147 END; 148 END; 149 150 RESULT; 151 152END CE3906D; 153