1-- C47005A.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-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A FLOATING 27-- POINT TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE 28-- OF THE OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. 29 30-- HISTORY: 31-- RJW 07/23/86 CREATED ORIGINAL TEST. 32-- BCB 08/19/87 CHANGED HEADER TO STANDARD HEADER FORMAT. ADDED 33-- TEST FOR UPPER SIDE OF RANGE. 34 35WITH REPORT; USE REPORT; 36PROCEDURE C47005A IS 37 38BEGIN 39 40 TEST( "C47005A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " & 41 "DENOTES A FLOATING POINT TYPE, CHECK THAT " & 42 "CONSTRAINT_ERROR IS RAISED WHEN THE VALUE " & 43 "OF THE OPERAND DOES NOT LIE WITHIN THE " & 44 "RANGE OF THE TYPE MARK" ); 45 46 DECLARE 47 48 SUBTYPE SFLOAT IS FLOAT RANGE -1.0 .. 1.0; 49 50 FUNCTION IDENT (F : FLOAT) RETURN FLOAT IS 51 BEGIN 52 IF EQUAL (3, 3) THEN 53 RETURN F; 54 ELSE 55 RETURN 0.0; 56 END IF; 57 END IDENT; 58 59 BEGIN 60 IF SFLOAT'(IDENT (-2.0)) = -1.0 THEN 61 FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & 62 "SUBTYPE SFLOAT - 1"); 63 ELSE 64 FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & 65 "SUBTYPE SFLOAT - 2"); 66 END IF; 67 EXCEPTION 68 WHEN CONSTRAINT_ERROR => 69 NULL; 70 WHEN OTHERS => 71 FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & 72 "OF SUBTYPE SFLOAT" ); 73 END; 74 75 DECLARE 76 77 TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; 78 SUBTYPE SFLT IS FLT RANGE -1.0 .. 1.0; 79 80 FUNCTION IDENT (F : FLT) RETURN FLT IS 81 BEGIN 82 IF EQUAL (3, 3) THEN 83 RETURN F; 84 ELSE 85 RETURN 0.0; 86 END IF; 87 END IDENT; 88 89 BEGIN 90 IF SFLT'(IDENT (-2.0)) = -1.0 THEN 91 FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & 92 "SUBTYPE SFLT - 1"); 93 ELSE 94 FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & 95 "SUBTYPE SFLT - 2"); 96 END IF; 97 EXCEPTION 98 WHEN CONSTRAINT_ERROR => 99 NULL; 100 WHEN OTHERS => 101 FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & 102 "OF SUBTYPE SFLT" ); 103 END; 104 105 DECLARE 106 107 TYPE NFLT IS NEW FLOAT; 108 SUBTYPE SNFLT IS NFLT RANGE -1.0 .. 1.0; 109 110 FUNCTION IDENT (F : NFLT) RETURN NFLT IS 111 BEGIN 112 IF EQUAL (3, 3) THEN 113 RETURN F; 114 ELSE 115 RETURN 0.0; 116 END IF; 117 END IDENT; 118 119 BEGIN 120 IF SNFLT'(IDENT (2.0)) = 1.0 THEN 121 FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & 122 "SUBTYPE SNFLT 1"); 123 ELSE 124 FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & 125 "SUBTYPE SNFLT 2"); 126 END IF; 127 EXCEPTION 128 WHEN CONSTRAINT_ERROR => 129 NULL; 130 WHEN OTHERS => 131 FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & 132 "OF SUBTYPE SNFLT" ); 133 END; 134 135 RESULT; 136END C47005A; 137