1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
# Test mpfr's sprintf() and snprintf() functions with "%a" formatting.
# I assume that Rmpfr_printf() and Rmpfr_fprintf() will handle this formatting
# in exactly the same way. Tests involving Rmpfr_printf() and Rmpfr_fprintf()
# will be added if evidence contrary to my assumption arises.
# I think that trailing mantissa zeros are frowned upon, but these tests will
# accept them.
# On windows, gmp_sprintf() presents the trailing zeroes.
#
# Also we test nv2mpfr() as that sub is used by Rmpfr_*printf in these tests
# if WIN32_FMT_BUG is set. In such instances, 'Rmpfr_printf("%a", $nv)' will
# be replaced by "Rmpfr_printf("%Ra", nv2mpfr($nv)' - and similarly for the
# other Rmpfr_*printf() functions.
use strict;
use warnings;
use Config;
use Math::MPFR qw(:mpfr);
use Test::More;
my $nv = 1.0078125; # 0x1.02p+0
my $obj = Math::MPFR->new($nv);
my $buflen = 16;
my ($buf, $ret);
# 0x1.02p+0 == 0x2.04p-1 == 0x4.08p-2 == 0x8.1p-3;
# Allow for any one of them to appear at any time.
# In the sprintf tests:
# "%a%: ^0x1\.02(0+)?p\+0$|^0x2\.04(0+)?p\-1$|^0x4\.08(0+)?p\-2$|^0x8\.1(0+)?p\-3$
# "%A": ^0X1\.02(0+)?P\+0$|^0X2\.04(0+)?P\-1$|^0X4\.08(0+)?P\-2$|^0X8\.1(0+)?P\-3$
#In the snprintf tests:
# "%a": ^0x1\.0$|^0x2\.0$|^0x4\.0$|^0x8\.1$
# "%A": ^0X1\.0$|^0X2\.0$|^0X4\.0$|^0X8\.1$
### nv2mpfr tests
my $s = '1.3';
my $nv2mpfr = 1.3;
my $op = Math::MPFR->new(1.3);
cmp_ok(nv2mpfr($nv2mpfr), '==', $nv2mpfr, "equivalence holds for all NV precisions");
if($Config{nvsize} == 8) {
cmp_ok(nv2mpfr($s), '==', $s, "string equivalence holds for 'double' precision");
cmp_ok(nv2mpfr($op), '==', $op, "mpfr object equivalence holds for 'double' precision");
}
else {
cmp_ok(nv2mpfr($s), '!=', $s, "no string equivalence for non 'double' precision");
cmp_ok(nv2mpfr($op), '==', $op, "no mpfr object equivalence for non 'double' precision");
}
### sprintf tests on NV
if($Config{nvtype} eq 'double') {
# "%a"/"%A" formatting of an NV is not expected to work
# unless $Config{nvtype} is 'double'.
$ret = Rmpfr_sprintf($buf, "%a", $nv, 16);
like($buf, qr/^0x1.02(0+)?p\+0$|^0x2\.04p\-1$|^0x4\.08p\-2$|^0x8\.1p\-3$/, "\"%a\" (mpfr) formatting of NV as expected");
cmp_ok($ret, '==', length($buf), "\"%a\" (mpfr) formatting of NV returned correct value");
$ret = Rmpfr_sprintf($buf, "%A", $nv, 16);
like($buf, qr/^0X1.02(0+)?P\+0$|^0X2\.04P\-1$|^0X4\.08P\-2$|^0X8\.1P\-3$/, "\"%A\" (mpfr) formatting of NV as expected");
cmp_ok($ret, '==', length($buf), "\"%A\" (mpfr) formatting of NV returned correct value");
}
if($Config{nvtype} eq 'long double') {
# "%La"/"%LA" formatting of an NV is not expected to work
# unless $Config{nvtype} is 'long double'.
$ret = Rmpfr_sprintf($buf, "%La", $nv, 16);
like($buf, qr/^0x1\.02(0+)?p\+0$|^0x2\.04(0+)?p\-1$|^0x4\.08(0+)?p\-2$|^0x8\.1(0+)?p\-3$/, "\"%La\" formatting of NV as expected");
cmp_ok($ret, '==', length($buf), "\"%La\" formatting of NV returned correct value");
$ret = Rmpfr_sprintf($buf, "%LA", $nv, 16);
like($buf, qr/^0X1\.02(0+)?P\+0$|^0X2\.04(0+)?P\-1$|^0X4\.08(0+)?P\-2$|^0X8\.1(0+)?P\-3$/, "\"%LA\" formatting of NV as expected");
cmp_ok($ret, '==', length($buf), "\"%LA\" formatting of NV returned correct value");
}
### sprintf tests on MPFR object
$ret = Rmpfr_sprintf($buf, "%Ra", $obj, 16);
cmp_ok($buf, 'eq', '0x1.02p+0', "\"%a\" formatting of MPFR object as expected");
cmp_ok($ret, '==', length($buf), "\"%a\" formatting of MPFR object returned correct value");
$ret = Rmpfr_sprintf($buf, "%RA", $obj, 16);
cmp_ok($buf, 'eq', '0X1.02P+0', "\"%A\" formatting of MPFR object as expected");
cmp_ok($ret, '==', length($buf), "\"%A\" formatting of MPFR object returned correct value");
################################################################
################################################################
### snprintf tests on NV
if($Config{nvtype} eq 'double') {
# "%a"/"%A" formatting of an NV is not expected to work
# unless $Config{nvtype} is 'double'.
$ret = Rmpfr_snprintf($buf, 6, "%a", $nv, 16);
like($buf, qr/^0x1\.0$|^0x2\.0$|^0x4\.0$|^0x8\.1$/, "\"%a\" (snprintf) formatting of NV as expected");
my $expectation = 9;
$expectation = 8 if $buf =~ /^0x8/i;
cmp_ok($ret, '==', $expectation, "\"%a\" (snprintf) formatting of NV returned correct value");
$ret = Rmpfr_snprintf($buf, 6, "%A", $nv, 16);
like($buf, qr/^0X1\.0$|^0X2\.0$|^0X4\.0$|^0X8\.1$/, "\"%A\" (snprintf) formatting of NV as expected");
$expectation = 9;
$expectation = 8 if $buf =~ /^0x8/i;
cmp_ok($ret, '==', $expectation, "\"%A\" (snprintf) formatting of NV returned correct value");
}
if($Config{nvtype} eq 'long double') {
# "%La"/"%LA" formatting of an NV is not expected to work
# unless $Config{nvtype} is 'long double'.
my $returned = 9;
$ret = Rmpfr_snprintf($buf, 6, "%La", $nv, 16);
like($buf, qr/^0x1\.0$|^0x2\.0$|^0x4\.0$|^0x8\.1$/, "\"%La\" (mpfr snprintf) formatting of NV as expected");
$returned = 8 if $buf =~ /0x8/i;
cmp_ok($ret, '==', $returned, "\"%La\" (mpfr snprintf) formatting of NV returned correct value");
$ret = Rmpfr_snprintf($buf, 6, "%LA", $nv, 16);
like($buf, qr/^0X1\.0$|^0X2\.0$|^0X4\.0$|^0X8\.1$/, "\"%LA\" (mpfr snprintf) formatting of NV as expected");
cmp_ok($ret, '==', $returned, "\"%LA\" (snprintf) formatting of NV returned correct value");
}
### snprintf tests on MPFR object
$ret = Rmpfr_snprintf($buf, 6, "%Ra", $obj, 16);
cmp_ok($buf, 'eq', '0x1.0', "\"%a\" (snprintf) formatting of MPFR object as expected");
cmp_ok($ret, '==', 9, "\"%a\" (snprintf) formatting of MPFR object returned correct value");
$ret = Rmpfr_snprintf($buf, 6, "%RA", $obj, 16);
cmp_ok($buf, 'eq', '0X1.0', "\"%A\" (snprintf) formatting of MPFR object as expected");
cmp_ok($ret, '==', 9, "\"%A\" (snprintf) formatting of MPFR object returned correct value");
################################################################
################################################################
# "%a" formatting error tests
unless($Config{nvtype} eq 'double') {
eval { Rmpfr_sprintf($buf, " %%A %a %% ", $nv, 16) };
like($@, qr/"%a" formatting applies only to doubles/, '"%a" formatting allowed only for doubles');
eval { Rmpfr_sprintf($buf, " %%a %A %% ", $nv, 16) };
like($@, qr/"%A" formatting applies only to doubles/, '"%A" formatting allowed only for doubles');
}
unless($Config{nvtype} eq 'long double') {
eval { Rmpfr_sprintf($buf, " %%LA %La %% ", $nv, 16) };
like($@, qr/"%La" formatting applies only to long doubles/, '"%La" formatting allowed only for long doubles');
eval { Rmpfr_sprintf($buf, " %%La %LA %% ", $nv, 16) };
like($@, qr/"%LA" formatting applies only to long doubles/, '"%LA" formatting allowed only for long doubles');
}
eval { Rmpfr_sprintf($buf, " %%a %A %% ", Math::MPFR->new($nv), 16) };
like($@, qr/"%A" formatting applies only to NVs/, '"%A" formatting disallowed for Math::MPFR objects');
done_testing();
|
