1-- C35505C.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 FOR 'SUCC' AND 'PRED', 27-- IF THE RETURNED VALUES WOULD BE OUTSIDE OF THE BASE TYPE, 28-- WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT 29-- IS A USER-DEFINED ENUMERATION TYPE. 30 31-- HISTORY: 32-- RJW 06/05/86 CREATED ORIGINAL TEST. 33-- VCL 08/19/87 REMOVED THE FUNCTION 'IDENT' IN THE GENERIC 34-- PROCEDURE 'P' AND REPLACED ALL CALLS TO 'IDENT' 35-- WITH "T'VAL(IDENT_INT(T'POS(...)))". 36 37WITH REPORT; USE REPORT; 38 39PROCEDURE C35505C IS 40 41 TYPE B IS ('Z', 'X', Z, X); 42 43 SUBTYPE C IS B RANGE 'X' .. Z; 44 45BEGIN 46 TEST ( "C35505C", "CHECK THAT 'SUCC' AND 'PRED' RAISE " & 47 "CONSTRAINT_ERROR APPROPRIATELY WHEN THE " & 48 "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & 49 "ARGUMENT IS A USER-DEFINED ENUMERATION TYPE" ); 50 51 DECLARE 52 GENERIC 53 TYPE T IS (<>); 54 STR : STRING; 55 PROCEDURE P; 56 57 PROCEDURE P IS 58 59 BEGIN 60 BEGIN 61 IF T'PRED (T'VAL (IDENT_INT (T'POS 62 (T'BASE'FIRST)))) = T'FIRST THEN 63 FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & 64 STR & "'PRED - 1" ); 65 ELSE 66 FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & 67 STR & "'PRED - 2" ); 68 END IF; 69 EXCEPTION 70 WHEN CONSTRAINT_ERROR => 71 NULL; 72 WHEN OTHERS => 73 FAILED ( "WRONG EXCEPTION RAISED FOR " & 74 STR & "'PRED - 1" ); 75 END; 76 77 BEGIN 78 IF T'SUCC (T'VAL (IDENT_INT (T'POS 79 (T'BASE'LAST)))) = T'LAST THEN 80 FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & 81 STR & "'SUCC - 1" ); 82 ELSE 83 FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & 84 STR & "'SUCC - 2" ); 85 END IF; 86 EXCEPTION 87 WHEN CONSTRAINT_ERROR => 88 NULL; 89 WHEN OTHERS => 90 FAILED ( "WRONG EXCEPTION RAISED FOR " & 91 STR & "'SUCC - 1" ); 92 END; 93 END P; 94 95 PROCEDURE PB IS NEW P (B, "B"); 96 PROCEDURE PC IS NEW P (C, "C"); 97 BEGIN 98 PB; 99 PC; 100 END; 101RESULT; 102END C35505C; 103