File Coverage

blib/lib/Math/Decimal64.pm
Criterion Covered Total %
statement 225 349 64.4
branch 139 224 62.0
condition 43 84 51.1
subroutine 30 38 78.9
pod 0 22 0.0
total 437 717 60.9


line stmt bran cond sub pod time code
1             ## This file generated by InlineX::C2XS (version 0.22) using Inline::C (version 0.5002)
2             package Math::Decimal64;
3              
4 36     36   19899 use 5.006;
  36         124  
5              
6 36     36   168 use warnings;
  36         75  
  36         731  
7 36     36   145 use strict;
  36         65  
  36         512  
8 36     36   147 use Config; # So MEtoD64 can check whether sizeof(longdouble) > 8.
  36         103  
  36         2596  
9              
10             require Exporter;
11             *import = \&Exporter::import;
12             require DynaLoader;
13              
14             our $VERSION = '0.16';
15             #$VERSION = eval $VERSION;
16              
17 36     36   16050 use subs qw(DEC64_MAX DEC64_MIN);
  36         727  
  36         173  
18              
19             DynaLoader::bootstrap Math::Decimal64 $Math::Decimal64::VERSION;
20              
21             @Math::Decimal64::EXPORT = ();
22             @Math::Decimal64::EXPORT_OK = qw(
23             MEtoD64 UVtoD64 IVtoD64 NVtoD64 PVtoD64 STRtoD64 D64toME D64toNV
24             FR64toME pFR D64toFSTR D64toRSTR
25             InfD64 NaND64 UnityD64 ZeroD64 is_InfD64 is_NaND64 is_ZeroD64
26             D64toLD LDtoD64 DEC64_MAX DEC64_MIN
27             assignME assignInf assignNaN assignPV Exp10 have_strtod64
28             assignIV assignUV assignNV assignD64
29             decode_d64 decode_bid decode_dpd d64_bytes hex2bin d64_fmt
30             get_sign get_exp PVtoME MEtoPV assignDPD DPDtoD64
31             );
32              
33             %Math::Decimal64::EXPORT_TAGS = (all => [qw(
34             MEtoD64 UVtoD64 IVtoD64 NVtoD64 PVtoD64 STRtoD64 D64toME D64toNV
35             FR64toME pFR D64toFSTR D64toRSTR
36             InfD64 NaND64 UnityD64 ZeroD64 is_InfD64 is_NaND64 is_ZeroD64
37             D64toLD LDtoD64 DEC64_MAX DEC64_MIN
38             assignME assignInf assignNaN assignPV Exp10 have_strtod64
39             assignIV assignUV assignNV assignD64
40             decode_d64 decode_bid decode_dpd d64_bytes hex2bin d64_fmt
41             get_sign get_exp PVtoME MEtoPV assignDPD DPDtoD64
42             )]);
43              
44             use overload
45 36         497 '+' => \&_overload_add,
46             '*' => \&_overload_mul,
47             '-' => \&_overload_sub,
48             '/' => \&_overload_div,
49             '+=' => \&_overload_add_eq,
50             '*=' => \&_overload_mul_eq,
51             '-=' => \&_overload_sub_eq,
52             '/=' => \&_overload_div_eq,
53             '""' => \&_overload_string,
54             '==' => \&_overload_equiv,
55             '!=' => \&_overload_not_equiv,
56             '<' => \&_overload_lt,
57             '>' => \&_overload_gt,
58             '<=' => \&_overload_lte,
59             '>=' => \&_overload_gte,
60             '<=>' => \&_overload_spaceship,
61             '=' => \&_overload_copy,
62             '!' => \&_overload_not,
63             'bool' => \&_overload_true,
64             'abs' => \&_overload_abs,
65             '++' => \&_overload_inc,
66             '--' => \&_overload_dec,
67             'int' => \&_overload_int,
68             'neg' => \&_overload_neg,
69 36     36   42198 ;
  36         30202  
70              
71             #######################################################################
72             #######################################################################
73              
74             $Math::Decimal64::nan_str = unpack("a*", pack( "B*", '011111' . ('0' x 58)));
75             $Math::Decimal64::ninf_str = unpack("a*", pack( "B*", '11111' . ('0' x 59)));
76             $Math::Decimal64::pinf_str = unpack("a*", pack( "B*", '01111' . ('0' x 59)));
77             $Math::Decimal64::fmt = d64_fmt();
78             $Math::Decimal64::NNW = 0; # set to 1 to enable a non-numeric warning whenever
79             # a string containing any non-numeric characters is
80             # treated as a number.
81              
82             #######################################################################
83             #######################################################################
84              
85             %Math::Decimal64::dpd_encode = $Math::Decimal64::fmt eq 'DPD' ? (
86             '0000000000' => '000', '0000000001' => '001', '0000000010' => '002', '0000000011' => '003',
87             '0000000100' => '004', '0000000101' => '005', '0000000110' => '006', '0000000111' => '007',
88             '0000001000' => '008', '0000001001' => '009', '0000010000' => '010', '0000010001' => '011',
89             '0000010010' => '012', '0000010011' => '013', '0000010100' => '014', '0000010101' => '015',
90             '0000010110' => '016', '0000010111' => '017', '0000011000' => '018', '0000011001' => '019',
91             '0000100000' => '020', '0000100001' => '021', '0000100010' => '022', '0000100011' => '023',
92             '0000100100' => '024', '0000100101' => '025', '0000100110' => '026', '0000100111' => '027',
93             '0000101000' => '028', '0000101001' => '029', '0000110000' => '030', '0000110001' => '031',
94             '0000110010' => '032', '0000110011' => '033', '0000110100' => '034', '0000110101' => '035',
95             '0000110110' => '036', '0000110111' => '037', '0000111000' => '038', '0000111001' => '039',
96             '0001000000' => '040', '0001000001' => '041', '0001000010' => '042', '0001000011' => '043',
97             '0001000100' => '044', '0001000101' => '045', '0001000110' => '046', '0001000111' => '047',
98             '0001001000' => '048', '0001001001' => '049', '0001010000' => '050', '0001010001' => '051',
99             '0001010010' => '052', '0001010011' => '053', '0001010100' => '054', '0001010101' => '055',
100             '0001010110' => '056', '0001010111' => '057', '0001011000' => '058', '0001011001' => '059',
101             '0001100000' => '060', '0001100001' => '061', '0001100010' => '062', '0001100011' => '063',
102             '0001100100' => '064', '0001100101' => '065', '0001100110' => '066', '0001100111' => '067',
103             '0001101000' => '068', '0001101001' => '069', '0001110000' => '070', '0001110001' => '071',
104             '0001110010' => '072', '0001110011' => '073', '0001110100' => '074', '0001110101' => '075',
105             '0001110110' => '076', '0001110111' => '077', '0001111000' => '078', '0001111001' => '079',
106             '0000001010' => '080', '0000001011' => '081', '0000101010' => '082', '0000101011' => '083',
107             '0001001010' => '084', '0001001011' => '085', '0001101010' => '086', '0001101011' => '087',
108             '0001001110' => '088', '0001001111' => '089', '0000011010' => '090', '0000011011' => '091',
109             '0000111010' => '092', '0000111011' => '093', '0001011010' => '094', '0001011011' => '095',
110             '0001111010' => '096', '0001111011' => '097', '0001011110' => '098', '0001011111' => '099',
111             '0010000000' => '100', '0010000001' => '101', '0010000010' => '102', '0010000011' => '103',
112             '0010000100' => '104', '0010000101' => '105', '0010000110' => '106', '0010000111' => '107',
113             '0010001000' => '108', '0010001001' => '109', '0010010000' => '110', '0010010001' => '111',
114             '0010010010' => '112', '0010010011' => '113', '0010010100' => '114', '0010010101' => '115',
115             '0010010110' => '116', '0010010111' => '117', '0010011000' => '118', '0010011001' => '119',
116             '0010100000' => '120', '0010100001' => '121', '0010100010' => '122', '0010100011' => '123',
117             '0010100100' => '124', '0010100101' => '125', '0010100110' => '126', '0010100111' => '127',
118             '0010101000' => '128', '0010101001' => '129', '0010110000' => '130', '0010110001' => '131',
119             '0010110010' => '132', '0010110011' => '133', '0010110100' => '134', '0010110101' => '135',
120             '0010110110' => '136', '0010110111' => '137', '0010111000' => '138', '0010111001' => '139',
121             '0011000000' => '140', '0011000001' => '141', '0011000010' => '142', '0011000011' => '143',
122             '0011000100' => '144', '0011000101' => '145', '0011000110' => '146', '0011000111' => '147',
123             '0011001000' => '148', '0011001001' => '149', '0011010000' => '150', '0011010001' => '151',
124             '0011010010' => '152', '0011010011' => '153', '0011010100' => '154', '0011010101' => '155',
125             '0011010110' => '156', '0011010111' => '157', '0011011000' => '158', '0011011001' => '159',
126             '0011100000' => '160', '0011100001' => '161', '0011100010' => '162', '0011100011' => '163',
127             '0011100100' => '164', '0011100101' => '165', '0011100110' => '166', '0011100111' => '167',
128             '0011101000' => '168', '0011101001' => '169', '0011110000' => '170', '0011110001' => '171',
129             '0011110010' => '172', '0011110011' => '173', '0011110100' => '174', '0011110101' => '175',
130             '0011110110' => '176', '0011110111' => '177', '0011111000' => '178', '0011111001' => '179',
131             '0010001010' => '180', '0010001011' => '181', '0010101010' => '182', '0010101011' => '183',
132             '0011001010' => '184', '0011001011' => '185', '0011101010' => '186', '0011101011' => '187',
133             '0011001110' => '188', '0011001111' => '189', '0010011010' => '190', '0010011011' => '191',
134             '0010111010' => '192', '0010111011' => '193', '0011011010' => '194', '0011011011' => '195',
135             '0011111010' => '196', '0011111011' => '197', '0011011110' => '198', '0011011111' => '199',
136             '0100000000' => '200', '0100000001' => '201', '0100000010' => '202', '0100000011' => '203',
137             '0100000100' => '204', '0100000101' => '205', '0100000110' => '206', '0100000111' => '207',
138             '0100001000' => '208', '0100001001' => '209', '0100010000' => '210', '0100010001' => '211',
139             '0100010010' => '212', '0100010011' => '213', '0100010100' => '214', '0100010101' => '215',
140             '0100010110' => '216', '0100010111' => '217', '0100011000' => '218', '0100011001' => '219',
141             '0100100000' => '220', '0100100001' => '221', '0100100010' => '222', '0100100011' => '223',
142             '0100100100' => '224', '0100100101' => '225', '0100100110' => '226', '0100100111' => '227',
143             '0100101000' => '228', '0100101001' => '229', '0100110000' => '230', '0100110001' => '231',
144             '0100110010' => '232', '0100110011' => '233', '0100110100' => '234', '0100110101' => '235',
145             '0100110110' => '236', '0100110111' => '237', '0100111000' => '238', '0100111001' => '239',
146             '0101000000' => '240', '0101000001' => '241', '0101000010' => '242', '0101000011' => '243',
147             '0101000100' => '244', '0101000101' => '245', '0101000110' => '246', '0101000111' => '247',
148             '0101001000' => '248', '0101001001' => '249', '0101010000' => '250', '0101010001' => '251',
149             '0101010010' => '252', '0101010011' => '253', '0101010100' => '254', '0101010101' => '255',
150             '0101010110' => '256', '0101010111' => '257', '0101011000' => '258', '0101011001' => '259',
151             '0101100000' => '260', '0101100001' => '261', '0101100010' => '262', '0101100011' => '263',
152             '0101100100' => '264', '0101100101' => '265', '0101100110' => '266', '0101100111' => '267',
153             '0101101000' => '268', '0101101001' => '269', '0101110000' => '270', '0101110001' => '271',
154             '0101110010' => '272', '0101110011' => '273', '0101110100' => '274', '0101110101' => '275',
155             '0101110110' => '276', '0101110111' => '277', '0101111000' => '278', '0101111001' => '279',
156             '0100001010' => '280', '0100001011' => '281', '0100101010' => '282', '0100101011' => '283',
157             '0101001010' => '284', '0101001011' => '285', '0101101010' => '286', '0101101011' => '287',
158             '0101001110' => '288', '0101001111' => '289', '0100011010' => '290', '0100011011' => '291',
159             '0100111010' => '292', '0100111011' => '293', '0101011010' => '294', '0101011011' => '295',
160             '0101111010' => '296', '0101111011' => '297', '0101011110' => '298', '0101011111' => '299',
161             '0110000000' => '300', '0110000001' => '301', '0110000010' => '302', '0110000011' => '303',
162             '0110000100' => '304', '0110000101' => '305', '0110000110' => '306', '0110000111' => '307',
163             '0110001000' => '308', '0110001001' => '309', '0110010000' => '310', '0110010001' => '311',
164             '0110010010' => '312', '0110010011' => '313', '0110010100' => '314', '0110010101' => '315',
165             '0110010110' => '316', '0110010111' => '317', '0110011000' => '318', '0110011001' => '319',
166             '0110100000' => '320', '0110100001' => '321', '0110100010' => '322', '0110100011' => '323',
167             '0110100100' => '324', '0110100101' => '325', '0110100110' => '326', '0110100111' => '327',
168             '0110101000' => '328', '0110101001' => '329', '0110110000' => '330', '0110110001' => '331',
169             '0110110010' => '332', '0110110011' => '333', '0110110100' => '334', '0110110101' => '335',
170             '0110110110' => '336', '0110110111' => '337', '0110111000' => '338', '0110111001' => '339',
171             '0111000000' => '340', '0111000001' => '341', '0111000010' => '342', '0111000011' => '343',
172             '0111000100' => '344', '0111000101' => '345', '0111000110' => '346', '0111000111' => '347',
173             '0111001000' => '348', '0111001001' => '349', '0111010000' => '350', '0111010001' => '351',
174             '0111010010' => '352', '0111010011' => '353', '0111010100' => '354', '0111010101' => '355',
175             '0111010110' => '356', '0111010111' => '357', '0111011000' => '358', '0111011001' => '359',
176             '0111100000' => '360', '0111100001' => '361', '0111100010' => '362', '0111100011' => '363',
177             '0111100100' => '364', '0111100101' => '365', '0111100110' => '366', '0111100111' => '367',
178             '0111101000' => '368', '0111101001' => '369', '0111110000' => '370', '0111110001' => '371',
179             '0111110010' => '372', '0111110011' => '373', '0111110100' => '374', '0111110101' => '375',
180             '0111110110' => '376', '0111110111' => '377', '0111111000' => '378', '0111111001' => '379',
181             '0110001010' => '380', '0110001011' => '381', '0110101010' => '382', '0110101011' => '383',
182             '0111001010' => '384', '0111001011' => '385', '0111101010' => '386', '0111101011' => '387',
183             '0111001110' => '388', '0111001111' => '389', '0110011010' => '390', '0110011011' => '391',
184             '0110111010' => '392', '0110111011' => '393', '0111011010' => '394', '0111011011' => '395',
185             '0111111010' => '396', '0111111011' => '397', '0111011110' => '398', '0111011111' => '399',
186             '1000000000' => '400', '1000000001' => '401', '1000000010' => '402', '1000000011' => '403',
187             '1000000100' => '404', '1000000101' => '405', '1000000110' => '406', '1000000111' => '407',
188             '1000001000' => '408', '1000001001' => '409', '1000010000' => '410', '1000010001' => '411',
189             '1000010010' => '412', '1000010011' => '413', '1000010100' => '414', '1000010101' => '415',
190             '1000010110' => '416', '1000010111' => '417', '1000011000' => '418', '1000011001' => '419',
191             '1000100000' => '420', '1000100001' => '421', '1000100010' => '422', '1000100011' => '423',
192             '1000100100' => '424', '1000100101' => '425', '1000100110' => '426', '1000100111' => '427',
193             '1000101000' => '428', '1000101001' => '429', '1000110000' => '430', '1000110001' => '431',
194             '1000110010' => '432', '1000110011' => '433', '1000110100' => '434', '1000110101' => '435',
195             '1000110110' => '436', '1000110111' => '437', '1000111000' => '438', '1000111001' => '439',
196             '1001000000' => '440', '1001000001' => '441', '1001000010' => '442', '1001000011' => '443',
197             '1001000100' => '444', '1001000101' => '445', '1001000110' => '446', '1001000111' => '447',
198             '1001001000' => '448', '1001001001' => '449', '1001010000' => '450', '1001010001' => '451',
199             '1001010010' => '452', '1001010011' => '453', '1001010100' => '454', '1001010101' => '455',
200             '1001010110' => '456', '1001010111' => '457', '1001011000' => '458', '1001011001' => '459',
201             '1001100000' => '460', '1001100001' => '461', '1001100010' => '462', '1001100011' => '463',
202             '1001100100' => '464', '1001100101' => '465', '1001100110' => '466', '1001100111' => '467',
203             '1001101000' => '468', '1001101001' => '469', '1001110000' => '470', '1001110001' => '471',
204             '1001110010' => '472', '1001110011' => '473', '1001110100' => '474', '1001110101' => '475',
205             '1001110110' => '476', '1001110111' => '477', '1001111000' => '478', '1001111001' => '479',
206             '1000001010' => '480', '1000001011' => '481', '1000101010' => '482', '1000101011' => '483',
207             '1001001010' => '484', '1001001011' => '485', '1001101010' => '486', '1001101011' => '487',
208             '1001001110' => '488', '1001001111' => '489', '1000011010' => '490', '1000011011' => '491',
209             '1000111010' => '492', '1000111011' => '493', '1001011010' => '494', '1001011011' => '495',
210             '1001111010' => '496', '1001111011' => '497', '1001011110' => '498', '1001011111' => '499',
211             '1010000000' => '500', '1010000001' => '501', '1010000010' => '502', '1010000011' => '503',
212             '1010000100' => '504', '1010000101' => '505', '1010000110' => '506', '1010000111' => '507',
213             '1010001000' => '508', '1010001001' => '509', '1010010000' => '510', '1010010001' => '511',
214             '1010010010' => '512', '1010010011' => '513', '1010010100' => '514', '1010010101' => '515',
215             '1010010110' => '516', '1010010111' => '517', '1010011000' => '518', '1010011001' => '519',
216             '1010100000' => '520', '1010100001' => '521', '1010100010' => '522', '1010100011' => '523',
217             '1010100100' => '524', '1010100101' => '525', '1010100110' => '526', '1010100111' => '527',
218             '1010101000' => '528', '1010101001' => '529', '1010110000' => '530', '1010110001' => '531',
219             '1010110010' => '532', '1010110011' => '533', '1010110100' => '534', '1010110101' => '535',
220             '1010110110' => '536', '1010110111' => '537', '1010111000' => '538', '1010111001' => '539',
221             '1011000000' => '540', '1011000001' => '541', '1011000010' => '542', '1011000011' => '543',
222             '1011000100' => '544', '1011000101' => '545', '1011000110' => '546', '1011000111' => '547',
223             '1011001000' => '548', '1011001001' => '549', '1011010000' => '550', '1011010001' => '551',
224             '1011010010' => '552', '1011010011' => '553', '1011010100' => '554', '1011010101' => '555',
225             '1011010110' => '556', '1011010111' => '557', '1011011000' => '558', '1011011001' => '559',
226             '1011100000' => '560', '1011100001' => '561', '1011100010' => '562', '1011100011' => '563',
227             '1011100100' => '564', '1011100101' => '565', '1011100110' => '566', '1011100111' => '567',
228             '1011101000' => '568', '1011101001' => '569', '1011110000' => '570', '1011110001' => '571',
229             '1011110010' => '572', '1011110011' => '573', '1011110100' => '574', '1011110101' => '575',
230             '1011110110' => '576', '1011110111' => '577', '1011111000' => '578', '1011111001' => '579',
231             '1010001010' => '580', '1010001011' => '581', '1010101010' => '582', '1010101011' => '583',
232             '1011001010' => '584', '1011001011' => '585', '1011101010' => '586', '1011101011' => '587',
233             '1011001110' => '588', '1011001111' => '589', '1010011010' => '590', '1010011011' => '591',
234             '1010111010' => '592', '1010111011' => '593', '1011011010' => '594', '1011011011' => '595',
235             '1011111010' => '596', '1011111011' => '597', '1011011110' => '598', '1011011111' => '599',
236             '1100000000' => '600', '1100000001' => '601', '1100000010' => '602', '1100000011' => '603',
237             '1100000100' => '604', '1100000101' => '605', '1100000110' => '606', '1100000111' => '607',
238             '1100001000' => '608', '1100001001' => '609', '1100010000' => '610', '1100010001' => '611',
239             '1100010010' => '612', '1100010011' => '613', '1100010100' => '614', '1100010101' => '615',
240             '1100010110' => '616', '1100010111' => '617', '1100011000' => '618', '1100011001' => '619',
241             '1100100000' => '620', '1100100001' => '621', '1100100010' => '622', '1100100011' => '623',
242             '1100100100' => '624', '1100100101' => '625', '1100100110' => '626', '1100100111' => '627',
243             '1100101000' => '628', '1100101001' => '629', '1100110000' => '630', '1100110001' => '631',
244             '1100110010' => '632', '1100110011' => '633', '1100110100' => '634', '1100110101' => '635',
245             '1100110110' => '636', '1100110111' => '637', '1100111000' => '638', '1100111001' => '639',
246             '1101000000' => '640', '1101000001' => '641', '1101000010' => '642', '1101000011' => '643',
247             '1101000100' => '644', '1101000101' => '645', '1101000110' => '646', '1101000111' => '647',
248             '1101001000' => '648', '1101001001' => '649', '1101010000' => '650', '1101010001' => '651',
249             '1101010010' => '652', '1101010011' => '653', '1101010100' => '654', '1101010101' => '655',
250             '1101010110' => '656', '1101010111' => '657', '1101011000' => '658', '1101011001' => '659',
251             '1101100000' => '660', '1101100001' => '661', '1101100010' => '662', '1101100011' => '663',
252             '1101100100' => '664', '1101100101' => '665', '1101100110' => '666', '1101100111' => '667',
253             '1101101000' => '668', '1101101001' => '669', '1101110000' => '670', '1101110001' => '671',
254             '1101110010' => '672', '1101110011' => '673', '1101110100' => '674', '1101110101' => '675',
255             '1101110110' => '676', '1101110111' => '677', '1101111000' => '678', '1101111001' => '679',
256             '1100001010' => '680', '1100001011' => '681', '1100101010' => '682', '1100101011' => '683',
257             '1101001010' => '684', '1101001011' => '685', '1101101010' => '686', '1101101011' => '687',
258             '1101001110' => '688', '1101001111' => '689', '1100011010' => '690', '1100011011' => '691',
259             '1100111010' => '692', '1100111011' => '693', '1101011010' => '694', '1101011011' => '695',
260             '1101111010' => '696', '1101111011' => '697', '1101011110' => '698', '1101011111' => '699',
261             '1110000000' => '700', '1110000001' => '701', '1110000010' => '702', '1110000011' => '703',
262             '1110000100' => '704', '1110000101' => '705', '1110000110' => '706', '1110000111' => '707',
263             '1110001000' => '708', '1110001001' => '709', '1110010000' => '710', '1110010001' => '711',
264             '1110010010' => '712', '1110010011' => '713', '1110010100' => '714', '1110010101' => '715',
265             '1110010110' => '716', '1110010111' => '717', '1110011000' => '718', '1110011001' => '719',
266             '1110100000' => '720', '1110100001' => '721', '1110100010' => '722', '1110100011' => '723',
267             '1110100100' => '724', '1110100101' => '725', '1110100110' => '726', '1110100111' => '727',
268             '1110101000' => '728', '1110101001' => '729', '1110110000' => '730', '1110110001' => '731',
269             '1110110010' => '732', '1110110011' => '733', '1110110100' => '734', '1110110101' => '735',
270             '1110110110' => '736', '1110110111' => '737', '1110111000' => '738', '1110111001' => '739',
271             '1111000000' => '740', '1111000001' => '741', '1111000010' => '742', '1111000011' => '743',
272             '1111000100' => '744', '1111000101' => '745', '1111000110' => '746', '1111000111' => '747',
273             '1111001000' => '748', '1111001001' => '749', '1111010000' => '750', '1111010001' => '751',
274             '1111010010' => '752', '1111010011' => '753', '1111010100' => '754', '1111010101' => '755',
275             '1111010110' => '756', '1111010111' => '757', '1111011000' => '758', '1111011001' => '759',
276             '1111100000' => '760', '1111100001' => '761', '1111100010' => '762', '1111100011' => '763',
277             '1111100100' => '764', '1111100101' => '765', '1111100110' => '766', '1111100111' => '767',
278             '1111101000' => '768', '1111101001' => '769', '1111110000' => '770', '1111110001' => '771',
279             '1111110010' => '772', '1111110011' => '773', '1111110100' => '774', '1111110101' => '775',
280             '1111110110' => '776', '1111110111' => '777', '1111111000' => '778', '1111111001' => '779',
281             '1110001010' => '780', '1110001011' => '781', '1110101010' => '782', '1110101011' => '783',
282             '1111001010' => '784', '1111001011' => '785', '1111101010' => '786', '1111101011' => '787',
283             '1111001110' => '788', '1111001111' => '789', '1110011010' => '790', '1110011011' => '791',
284             '1110111010' => '792', '1110111011' => '793', '1111011010' => '794', '1111011011' => '795',
285             '1111111010' => '796', '1111111011' => '797', '1111011110' => '798', '1111011111' => '799',
286             '0000001100' => '800', '0000001101' => '801', '0100001100' => '802', '0100001101' => '803',
287             '1000001100' => '804', '1000001101' => '805', '1100001100' => '806', '1100001101' => '807',
288             '0000101110' => '808', '0000101111' => '809', '0000011100' => '810', '0000011101' => '811',
289             '0100011100' => '812', '0100011101' => '813', '1000011100' => '814', '1000011101' => '815',
290             '1100011100' => '816', '1100011101' => '817', '0000111110' => '818', '0000111111' => '819',
291             '0000101100' => '820', '0000101101' => '821', '0100101100' => '822', '0100101101' => '823',
292             '1000101100' => '824', '1000101101' => '825', '1100101100' => '826', '1100101101' => '827',
293             '0100101110' => '828', '0100101111' => '829', '0000111100' => '830', '0000111101' => '831',
294             '0100111100' => '832', '0100111101' => '833', '1000111100' => '834', '1000111101' => '835',
295             '1100111100' => '836', '1100111101' => '837', '0100111110' => '838', '0100111111' => '839',
296             '0001001100' => '840', '0001001101' => '841', '0101001100' => '842', '0101001101' => '843',
297             '1001001100' => '844', '1001001101' => '845', '1101001100' => '846', '1101001101' => '847',
298             '1000101110' => '848', '1000101111' => '849', '0001011100' => '850', '0001011101' => '851',
299             '0101011100' => '852', '0101011101' => '853', '1001011100' => '854', '1001011101' => '855',
300             '1101011100' => '856', '1101011101' => '857', '1000111110' => '858', '1000111111' => '859',
301             '0001101100' => '860', '0001101101' => '861', '0101101100' => '862', '0101101101' => '863',
302             '1001101100' => '864', '1001101101' => '865', '1101101100' => '866', '1101101101' => '867',
303             '1100101110' => '868', '1100101111' => '869', '0001111100' => '870', '0001111101' => '871',
304             '0101111100' => '872', '0101111101' => '873', '1001111100' => '874', '1001111101' => '875',
305             '1101111100' => '876', '1101111101' => '877', '1100111110' => '878', '1100111111' => '879',
306             '0000001110' => '880', '0000001111' => '881', '0100001110' => '882', '0100001111' => '883',
307             '1000001110' => '884', '1000001111' => '885', '1100001110' => '886', '1100001111' => '887',
308             '0001101110' => '888', '0001101111' => '889', '0000011110' => '890', '0000011111' => '891',
309             '0100011110' => '892', '0100011111' => '893', '1000011110' => '894', '1000011111' => '895',
310             '1100011110' => '896', '1100011111' => '897', '0001111110' => '898', '0001111111' => '899',
311             '0010001100' => '900', '0010001101' => '901', '0110001100' => '902', '0110001101' => '903',
312             '1010001100' => '904', '1010001101' => '905', '1110001100' => '906', '1110001101' => '907',
313             '0010101110' => '908', '0010101111' => '909', '0010011100' => '910', '0010011101' => '911',
314             '0110011100' => '912', '0110011101' => '913', '1010011100' => '914', '1010011101' => '915',
315             '1110011100' => '916', '1110011101' => '917', '0010111110' => '918', '0010111111' => '919',
316             '0010101100' => '920', '0010101101' => '921', '0110101100' => '922', '0110101101' => '923',
317             '1010101100' => '924', '1010101101' => '925', '1110101100' => '926', '1110101101' => '927',
318             '0110101110' => '928', '0110101111' => '929', '0010111100' => '930', '0010111101' => '931',
319             '0110111100' => '932', '0110111101' => '933', '1010111100' => '934', '1010111101' => '935',
320             '1110111100' => '936', '1110111101' => '937', '0110111110' => '938', '0110111111' => '939',
321             '0011001100' => '940', '0011001101' => '941', '0111001100' => '942', '0111001101' => '943',
322             '1011001100' => '944', '1011001101' => '945', '1111001100' => '946', '1111001101' => '947',
323             '1010101110' => '948', '1010101111' => '949', '0011011100' => '950', '0011011101' => '951',
324             '0111011100' => '952', '0111011101' => '953', '1011011100' => '954', '1011011101' => '955',
325             '1111011100' => '956', '1111011101' => '957', '1010111110' => '958', '1010111111' => '959',
326             '0011101100' => '960', '0011101101' => '961', '0111101100' => '962', '0111101101' => '963',
327             '1011101100' => '964', '1011101101' => '965', '1111101100' => '966', '1111101101' => '967',
328             '1110101110' => '968', '1110101111' => '969', '0011111100' => '970', '0011111101' => '971',
329             '0111111100' => '972', '0111111101' => '973', '1011111100' => '974', '1011111101' => '975',
330             '1111111100' => '976', '1111111101' => '977', '1110111110' => '978', '1110111111' => '979',
331             '0010001110' => '980', '0010001111' => '981', '0110001110' => '982', '0110001111' => '983',
332             '1010001110' => '984', '1010001111' => '985', '1110001110' => '986', '1110001111' => '987',
333             '0011101110' => '988', '0011101111' => '989', '0010011110' => '990', '0010011111' => '991',
334             '0110011110' => '992', '0110011111' => '993', '1010011110' => '994', '1010011111' => '995',
335             '1110011110' => '996', '1110011111' => '997', '0011111110' => '998', '0011111111' => '999',
336             ) : ();
337              
338             #######################################################################
339             #######################################################################
340              
341             # %Math::Decimal64::dpd_decode is simply %Math::Decimal64::dpd_encode
342             # with the keys and values interchanged.
343              
344             for my $key(keys(%Math::Decimal64::dpd_encode)) {
345             $Math::Decimal64::dpd_decode{$Math::Decimal64::dpd_encode{$key}} = $key;
346             }
347              
348             #######################################################################
349             #######################################################################
350              
351             %Math::Decimal64::bid_decode = $Math::Decimal64::fmt eq 'BID' ? (
352             0 => MEtoD64('1' . ('0' x 15), 0), 1 => MEtoD64('1' . ('0' x 14), 0),
353             2 => MEtoD64('1' . ('0' x 13), 0), 3 => MEtoD64('1' . ('0' x 12), 0),
354             4 => MEtoD64('1' . ('0' x 11), 0), 5 => MEtoD64('1' . ('0' x 10), 0),
355             6 => MEtoD64('1' . ('0' x 9), 0), 7 => MEtoD64('1' . ('0' x 8), 0),
356             8 => MEtoD64('1' . ('0' x 7), 0), 9 => MEtoD64('1' . ('0' x 6), 0),
357             10 => MEtoD64('1' . ('0' x 5), 0), 11 => MEtoD64('1' . ('0' x 4), 0),
358             12 => MEtoD64('1' . ('0' x 3), 0), 13 => MEtoD64('1' . ('0' x 2), 0),
359             14 => MEtoD64('1' . ('0' x 1), 0), 15 => MEtoD64('1', 0)
360             ) : ();
361              
362             #######################################################################
363             #######################################################################
364             # Used by t/decode_cross_checks.t
365              
366             sub _decode_mant {
367 1536     1536   15200 my $val = shift;
368 1536         2396 my $ret = '';
369 1536         2756 for my $i(0 .. 15) {
370 24576         33229 my $count = 0;
371 24576 100       56268 if($val > 0) {
372 19271         46507 while($val >= $Math::Decimal64::bid_decode{$i}) {
373 58592         108111 $val -= $Math::Decimal64::bid_decode{$i};
374 58592         134667 $count++;
375             }
376             }
377 24576         43260 $ret .= $count;
378             }
379 1536         4409 return $ret;
380             }
381              
382             #######################################################################
383             #######################################################################
384              
385 36     36 0 10757 sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking
386              
387             #######################################################################
388             #######################################################################
389              
390             sub _overload_string {
391 58     58   1253 my @ret = D64toME($_[0]);
392 58 100 66     457 if(is_InfD64($_[0]) || !$_[0]) {return $ret[0]}
  14         64  
393 44         224 return $ret[0] . 'e' . $ret[1];
394             }
395              
396             #######################################################################
397             #######################################################################
398              
399             sub pFR {
400 0     0 0 0 my @ret = FR64toME($_[0]);
401 0 0 0     0 if(is_InfD64($_[0]) || !$_[0]) {print $ret[0]}
  0         0  
402 0         0 else {print $ret[0] . "e" . $ret[1]}
403             }
404              
405             #######################################################################
406             #######################################################################
407              
408             sub _overload_int {
409 47732 100 100 47732   466834 if(is_NaND64($_[0]) || is_InfD64($_[0]) || is_ZeroD64($_[0])) {return $_[0]}
  341   100     953  
410 47391         99437 my($man, $exp) = D64toME($_[0]);
411 47391 100       118215 if($exp >= 0) {return $_[0]}
  23512         70723  
412 23879         35897 my $man_length = length($man);
413 23879 100       65503 $man_length-- if $man =~ /^\-/;
414 23879 100       51678 if(-$exp >= $man_length) { # -1 <= $_[0] <= 1
415 23864         62238 my $z = ZeroD64(1);
416 23864 100       81810 if($_[0] < $z) {return ZeroD64(-1)} # return -0
  23863         114761  
417 1         4 return $z; # return 0
418             }
419              
420 15         29 substr($man, $exp, -$exp, '');
421 15         69 return MEtoD64($man, 0);
422             }
423              
424             #######################################################################
425             #######################################################################
426              
427             sub new {
428              
429             # This function caters for 2 possibilities:
430             # 1) that 'new' has been called OOP style - in which
431             # case there will be a maximum of 2 args
432             # 2) that 'new' has been called as a function - in
433             # which case there will be a maximum of 1 arg.
434             # If there are no args, then we just want to return a
435             # Math::Decimal64 object that's a NaN.
436              
437 509412 100   509412 0 7060068 if(!@_) {return NaND64()}
  1         5  
438              
439 509411 100       1021721 if(@_ > 3) {die "More than 3 arguments supplied to new()"}
  2         15  
440              
441             # If 'new' has been called OOP style, the first arg is the string
442             # "Math::Decimal64" which we don't need - so let's remove it. However,
443             # if the first arg is a Math::Decimal64 object (which is a possibility),
444             # then we'll get a fatal error when we check it for equivalence to
445             # the string "Math::Decimal64". So we first need to check that it's not
446             # an object - which we'll do by using the ref() function:
447 509409 100 100     1907672 if(!ref($_[0]) && $_[0] eq "Math::Decimal64") {
448 509398         705276 shift;
449 509398 100       974849 if(!@_) {return NaND64()}
  10         176  
450             }
451              
452             # @_ can now contain max of 2 vals - the mantissa and exponent.
453             # If @_ == 1 then it contains the value.
454 509399 100       970515 if(@_ > 2) {die "Too many arguments supplied to new() - expected no more than 2"}
  1         4  
455              
456 509398 100       987311 if(@_ == 2) {return MEtoD64(shift, shift)}
  509266         923294  
457              
458 132         222 my $arg = shift;
459 132         302 my $type = _itsa($arg);
460              
461 132 100       273 if($type == 1) { # UV
462 13         117 return UVtoD64($arg);
463             }
464              
465 119 100       245 if($type == 2) { # IV
466 15         117 return IVtoD64($arg);
467             }
468              
469 104 100       196 if($type == 3) { # NV
470 3         15 die "new() cannot be used to assign an NV - use NVtoD64() instead";
471             }
472              
473 101 100       193 if($type == 4) { # PV
474 73 50       194 return STRtoD64($arg) if have_strtod64();
475 73         410 return PVtoD64($arg);
476             }
477              
478 28 100       68 if($type == 64) { # Math::Decimal64 object
479 25         89 return D64toD64($arg);
480             }
481              
482 3         14 die "Bad argument given to new";
483             }
484              
485             #######################################################################
486             #######################################################################
487              
488             sub D64toME {
489              
490 178588     178588 0 534620 my($ret1, $ret2) = split /e/i, decode_d64($_[0]);
491 178588 100       424384 $ret2 = 0 unless defined $ret2;
492 178588 100       601475 $ret2 = 0 if is_ZeroD64($_[0]);
493 178588         459802 return ($ret1, $ret2);
494              
495             ## OLD - used strtold ##
496             # return ('-0', '0') if (is_ZeroD64($_[0]) == -1); # Negative Zero.
497             # my @ret = _D64toME($_[0]);
498             # if(!defined($ret[1])) {
499             # @ret = _sci2me($ret[0], $ret[2]);
500             # }
501             # return @ret;
502             }
503              
504             #######################################################################
505             #######################################################################
506              
507             sub FR64toME {
508              
509 0     0 0 0 my $fr = Math::MPFR::Rmpfr_init2(55);
510 0         0 my $v = $Math::MPFR::VERSION;
511 0 0       0 $v ge '3.23' ? Math::MPFR::Rmpfr_set_DECIMAL64($fr, $_[0], 0)
512             : Math::MPFR::Rmpfr_set_decimal64($fr, $_[0], 0); # round to nearest
513              
514 0 0 0     0 if(Math::MPFR::Rmpfr_zero_p($fr) ||
      0        
515             Math::MPFR::Rmpfr_inf_p($fr) ||
516             Math::MPFR::Rmpfr_nan_p($fr)) {
517 0         0 return D64toME($_[0]);
518             }
519              
520 0         0 my($man, $exp) = Math::MPFR::Rmpfr_deref2($fr, 10, 16, 0); #MPFR_RNDN
521 0   0     0 chop $man while(length($man) > 1 && $man =~ /0$/);
522 0         0 $exp -= length($man);
523 0 0       0 $exp++ if $man =~/^\-/;
524 0         0 return ($man, $exp);
525             }
526              
527             #######################################################################
528             #######################################################################
529              
530             sub MEtoD64 {
531             # Check that 2 args are supplied
532 546881 50   546881 0 2060913 die "MEtoD64 takes 2 args" if @_ != 2;
533              
534 546881         954640 my($arg1, $arg2) = (shift, shift);
535              
536 546881 100       1398873 die "Invalid 1st arg ($arg1) to MEtoD64" if $arg1 =~ /[^0-9\-\+]/;
537 546880 50       1142295 die "Invalid 2nd arg ($arg2) to MEtoD64" if $arg2 =~ /[^0-9\-\+]/;
538              
539 546880         871004 $arg1 =~ s/^\+//;
540 546880         748107 $arg2 =~ s/^\+//;
541 546880 100       1288662 my $sign = $arg1 =~ s/^\-// ? '-' : '';
542              
543 546880         838163 my $len_1 = length $arg1;
544              
545 546880 100 100     1698302 if($len_1 >= 16 || $arg2 < -398) {
546 222466 100       430994 die "${sign}${arg1} exceeds _Decimal64 precision. It needs to be shortened to no more than 16 decimal digits"
547             if $len_1 > 16;
548 222465 100       421310 ($arg1, $arg2) = _round_as_needed($arg1, $arg2) if $arg2 < -398;
549              
550             # Need to handle the possibility that strtold can't handle all 16-digit values correctly.
551 222465 50       1074495 if($Config{longdblsize} == 8) {
552 0         0 my $len = length $arg1; # length of $arg1 may have changed
553 0 0       0 if($len == 16) {
554 0         0 return _MEtoD64($sign . substr($arg1, 0, 8), $arg2 + 8) +
555             _MEtoD64($sign . substr($arg1, 8, 8), $arg2);
556             }
557             }
558             }
559              
560 546879         5055551 return _MEtoD64($sign . $arg1, $arg2);
561              
562             }
563              
564             #######################################################################
565             #######################################################################
566              
567             # Values such as (d, -400), (dd, -401), (ddd, -402), etc evaluate to zero.
568             # But values such as (dddd, -400), (ddd, -401), (dddddddd, -402), etc may be non-zero.
569             # In such cases we'll remove the ignored (trailing) digits, rounding the leading
570             # digits to nearest - tied to even for midway cases.
571              
572             sub _round_as_needed {
573 3470     3470   6793 my($sign, $man, $exp) = ('', shift, shift);
574              
575 3470 50       7625 if($man =~ /^\-/) {
576 0         0 $man =~ s/^\-//;
577 0         0 $sign = '-';
578             }
579              
580 3470         5611 my $length = length $man;
581 3470         5183 my $maxlen = -398 - $exp;
582              
583 3470 100       7111 if($length >= $maxlen) {
584 1102         1994 my $rounder = substr($man, $length - $maxlen); # The trailing (ignored) digits
585 1102 100       2381 $man = $length > $maxlen ? substr($man, 0, $length - $maxlen)
586             : '0';
587 1102         1617 my $roundup = 0;
588 1102 100       2884 $roundup = 1 if substr($rounder, 0, 1) > 5;
589 1102 100 100     2944 $roundup = 1 if ((substr($rounder, 0, 1) == 5) &&
      66        
590             ((substr($rounder, 1) =~ /[1-9]/) || (substr($man, -1, 1) %2 == 1)));
591              
592 1102 100       2430 $man++ if $roundup;
593 1102         1857 $exp += $maxlen; # Removal of trailing digits moved the implied
594             # decimal point $maxlen places to the left
595             }
596              
597 3470         9184 return ($sign . $man, $exp);
598             }
599              
600             #######################################################################
601             #######################################################################
602              
603             sub assignME {
604             # Check that 3 args are supplied
605 10 50   10 0 403 die "assignME takes 3 args" if @_ != 3;
606              
607 10         20 my $arg1 = shift;
608 10         17 my $arg2 = shift;
609 10         24 my $arg3 = shift;
610              
611 10 100       49 die "Invalid 1st arg ($arg1) to assignME" if _itsa($arg1) != 64;
612 8 50       27 die "Invalid 2nd arg ($arg2) to assignME" if $arg2 =~ /[^0-9\-]/;
613 8 50       24 die "Invalid 3rd arg ($arg3) to assignME" if $arg3 =~ /[^0-9\-]/;
614              
615 8         12 my $len_2 = length($arg2);
616 8 100       27 $len_2-- if $arg2 =~ /^\-/;
617              
618 8 100 66     36 if($len_2 >= 16 || $arg3 < -398) {
619 1 50       4 die "$arg2 exceeds _Decimal64 precision. It needs to be shortened to no more than 16 decimal digits"
620             if $len_2 > 16;
621 1 50       3 ($arg2, $arg3) = _round_as_needed($arg2, $arg3) if $arg3 < -398;
622             # Need to handle the possibility that strtold can't handle all 16-digit values correctly.
623 1 50       15 if($Config{longdblsize} == 8) {
624 0         0 $len_2 = length $arg2;
625 0         0 my ($sign, $inc) = ('', 0);
626 0 0       0 if($arg2 =~ /^\-/) {
627 0         0 $len_2--;
628 0         0 $sign = '-';
629 0         0 $inc++;
630             }
631 0 0       0 if($len_2 == 16) {
632 0         0 assignD64($arg1,
633             _MEtoD64($sign . substr($arg2, 0 + $inc, 8), $arg3 + 8) +
634             _MEtoD64($sign . substr($arg2, 8 + $inc, 8), $arg3));
635             }
636             }
637             }
638              
639 8         69 _assignME($arg1, $arg2, $arg3);
640              
641             }
642              
643             #######################################################################
644             #######################################################################
645              
646             sub _sci2me {
647 0     0   0 my @ret = split /e/i, $_[0];
648 0         0 chop $ret[0] while $ret[0] =~ /0\b/;
649 0         0 my @adj = split /\./, $ret[0];
650 0 0       0 my $adj = defined $adj[1] ? length($adj[1])
651             : 0;
652 0         0 $ret[0] =~ s/\.//;
653 0         0 $ret[1] += $_[1] - $adj;
654              
655 0         0 return @ret;
656             }
657              
658             #######################################################################
659             #######################################################################
660              
661             sub d64_bytes {
662 183927     183927 0 1026588 my @ret = _d64_bytes($_[0]);
663 183927         644892 return join '', @ret;
664             }
665              
666             #######################################################################
667             #######################################################################
668              
669             sub hex2bin {
670 182305     182305 0 646947 my $ret = unpack("B*", (pack "H*", $_[0]));
671 182305         312553 my $len = length $ret;
672 182305 50       392373 die "hex2bin() yielded $len bits" if $len != 64;
673 182305         333278 return $ret;
674             }
675              
676             #######################################################################
677             #######################################################################
678              
679             sub d64_fmt {
680 43     43 0 361 my $d64 = MEtoD64('1234567890123456', 0);
681             # BID: 31C462D53C8ABAC0
682             # DPD: 263934B9C1E28E56
683 43 50       178 return 'DPD' if d64_bytes($d64) =~ /E56$/i;
684 43 50       150 return 'BID' if d64_bytes($d64) =~ /AC0$/i;
685 0         0 return 'Unknown';
686             }
687              
688             #######################################################################
689             #######################################################################
690              
691             sub decode_dpd {
692             # Takes the Math::Decimal64 object as its arg.
693             # Decodes Densely Packed Decimal formatting of the Decimal64 value.
694 0     0 0 0 my $binstring = hex2bin(d64_bytes($_[0]));
695 0         0 my @first = decode_dpd_1st($binstring);
696 0 0 0     0 return ($first[0] . $first[1]) if ($first[1] =~ /inf/i || $first[1] =~ /nan/i);
697 0         0 my $mantissa = $first[1] . decode_dpd_2nd($binstring);
698              
699             # Remove leading zeroes from the mantissa
700 0         0 $mantissa =~ s/^0+//;
701 0 0       0 if($mantissa eq '') {$mantissa = '0'}
  0         0  
702             else {
703             # Remove trailing zeroes
704 0         0 while($mantissa =~ /0$/) {
705 0         0 $mantissa =~ s/0$//;
706 0         0 $first[2]++;
707             }
708             }
709              
710 0         0 my $ret = $first[0] . $mantissa . 'e' . $first[2];
711              
712             }
713              
714             #######################################################################
715             #######################################################################
716              
717             sub decode_dpd_1st{
718             # Takes the entire binary string as its arg.
719 0 0   0 0 0 die "Argument to decode_dpd_1st is wrong size (", length($_[0]), ")"
720             if length($_[0]) != 64;
721 0         0 my $leading_bits = 14;
722 0         0 my $trailing_bits = 50;
723 0         0 my $msd; # significand's most siginificant digit
724             my $exp; # exponent
725 0         0 my $keep = substr($_[0], 0, $leading_bits);
726 0 0       0 my $sign = substr($keep, 0, 1) ? '-' : '';
727 0 0       0 return ('','nan') if substr($keep, 1, 5) eq '11111';
728 0 0       0 if(substr($keep, 1 ,5) eq '11110') {return ($sign, 'inf')}
  0         0  
729 0         0 my $pre = substr($keep, 1, 2);
730 0 0 0     0 if($pre eq '00' || $pre eq '01' || $pre eq '10') {
      0        
731 0         0 $msd = oct('0b0' . substr($keep, 3, 3));
732 0         0 $exp = oct('0b' . $pre . substr($keep, 6, 8)) - 398;
733 0         0 return ($sign, $msd, $exp);
734             }
735 0         0 $pre = substr($keep, 1, 4);
736 0 0 0     0 if($pre eq '1100' || $pre eq '1101' || $pre eq '1110') {
      0        
737 0         0 $exp = oct('0b' . substr($pre, 2, 2) . substr($keep, 6, 8)) - 398;
738 0         0 $msd = oct('0b' . '100' . substr($keep, 5, 1));
739 0         0 return ($sign, $msd, $exp);
740             }
741 0         0 die "decode_dpd_1st function failed to parse its argument ($_[0])";
742             }
743              
744             #######################################################################
745             #######################################################################
746              
747             sub decode_dpd_2nd {
748             # Takes the entire binary string as its arg.
749 0 0   0 0 0 die "Argument to decode_dpd_2nd is wrong size (", length($_[0]), ")"
750             if length($_[0]) != 64; # 64 for Decimal64
751 0         0 my $leading_bits = 14; # 18 for Decimal28
752 0         0 my $trailing_bits = 50; # 110 for Decimal28
753 0         0 my $keep = substr($_[0], $leading_bits, $trailing_bits);
754 0         0 my $ret = '';
755 0         0 for my $i(0, 10, 20, 30, 40) {
756 0         0 my $key = substr($keep, $i, 10);
757 0         0 $ret .= $Math::Decimal64::dpd_encode{$key};
758             }
759 0         0 return $ret;
760             }
761              
762             #######################################################################
763             #######################################################################
764              
765             sub decode_bid {
766             # Takes a Math::Decimal64 object as its arg.
767             # Decodes Binary Integer Decimal formatting of the _Decimal64 value.
768              
769 180769     180769 0 328881 my $keep = hex2bin(d64_bytes($_[0]));
770 180769 50       393199 die "Base 2 representation is wrong size (", length($keep), ")"
771             if length($keep) != 64; # 64 for Decimal64
772 180769         251763 my $leading_bits = 13;
773 180769         242636 my $trailing_bits = 51;
774 180769         261465 my @mantissa;
775             my $exp; # exponent
776 180769 100       389587 my $sign = substr($keep, 0, 1) ? '-' : '';
777 180769 100       386421 return 'nan' if substr($keep, 1, 5) eq '11111';
778 180756 100       361210 if(substr($keep, 1 ,5) eq '11110') {return $sign . 'inf'}
  25         90  
779 180731         268808 my $pre = substr($keep, 1, 2);
780 180731 100 100     686000 if($pre eq '00' || $pre eq '01' || $pre eq '10') {
      100        
781 171652         351707 $exp = oct('0b' . substr($keep, 1, 10)) - 398;
782 171652         1977377 @mantissa = reverse(split(//, '0' . substr($keep, 11, 53)));
783 171652         1808627 my $mantissa = _bid_mant(\@mantissa);
784 171652 100       570241 if($mantissa !~ /[1-9]/) { $mantissa = '0'}
  900         1522  
785             else {
786 170752         467698 while($mantissa =~ /0$/) {
787 632634         1288241 $mantissa =~ s/0$//;
788 632634         1512541 $exp++;
789             }
790             }
791 171652         1020183 return $sign . $mantissa . 'e' . $exp;
792             }
793 9079         15831 $pre = substr($keep, 1, 4);
794 9079 50 100     42270 if($pre eq '1100' || $pre eq '1101' || $pre eq '1110') {
      66        
795 9079         19404 $exp = oct('0b' . substr($keep, 3, 10)) - 398;
796 9079         106482 @mantissa = reverse(split(//,'100' . substr($keep, 13, 51)));
797 9079         96673 my $mantissa = _bid_mant(\@mantissa);
798 9079 50       31613 if($mantissa !~ /[1-9]/) { $mantissa = '0'}
  0         0  
799             else {
800 9079         28695 while($mantissa =~ /0$/) {
801 60707         124366 $mantissa =~ s/0$//;
802 60707         146495 $exp++;
803             }
804             }
805 9079         54903 return $sign . $mantissa . 'e' . $exp;
806             }
807 0         0 die "decode_bid function failed to parse its argument ($_[0])";
808             }
809              
810             #######################################################################
811             #######################################################################
812             # Replaced by XSub of same name
813             # sub PVtoD64 {
814             #
815             # my($arg1, $arg2) = PVtoME($_[0]);
816             #
817             # if($arg1 =~ /inf|nan/i) {
818             # $arg1 =~ /nan/i ? return NaND64()
819             # : $arg1 =~ /^\-/ ? return InfD64(-1)
820             # : return InfD64(1);
821             # }
822             #
823             # return MEtoD64($arg1, $arg2);
824             #}
825              
826             #######################################################################
827             #######################################################################
828             # Replaced by XSub of same name
829             # sub assignPV {
830             #
831             # my($arg1, $arg2) = PVtoME($_[1]);
832             # if($arg1 =~ /inf|nan/i) {
833             # $arg1 =~ /nan/i ? assignNaN($_[0])
834             # : $arg1 =~ /^\-/ ? assignInf($_[0], -1)
835             # : assignInf($_[0], 1);
836             # }
837             # else {
838             # assignME($_[0], $arg1, $arg2);
839             # }
840             #}
841              
842             #######################################################################
843             #######################################################################
844              
845 8     8   114 sub DEC64_MAX {return _DEC64_MAX()}
846 9     9   75 sub DEC64_MIN {return _DEC64_MIN()}
847              
848             #######################################################################
849             #######################################################################
850              
851             sub get_exp {
852 1536     1536 0 2787 my $keep = hex2bin(d64_bytes($_[0]));
853 1536         2619 my $pre = substr($keep, 1, 2);
854 1536 50       3043 if($Math::Decimal64::fmt eq 'DPD') {
855 0 0 0     0 if($pre eq '00' || $pre eq '01' || $pre eq '10') {
      0        
856 0         0 return oct('0b' . $pre . substr($keep, 6, 8)) - 398;
857             }
858             else {
859 0         0 return oct('0b' . substr($pre, 2, 2) . substr($keep, 6, 8)) - 398;
860             }
861             }
862             else {
863 1536 100 100     6083 if($pre eq '00' || $pre eq '01' || $pre eq '10') {
      100        
864 1469         4605 return oct('0b' . substr($keep, 1, 10)) - 398;
865             }
866             else {
867 67         219 return oct('0b' . substr($keep, 3, 10)) - 398;
868             }
869             }
870             }
871              
872             #######################################################################
873             #######################################################################
874              
875             sub get_sign {
876 1536 100   1536 0 6813 return '-' if hex(substr(d64_bytes($_[0]), 0, 1)) >= 8;
877 768         1746 return '+';
878             }
879              
880             #######################################################################
881             #######################################################################
882              
883             sub DPDtoD64 {
884             # Usable only where DPD format is in use.
885             # Converts the 64-bit string returned by _MEtoBINSTR into
886             # a Math::Decimal64 object set to the value encoded by the
887             # the 64-bit string. This is all done without having to calculate
888             # the actual value - and is typically ~25 times quicker than
889             # MEtoD64.
890 6     6 0 153 my($man, $exp) = (shift, shift);
891 6         13 my $arg = _MEtoBINSTR($man, $exp);
892 6         35 return _DPDtoD64(unpack("a*", pack( "B*", $arg)));
893             }
894              
895             #######################################################################
896             #######################################################################
897              
898             sub PVtoME {
899              
900 0     0 0 0 my($arg1, $arg2) = split /e/i, $_[0];
901              
902 0 0       0 if($arg1 =~ /^(\-|\+)?inf|^(\-|\+)?nan/i) {
903 0         0 return ($arg1, 0);
904             }
905              
906 0         0 _sanitise_args($arg1, $arg2);
907 0         0 return ($arg1, $arg2);
908             }
909              
910             sub MEtoPV {
911 16     16 0 101 my $arg1 = shift;
912 16 100       48 if($arg1 =~ /^(\-|\+)?inf|^(\-|\+)?nan/i) {
913 8         18 $arg1 =~ s/\+//;
914 8         28 return $arg1;
915             }
916              
917 8         12 my $arg2 = shift;
918 8         18 return $arg1 . 'e' . $arg2;
919             }
920              
921             #######################################################################
922             #######################################################################
923              
924             sub _sanitise_args {
925 0 0   0   0 $_[1] = 0 unless defined $_[1];
926 0         0 $_[0] =~ s/\.0+$//;
927 0         0 my @split = split /\./, $_[0];
928 0 0       0 $split[1] = '' unless defined $split[1];
929 0         0 $_[1] -= length($split[1]);
930 0         0 $_[0] =~ s/\.//;
931 0         0 $_[0] =~ s/^0+//;
932             }
933              
934             #######################################################################
935             #######################################################################
936              
937             sub assignDPD {
938 6     6 0 64 _assignDPD($_[0], unpack("a*", pack("B*", _MEtoBINSTR($_[1], $_[2]))));
939             }
940              
941             #######################################################################
942             #######################################################################
943              
944             sub _MEtoBINSTR {
945             # Converts (mantissa, exponent) strings to DPD encoded 64-bit string - without
946             # the need to actually calculate the value.
947 12     12   19 my $man = shift;
948              
949 12 50       70 if($man =~ /^(\-|\+)?inf|^(\-|\+)?nan/i) {
950 12 100       82 $man =~ /\-inf/i ? return '11111' . ('0' x 59)
    100          
951             : $man =~ /^(\-|\+)?nan/i ? return '011111' . ('0' x 58)
952             : return '01111' . ('0' x 59);
953             }
954              
955 0         0 my $exp = shift;
956              
957             # Determine the sign, and remove it.
958 0 0       0 my $sign = $man =~ /^\-/ ? '1' : '0';
959 0         0 $man =~ s/[\+\-]//;
960 0 0       0 die "_MEtoBINSTR has been passed (probably from DPDtoBINSTR) an illegal mantissa"
961             if $man =~ /[^0-9]/;
962              
963             # Remove leading zeroes, and return zero (of appropriate sign)
964             # if we're left with the empty string.
965 0         0 $man =~ s/^0+//;
966 0 0       0 return $sign . '0100001101101' . ('0' x 50) unless $man;
967              
968             # Fill the mantissa with 16 digits - by zero padding the end.
969 0         0 my $add_zeroes = 16 - length($man);
970 0         0 $man .= '0' x $add_zeroes;
971 0         0 $exp -= $add_zeroes;
972              
973 0 0 0     0 if(length($man) > 16 || $exp < -398) {
974 0 0       0 die "$man exceeds _Decimal64 precision. It needs to be shortened to no more than 16 decimal digits"
975             if length($man) > 16;
976 0         0 ($man, $exp) = _round_as_needed($man, $exp);
977             }
978              
979             # Return 0 if $exp is still less that -398.
980 0 0       0 return $sign . '0100001101101' . ('0' x 50) if $exp < -398;
981              
982             # Return -inf/inf if value is infinite
983 0 0       0 if($exp > 369) {
984 0 0       0 return $sign . '1111' . ('0' x 59) if (length($man) + $exp) > 385;
985             }
986              
987 0         0 $man = '0' . $man while length($man) < 16;
988              
989             # The last 50 bits encode the last 15 digits.
990 0         0 my $last_15_dig = substr($man, 1, 15);
991 0         0 my $last_50_bits;
992 0         0 for(my $i = 0; $i < 13; $i += 3) {
993 0         0 $last_50_bits .= $Math::Decimal64::dpd_decode{substr($last_15_dig, $i, 3)}
994             }
995              
996 0         0 my $len = length($last_50_bits);
997 0 0       0 die "Wrong bitsize ($len != 50) in _MEtoBINSTR()" if $len != 50;
998              
999 0         0 my $leading_digit = substr($man, 0, 1); # ie the msd (most siginificant digit).
1000 0         0 my $exp_base_2 = sprintf "%010b", $exp + 398;
1001              
1002             # The encoding of the exponent and msd depends upon the value of the msd.
1003             # If it's 0..7, it's done one way; if it's 8 or 9 it's done th'other way.
1004 0 0       0 if($leading_digit < 8) {
1005 0         0 my $leading_digit_bits = sprintf "%03b", $leading_digit;
1006 0         0 substr($exp_base_2, 2, 0, $leading_digit_bits);
1007             }
1008             else {
1009 0 0       0 my $leading_digit_bit = $leading_digit == 8 ? '0' : '1';
1010 0         0 $exp_base_2 = '11' . substr($exp_base_2, 0, 2) . $leading_digit_bit . substr($exp_base_2, 2, 8);
1011             }
1012              
1013 0         0 $len = length($exp_base_2);
1014 0 0       0 die "Exponent (= $exp) component length is wrong ($len != 13) in _MEtoBINSTR()" if $len != 13;
1015              
1016 0         0 return $sign . $exp_base_2 . $last_50_bits;
1017             }
1018              
1019             #######################################################################
1020             #######################################################################
1021              
1022             sub D64toFSTR {
1023             # Converts the argument (M::D64 object) to a string in floating point
1024             # format - as distinct from scientific notation.
1025 413     413 0 1358 my($m, $e) = D64toME($_[0]);
1026 413 100       1272 return 'nan' if is_NaND64($_[0]);
1027 402 100       1242 if(is_InfD64($_[0])) {
1028 22 100       78 return 'inf' if is_InfD64($_[0])> 0;
1029 11         24 return '-inf';
1030             }
1031 380 100       1110 return $m . '0' x $e if $e >= 0;
1032 231         417 my($len, $sign) = (length $m, '');
1033 231         536 $m =~ s/^\-//;
1034 231 100       496 if($len != length $m) {
1035 115         172 $len--;
1036 115         167 $sign = '-';
1037             }
1038 231 100       476 if($len + $e > 0) {
1039 87         154 substr($m, $e, 0, '.');
1040 87         211 return $sign . $m;
1041             }
1042 144 100       297 if($len + $e < 0) {
1043 126         392 return $sign . '0.' . '0' x -($len + $e) . $m;
1044             }
1045 18         44 return $sign . '0.' . $m;
1046             }
1047              
1048             #######################################################################
1049             #######################################################################
1050              
1051             sub D64toRSTR {
1052             # As for D64toFSTR, but rounds the string to the no. of
1053             # decimal places specified by the second arg.
1054              
1055 123 100   123 0 658 die "2nd arg to D64toRSTR() must be greater than zero"
1056             unless $_[1] >= 0;
1057              
1058 122 100       223 my $dp = $_[1] ? '.' : '';
1059              
1060 122         233 my $str = D64toFSTR($_[0]);
1061              
1062 122 100       330 return $str if $str =~ /n/i; # inf/nan
1063              
1064 92 100       239 return $str . "$dp" . '0' x $_[1] unless $str =~ /\./;
1065              
1066 84         198 my($leading, $trailing) = split /\./, $str;
1067 84         135 my $len_trail = length $trailing ;
1068              
1069 84 100       183 return $str if ($_[1] == $len_trail);
1070              
1071 66 100       136 if(length($trailing) <= $_[1]) {
1072 14         25 $trailing .= '0' x ($_[1] - length($trailing));
1073 14         36 return $leading . "$dp" . $trailing;
1074             }
1075              
1076             # $len_trail > specified number of decimal places ($_[1]).
1077             # We need to round (to nearest, ties to even) from here on.
1078              
1079 52 100 100     292 return $leading . "$dp" . substr($trailing, 0, $_[1])
      66        
1080             if (substr($trailing, $_[1], 1) <= 4) ||
1081             (substr($trailing, $_[1]) =~ /^5(0+)?$/ && substr($trailing, $_[1] - 1, 1) % 2 == 0);
1082              
1083 34         69 my $to_inc = substr($trailing, 0, $_[1]);
1084              
1085 34         61 my $carry = _increment($to_inc); # $carry will either be mt string or '1'. If '1', then we
1086             # also need to increment $leading.
1087              
1088 34 100       86 return $leading . "$dp" . $to_inc
1089             if $carry eq '';
1090              
1091 24         41 my($sign, $len_lead) = ('', length($leading));
1092              
1093 24         54 $leading =~ s/^\-//;
1094              
1095 24 100       52 if($len_lead != length($leading)) {
1096 12         16 $sign = '-';
1097 12         19 $len_lead--;
1098             }
1099              
1100 24         39 $carry = _increment($leading);
1101              
1102 24         65 return $sign . $carry . $leading . "$dp" . $to_inc;
1103             }
1104              
1105             #######################################################################
1106             #######################################################################
1107              
1108             sub _increment {
1109 58     58   87 my $carry = 1;
1110 58         82 my $len = length($_[0]) * -1;
1111              
1112 58         128 for(my $offset = -1; $offset >= $len; $offset--) {
1113 52         104 substr($_[0], $offset, 1) = (substr($_[0], $offset, 1) + 1) % 10;
1114 52 100       128 if(substr($_[0], $offset, 1) ne '0') {
1115 30         46 $carry = '';
1116 30         41 last;
1117             }
1118             }
1119              
1120 58         104 return $carry;
1121             }
1122              
1123             #######################################################################
1124             #######################################################################
1125              
1126             *decode_d64 = $Math::Decimal64::fmt eq 'DPD' ? \&decode_dpd : \&decode_bid;
1127              
1128             #######################################################################
1129             #######################################################################
1130              
1131             1;
1132              
1133             __END__