1-- C4A012B.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
27--     A UNIVERSAL_REAL EXPRESSION IF DIVISION BY ZERO IS ATTEMPTED.
28
29--     CHECK THAT CONSTRAINT_ERROR IS RAISED FOR
30--     0.0 ** (-1) (OR ANY OTHER NEGATIVE EXPONENT VALUE).
31
32-- HISTORY:
33--     RJW 09/04/86  CREATED ORIGINAL TEST.
34--     CJJ 09/04/87  ADDED PASS MESSAGE FOR RAISING NUMERIC_ERROR;
35--                   MODIFIED CODE TO PREVENT COMPILER OPTIMIZING
36--                   OUT THE TEST.
37--     JET 12/31/87  ADDED MORE CODE TO PREVENT OPTIMIZATION.
38--     MRM 03/30/93  REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
39--     JRL 02/29/96  Added code to check for value of Machine_Overflows; if
40--                   False, test is inapplicable.
41
42WITH REPORT; USE REPORT;
43
44PROCEDURE C4A012B IS
45
46     F : FLOAT;
47
48     I3 : INTEGER := -3;
49
50     SUBTYPE SINT IS INTEGER RANGE -10 .. 10;
51     SI5 : CONSTANT SINT := -5;
52
53     FUNCTION IDENT (X:FLOAT) RETURN FLOAT IS
54     BEGIN
55          IF EQUAL (3,3) THEN
56               RETURN X;
57          ELSE
58               RETURN 1.0;
59          END IF;
60     END IDENT;
61
62BEGIN
63
64     TEST ( "C4A012B", "CHECK THAT CONSTRAINT_ERROR " &
65                       "IS RAISED FOR " &
66                       "0.0 ** (-1) (OR ANY OTHER NEGATIVE EXPONENT " &
67                       "VALUE)" );
68
69     IF FLOAT'MACHINE_OVERFLOWS = FALSE THEN
70        REPORT.NOT_APPLICABLE ("Float'Machine_Overflows = False");
71     ELSE
72
73        BEGIN
74             F := IDENT (0.0) ** (-1);
75             FAILED ( "THE EXPRESSION '0.0 ** (-1)' DID NOT RAISE " &
76                      "AN EXCEPTION" );
77             IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
78                  COMMENT ("SHOULDN'T BE HERE!");
79             END IF;
80        EXCEPTION
81             WHEN CONSTRAINT_ERROR =>
82                  COMMENT ("CONSTRAINT_ERROR RAISED - 1");
83             WHEN OTHERS =>
84                  FAILED ( "THE EXPRESSION '0.0 ** (-1)' RAISED THE " &
85                           "WRONG EXCEPTION" );
86        END;
87
88        BEGIN
89             F := 0.0 ** (IDENT_INT (-1));
90             FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (-1))' DID " &
91                       "NOT RAISE AN EXCEPTION" );
92             IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
93                  COMMENT ("SHOULDN'T BE HERE!");
94             END IF;
95        EXCEPTION
96             WHEN CONSTRAINT_ERROR =>
97                  COMMENT ("CONSTRAINT_ERROR RAISED - 2");
98             WHEN OTHERS =>
99                  FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (-1))' " &
100                           "RAISED THE WRONG EXCEPTION" );
101        END;
102
103        BEGIN
104             F := 0.0 ** (INTEGER'POS (IDENT_INT (-1)));
105             FAILED ( "THE EXPRESSION '0.0 ** " &
106                      "(INTEGER'POS (IDENT_INT (-1)))' DID " &
107                      "NOT RAISE AN EXCEPTION" );
108             IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
109                  COMMENT ("SHOULDN'T BE HERE!");
110             END IF;
111        EXCEPTION
112             WHEN CONSTRAINT_ERROR =>
113                  COMMENT ("CONSTRAINT_ERROR RAISED - 3");
114             WHEN OTHERS =>
115                  FAILED ( "THE EXPRESSION '0.0 ** " &
116                           "(INTEGER'POS (IDENT_INT (-1)))' RAISED " &
117                           "THE WRONG EXCEPTION" );
118        END;
119
120        BEGIN
121             F := IDENT(0.0) ** I3;
122             FAILED ( "THE EXPRESSION '0.0 ** I3' DID NOT RAISE " &
123                       "AN EXCEPTION" );
124             IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
125                  COMMENT ("SHOULDN'T BE HERE!");
126             END IF;
127        EXCEPTION
128             WHEN CONSTRAINT_ERROR =>
129                  COMMENT ("CONSTRAINT_ERROR RAISED - 4");
130             WHEN OTHERS =>
131                  FAILED ( "THE EXPRESSION '0.0 ** I3' RAISED THE " &
132                           "WRONG EXCEPTION" );
133        END;
134
135        BEGIN
136             F := 0.0 ** (IDENT_INT (I3));
137             FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (I3))' DID " &
138                      "NOT RAISE AN EXCEPTION" );
139             IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
140                  COMMENT ("SHOULDN'T BE HERE!");
141             END IF;
142        EXCEPTION
143             WHEN CONSTRAINT_ERROR =>
144                  COMMENT ("CONSTRAINT_ERROR RAISED - 5");
145             WHEN OTHERS =>
146                  FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (I3))' " &
147                            "RAISED THE WRONG EXCEPTION" );
148        END;
149
150        BEGIN
151             F := IDENT (0.0) ** SI5;
152             FAILED ( "THE EXPRESSION '0.0 ** SI5' DID NOT RAISE " &
153                       "AN EXCEPTION" );
154             IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
155                  COMMENT ("SHOULDN'T BE HERE!");
156             END IF;
157        EXCEPTION
158             WHEN CONSTRAINT_ERROR =>
159                  COMMENT ("CONSTRAINT_ERROR RAISED - 6");
160             WHEN OTHERS =>
161                  FAILED ( "THE EXPRESSION '0.0 ** SI5' RAISED THE " &
162                           "WRONG EXCEPTION" );
163        END;
164
165        BEGIN
166             F := 0.0 ** (IDENT_INT (SI5));
167             FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (SI5))' DID " &
168                      "NOT RAISE AN EXCEPTION" );
169             IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
170                  COMMENT ("SHOULDN'T BE HERE!");
171             END IF;
172        EXCEPTION
173             WHEN CONSTRAINT_ERROR =>
174                  COMMENT ("CONSTRAINT_ERROR RAISED - 7");
175             WHEN OTHERS =>
176                  FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (SI5))' " &
177                            "RAISED THE WRONG EXCEPTION" );
178        END;
179
180     END IF;
181
182     RESULT;
183
184END C4A012B;
185