1 |
149 |
jeremybenn |
-- C490001.A
|
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 |
|
|
--
|
26 |
|
|
-- OBJECTIVE:
|
27 |
|
|
-- Check that, for a real static expression that is not part of a larger
|
28 |
|
|
-- static expression, and whose expected type T is a floating point type
|
29 |
|
|
-- that is not a descendant of a formal scalar type, the value is rounded
|
30 |
|
|
-- to the nearest machine number of T if T'Machine_Rounds is true, and is
|
31 |
|
|
-- truncated otherwise. Check that if rounding is performed, and the value
|
32 |
|
|
-- is exactly halfway between two machine numbers, one of the two machine
|
33 |
|
|
-- numbers is used.
|
34 |
|
|
--
|
35 |
|
|
-- TEST DESCRIPTION:
|
36 |
|
|
-- The test obtains a machine number M1 for a floating point subtype S by
|
37 |
|
|
-- passing a real literal to S'Machine. It then obtains an adjacent
|
38 |
|
|
-- machine number M2 by using S'Succ (or S'Pred). It then constructs
|
39 |
|
|
-- values which lie between these two machine numbers: one (A) which is
|
40 |
|
|
-- closer to M1, one (B) which is exactly halfway between M1 and M2, and
|
41 |
|
|
-- one (C) which is closer to M2. This is done for both positive and
|
42 |
|
|
-- negative machine numbers.
|
43 |
|
|
--
|
44 |
|
|
-- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true,
|
45 |
|
|
-- C must be rounded to M2, A must be rounded to M1, and B must be rounded
|
46 |
|
|
-- to either M1 or M2. If S'Machine_Rounds is false, all the values must
|
47 |
|
|
-- be truncated to M1.
|
48 |
|
|
--
|
49 |
|
|
-- A, B, and C are constructed using the following static expressions:
|
50 |
|
|
--
|
51 |
|
|
-- A: constant S := M1 + (M2 - M1)*Z; -- Z slightly less than 0.5.
|
52 |
|
|
-- B: constant S := M1 + (M2 - M1)*Z; -- Z equals 0.5.
|
53 |
|
|
-- C: constant S := M1 + (M2 - M1)*Z; -- Z slightly more than 0.5.
|
54 |
|
|
--
|
55 |
|
|
-- Since these are static expressions, they must be evaluated exactly,
|
56 |
|
|
-- and no rounding may occur until the final result is calculated.
|
57 |
|
|
--
|
58 |
|
|
-- The checks for equality between the members of (A, B, C) and (M1, M2)
|
59 |
|
|
-- are performed at run-time within the body of a subprogram.
|
60 |
|
|
--
|
61 |
|
|
-- The test performs additional checks that the rounding performed on
|
62 |
|
|
-- real literals is consistent for a floating point subtype. A literal is
|
63 |
|
|
-- assigned to a constant of a floating point subtype S. The same literal
|
64 |
|
|
-- is then passed to a subprogram, along with the constant, and an
|
65 |
|
|
-- equality check is performed within the body of the subprogram.
|
66 |
|
|
--
|
67 |
|
|
--
|
68 |
|
|
-- CHANGE HISTORY:
|
69 |
|
|
-- 25 Sep 95 SAIC Initial prerelease version.
|
70 |
|
|
-- 25 May 01 RLB Repaired to work with the repeal of the round away
|
71 |
|
|
-- rule by AI-268.
|
72 |
|
|
--
|
73 |
|
|
--!
|
74 |
|
|
|
75 |
|
|
with System;
|
76 |
|
|
package C490001_0 is
|
77 |
|
|
|
78 |
|
|
type My_Flt is digits System.Max_Digits;
|
79 |
|
|
|
80 |
|
|
procedure Float_Subtest (A, B: in My_Flt; Msg: in String);
|
81 |
|
|
|
82 |
|
|
procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String);
|
83 |
|
|
|
84 |
|
|
|
85 |
|
|
--
|
86 |
|
|
-- Positive cases:
|
87 |
|
|
--
|
88 |
|
|
|
89 |
|
|
-- |----|-------------|-----------------|-------------------|-----------|
|
90 |
|
|
-- | | | | | |
|
91 |
|
|
-- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2
|
92 |
|
|
|
93 |
|
|
|
94 |
|
|
Positive_Float : constant My_Flt := 12.440193950021943;
|
95 |
|
|
|
96 |
|
|
-- The literal value 12.440193950021943 is rounded up or down to the
|
97 |
|
|
-- nearest machine number of My_Flt when Positive_Float is initialized.
|
98 |
|
|
-- The value of Positive_Float should therefore be a machine number, and
|
99 |
|
|
-- the use of 'Machine in the initialization of P_M1 will be redundant for
|
100 |
|
|
-- a correct implementation. It's done anyway to make certain that P_M1 is
|
101 |
|
|
-- a machine number, independent of whether an implementation correctly
|
102 |
|
|
-- performs rounding.
|
103 |
|
|
|
104 |
|
|
P_M1 : constant My_Flt := My_Flt'Machine(Positive_Float);
|
105 |
|
|
P_M2 : constant My_Flt := My_Flt'Succ(P_M1);
|
106 |
|
|
|
107 |
|
|
-- P_M1 and P_M2 are adjacent machine numbers. Note that because it is not
|
108 |
|
|
-- certain whether 12.440193950021943 is a machine number, nor whether
|
109 |
|
|
-- 'Machine rounds it up or down, 12.440193950021943 may not lie between
|
110 |
|
|
-- P_M1 and P_M2. The test does not depend on this information, however;
|
111 |
|
|
-- the literal is only used as a "seed" to obtain the machine numbers.
|
112 |
|
|
|
113 |
|
|
|
114 |
|
|
-- The following entities are used to verify that rounding is performed
|
115 |
|
|
-- according to the value of 'Machine_Rounds. If language rules are
|
116 |
|
|
-- obeyed, the intermediate expressions in the following static
|
117 |
|
|
-- initialization expressions will not be rounded; all calculations will
|
118 |
|
|
-- be performed exactly. The final result, however, will be rounded to
|
119 |
|
|
-- a machine number (either P_M1 or P_M2, depending on the value of
|
120 |
|
|
-- My_Flt'Machine_Rounds). Thus, the value of each constant below will
|
121 |
|
|
-- equal that of P_M1 or P_M2.
|
122 |
|
|
|
123 |
|
|
Less_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*2.9/6.0);
|
124 |
|
|
Pos_Exactly_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)/2.0);
|
125 |
|
|
More_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*4.6/9.0);
|
126 |
|
|
|
127 |
|
|
|
128 |
|
|
--
|
129 |
|
|
-- Negative cases:
|
130 |
|
|
--
|
131 |
|
|
|
132 |
|
|
-- -|-------------|-----------------|-------------------|-----------|----|
|
133 |
|
|
-- | | | | | |
|
134 |
|
|
-- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0
|
135 |
|
|
|
136 |
|
|
|
137 |
|
|
-- The descriptions for the positive cases above apply to the negative
|
138 |
|
|
-- cases below as well. Note that, for N_M2, 'Pred is used rather than
|
139 |
|
|
-- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1.
|
140 |
|
|
|
141 |
|
|
Negative_Float : constant My_Flt := -0.692074550952117;
|
142 |
|
|
|
143 |
|
|
|
144 |
|
|
N_M1 : constant My_Flt := My_Flt'Machine(Negative_Float);
|
145 |
|
|
N_M2 : constant My_Flt := My_Flt'Pred(N_M1);
|
146 |
|
|
|
147 |
|
|
More_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*4.1/8.0);
|
148 |
|
|
Neg_Exactly_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)/2.0);
|
149 |
|
|
Less_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*2.4/5.0);
|
150 |
|
|
|
151 |
|
|
end C490001_0;
|
152 |
|
|
|
153 |
|
|
|
154 |
|
|
--==================================================================--
|
155 |
|
|
|
156 |
|
|
|
157 |
|
|
with TCTouch;
|
158 |
|
|
package body C490001_0 is
|
159 |
|
|
|
160 |
|
|
procedure Float_Subtest (A, B: in My_Flt; Msg: in String) is
|
161 |
|
|
begin
|
162 |
|
|
TCTouch.Assert (A = B, Msg);
|
163 |
|
|
end Float_Subtest;
|
164 |
|
|
|
165 |
|
|
procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String) is
|
166 |
|
|
begin
|
167 |
|
|
TCTouch.Assert (A = B or A = C, Msg);
|
168 |
|
|
end Float_Subtest;
|
169 |
|
|
|
170 |
|
|
end C490001_0;
|
171 |
|
|
|
172 |
|
|
|
173 |
|
|
--==================================================================--
|
174 |
|
|
|
175 |
|
|
|
176 |
|
|
with C490001_0; -- Floating point support.
|
177 |
|
|
use C490001_0;
|
178 |
|
|
|
179 |
|
|
with Report;
|
180 |
|
|
procedure C490001 is
|
181 |
|
|
begin
|
182 |
|
|
Report.Test ("C490001", "Rounding of real static expressions: " &
|
183 |
|
|
"floating point subtypes");
|
184 |
|
|
|
185 |
|
|
|
186 |
|
|
-- Check that rounding direction is consistent for literals:
|
187 |
|
|
|
188 |
|
|
Float_Subtest (12.440193950021943, P_M1, "Positive Float: literal");
|
189 |
|
|
Float_Subtest (-0.692074550952117, N_M1, "Negative Float: literal");
|
190 |
|
|
|
191 |
|
|
|
192 |
|
|
-- Now check that rounding is performed correctly for values between
|
193 |
|
|
-- machine numbers, according to the value of 'Machine_Rounds:
|
194 |
|
|
|
195 |
|
|
if My_Flt'Machine_Rounds then
|
196 |
|
|
Float_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Float: = half");
|
197 |
|
|
Float_Subtest (More_Pos_Than_Half, P_M2, "Positive Float: > half");
|
198 |
|
|
Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half");
|
199 |
|
|
|
200 |
|
|
Float_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Float: = half");
|
201 |
|
|
Float_Subtest (More_Neg_Than_Half, N_M2, "Negative Float: > half");
|
202 |
|
|
Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half");
|
203 |
|
|
else
|
204 |
|
|
Float_Subtest (Pos_Exactly_Half, P_M1, "Positive Float: = half");
|
205 |
|
|
Float_Subtest (More_Pos_Than_Half, P_M1, "Positive Float: > half");
|
206 |
|
|
Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half");
|
207 |
|
|
|
208 |
|
|
Float_Subtest (Neg_Exactly_Half, N_M1, "Negative Float: = half");
|
209 |
|
|
Float_Subtest (More_Neg_Than_Half, N_M1, "Negative Float: > half");
|
210 |
|
|
Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half");
|
211 |
|
|
end if;
|
212 |
|
|
|
213 |
|
|
|
214 |
|
|
Report.Result;
|
215 |
|
|
end C490001;
|