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