This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
use cBOOL for bool casts
[perl5.git] / numeric.c
CommitLineData
98994639
HS
1/* numeric.c
2 *
663f364b 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
1129b882 4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
98994639
HS
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
4ac71550
TC
12 * "That only makes eleven (plus one mislaid) and not fourteen,
13 * unless wizards count differently to other people." --Beorn
14 *
15 * [p.115 of _The Hobbit_: "Queer Lodgings"]
98994639
HS
16 */
17
ccfc67b7
JH
18/*
19=head1 Numeric functions
166f8a29
DM
20
21This file contains all the stuff needed by perl for manipulating numeric
22values, including such things as replacements for the OS's atof() function
23
24=cut
25
ccfc67b7
JH
26*/
27
98994639
HS
28#include "EXTERN.h"
29#define PERL_IN_NUMERIC_C
30#include "perl.h"
31
32U32
33Perl_cast_ulong(pTHX_ NV f)
34{
96a5add6 35 PERL_UNUSED_CONTEXT;
98994639
HS
36 if (f < 0.0)
37 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
38 if (f < U32_MAX_P1) {
39#if CASTFLAGS & 2
40 if (f < U32_MAX_P1_HALF)
41 return (U32) f;
42 f -= U32_MAX_P1_HALF;
43 return ((U32) f) | (1 + U32_MAX >> 1);
44#else
45 return (U32) f;
46#endif
47 }
48 return f > 0 ? U32_MAX : 0 /* NaN */;
49}
50
51I32
52Perl_cast_i32(pTHX_ NV f)
53{
96a5add6 54 PERL_UNUSED_CONTEXT;
98994639
HS
55 if (f < I32_MAX_P1)
56 return f < I32_MIN ? I32_MIN : (I32) f;
57 if (f < U32_MAX_P1) {
58#if CASTFLAGS & 2
59 if (f < U32_MAX_P1_HALF)
60 return (I32)(U32) f;
61 f -= U32_MAX_P1_HALF;
62 return (I32)(((U32) f) | (1 + U32_MAX >> 1));
63#else
64 return (I32)(U32) f;
65#endif
66 }
67 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
68}
69
70IV
71Perl_cast_iv(pTHX_ NV f)
72{
96a5add6 73 PERL_UNUSED_CONTEXT;
98994639
HS
74 if (f < IV_MAX_P1)
75 return f < IV_MIN ? IV_MIN : (IV) f;
76 if (f < UV_MAX_P1) {
77#if CASTFLAGS & 2
78 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
79 if (f < UV_MAX_P1_HALF)
80 return (IV)(UV) f;
81 f -= UV_MAX_P1_HALF;
82 return (IV)(((UV) f) | (1 + UV_MAX >> 1));
83#else
84 return (IV)(UV) f;
85#endif
86 }
87 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
88}
89
90UV
91Perl_cast_uv(pTHX_ NV f)
92{
96a5add6 93 PERL_UNUSED_CONTEXT;
98994639
HS
94 if (f < 0.0)
95 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
96 if (f < UV_MAX_P1) {
97#if CASTFLAGS & 2
98 if (f < UV_MAX_P1_HALF)
99 return (UV) f;
100 f -= UV_MAX_P1_HALF;
101 return ((UV) f) | (1 + UV_MAX >> 1);
102#else
103 return (UV) f;
104#endif
105 }
106 return f > 0 ? UV_MAX : 0 /* NaN */;
107}
108
53305cf1
NC
109/*
110=for apidoc grok_bin
98994639 111
53305cf1
NC
112converts a string representing a binary number to numeric form.
113
114On entry I<start> and I<*len> give the string to scan, I<*flags> gives
115conversion flags, and I<result> should be NULL or a pointer to an NV.
116The scan stops at the end of the string, or the first invalid character.
7b667b5f
MHM
117Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
118invalid character will also trigger a warning.
119On return I<*len> is set to the length of the scanned string,
120and I<*flags> gives output flags.
53305cf1 121
7fc63493 122If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
53305cf1
NC
123and nothing is written to I<*result>. If the value is > UV_MAX C<grok_bin>
124returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
125and writes the value to I<*result> (or the value is discarded if I<result>
126is NULL).
127
7b667b5f 128The binary number may optionally be prefixed with "0b" or "b" unless
a4c04bdc
NC
129C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
130C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary
53305cf1
NC
131number may use '_' characters to separate digits.
132
133=cut
134 */
135
136UV
7918f24d
NC
137Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
138{
53305cf1
NC
139 const char *s = start;
140 STRLEN len = *len_p;
141 UV value = 0;
142 NV value_nv = 0;
143
144 const UV max_div_2 = UV_MAX / 2;
f2338a2e 145 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1 146 bool overflowed = FALSE;
7fc63493 147 char bit;
53305cf1 148
7918f24d
NC
149 PERL_ARGS_ASSERT_GROK_BIN;
150
a4c04bdc
NC
151 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
152 /* strip off leading b or 0b.
153 for compatibility silently suffer "b" and "0b" as valid binary
154 numbers. */
155 if (len >= 1) {
156 if (s[0] == 'b') {
157 s++;
158 len--;
159 }
160 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
161 s+=2;
162 len-=2;
163 }
164 }
53305cf1
NC
165 }
166
7fc63493 167 for (; len-- && (bit = *s); s++) {
53305cf1
NC
168 if (bit == '0' || bit == '1') {
169 /* Write it in this wonky order with a goto to attempt to get the
170 compiler to make the common case integer-only loop pretty tight.
171 With gcc seems to be much straighter code than old scan_bin. */
172 redo:
173 if (!overflowed) {
174 if (value <= max_div_2) {
175 value = (value << 1) | (bit - '0');
176 continue;
177 }
178 /* Bah. We're just overflowed. */
9b387841
NC
179 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
180 "Integer overflow in binary number");
53305cf1
NC
181 overflowed = TRUE;
182 value_nv = (NV) value;
183 }
184 value_nv *= 2.0;
98994639 185 /* If an NV has not enough bits in its mantissa to
d1be9408 186 * represent a UV this summing of small low-order numbers
98994639
HS
187 * is a waste of time (because the NV cannot preserve
188 * the low-order bits anyway): we could just remember when
53305cf1 189 * did we overflow and in the end just multiply value_nv by the
98994639 190 * right amount. */
53305cf1
NC
191 value_nv += (NV)(bit - '0');
192 continue;
193 }
194 if (bit == '_' && len && allow_underscores && (bit = s[1])
195 && (bit == '0' || bit == '1'))
98994639
HS
196 {
197 --len;
198 ++s;
53305cf1 199 goto redo;
98994639 200 }
a2a5de95
NC
201 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
202 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
203 "Illegal binary digit '%c' ignored", *s);
53305cf1 204 break;
98994639 205 }
53305cf1
NC
206
207 if ( ( overflowed && value_nv > 4294967295.0)
98994639 208#if UVSIZE > 4
53305cf1 209 || (!overflowed && value > 0xffffffff )
98994639
HS
210#endif
211 ) {
a2a5de95
NC
212 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
213 "Binary number > 0b11111111111111111111111111111111 non-portable");
53305cf1
NC
214 }
215 *len_p = s - start;
216 if (!overflowed) {
217 *flags = 0;
218 return value;
98994639 219 }
53305cf1
NC
220 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
221 if (result)
222 *result = value_nv;
223 return UV_MAX;
98994639
HS
224}
225
53305cf1
NC
226/*
227=for apidoc grok_hex
228
229converts a string representing a hex number to numeric form.
230
231On entry I<start> and I<*len> give the string to scan, I<*flags> gives
232conversion flags, and I<result> should be NULL or a pointer to an NV.
7b667b5f
MHM
233The scan stops at the end of the string, or the first invalid character.
234Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
235invalid character will also trigger a warning.
236On return I<*len> is set to the length of the scanned string,
237and I<*flags> gives output flags.
53305cf1
NC
238
239If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
240and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
241returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
242and writes the value to I<*result> (or the value is discarded if I<result>
243is NULL).
244
d1be9408 245The hex number may optionally be prefixed with "0x" or "x" unless
a4c04bdc
NC
246C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
247C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
53305cf1
NC
248number may use '_' characters to separate digits.
249
250=cut
251 */
252
253UV
7918f24d
NC
254Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
255{
27da23d5 256 dVAR;
53305cf1
NC
257 const char *s = start;
258 STRLEN len = *len_p;
259 UV value = 0;
260 NV value_nv = 0;
53305cf1 261 const UV max_div_16 = UV_MAX / 16;
f2338a2e 262 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1 263 bool overflowed = FALSE;
98994639 264
7918f24d
NC
265 PERL_ARGS_ASSERT_GROK_HEX;
266
a4c04bdc
NC
267 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
268 /* strip off leading x or 0x.
269 for compatibility silently suffer "x" and "0x" as valid hex numbers.
270 */
271 if (len >= 1) {
272 if (s[0] == 'x') {
273 s++;
274 len--;
275 }
276 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
277 s+=2;
278 len-=2;
279 }
280 }
98994639
HS
281 }
282
283 for (; len-- && *s; s++) {
a3b680e6 284 const char *hexdigit = strchr(PL_hexdigit, *s);
53305cf1
NC
285 if (hexdigit) {
286 /* Write it in this wonky order with a goto to attempt to get the
287 compiler to make the common case integer-only loop pretty tight.
288 With gcc seems to be much straighter code than old scan_hex. */
289 redo:
290 if (!overflowed) {
291 if (value <= max_div_16) {
292 value = (value << 4) | ((hexdigit - PL_hexdigit) & 15);
293 continue;
294 }
295 /* Bah. We're just overflowed. */
9b387841
NC
296 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
297 "Integer overflow in hexadecimal number");
53305cf1
NC
298 overflowed = TRUE;
299 value_nv = (NV) value;
300 }
301 value_nv *= 16.0;
302 /* If an NV has not enough bits in its mantissa to
d1be9408 303 * represent a UV this summing of small low-order numbers
53305cf1
NC
304 * is a waste of time (because the NV cannot preserve
305 * the low-order bits anyway): we could just remember when
306 * did we overflow and in the end just multiply value_nv by the
307 * right amount of 16-tuples. */
308 value_nv += (NV)((hexdigit - PL_hexdigit) & 15);
309 continue;
310 }
311 if (*s == '_' && len && allow_underscores && s[1]
e1ec3a88 312 && (hexdigit = strchr(PL_hexdigit, s[1])))
98994639
HS
313 {
314 --len;
315 ++s;
53305cf1 316 goto redo;
98994639 317 }
a2a5de95
NC
318 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
319 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
53305cf1
NC
320 "Illegal hexadecimal digit '%c' ignored", *s);
321 break;
322 }
323
324 if ( ( overflowed && value_nv > 4294967295.0)
325#if UVSIZE > 4
326 || (!overflowed && value > 0xffffffff )
327#endif
328 ) {
a2a5de95
NC
329 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
330 "Hexadecimal number > 0xffffffff non-portable");
53305cf1
NC
331 }
332 *len_p = s - start;
333 if (!overflowed) {
334 *flags = 0;
335 return value;
336 }
337 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
338 if (result)
339 *result = value_nv;
340 return UV_MAX;
341}
342
343/*
344=for apidoc grok_oct
345
7b667b5f
MHM
346converts a string representing an octal number to numeric form.
347
348On entry I<start> and I<*len> give the string to scan, I<*flags> gives
349conversion flags, and I<result> should be NULL or a pointer to an NV.
350The scan stops at the end of the string, or the first invalid character.
351Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
352invalid character will also trigger a warning.
353On return I<*len> is set to the length of the scanned string,
354and I<*flags> gives output flags.
355
356If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
357and nothing is written to I<*result>. If the value is > UV_MAX C<grok_oct>
358returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
359and writes the value to I<*result> (or the value is discarded if I<result>
360is NULL).
361
362If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the octal
363number may use '_' characters to separate digits.
53305cf1
NC
364
365=cut
366 */
367
368UV
7918f24d
NC
369Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
370{
53305cf1
NC
371 const char *s = start;
372 STRLEN len = *len_p;
373 UV value = 0;
374 NV value_nv = 0;
53305cf1 375 const UV max_div_8 = UV_MAX / 8;
f2338a2e 376 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
53305cf1
NC
377 bool overflowed = FALSE;
378
7918f24d
NC
379 PERL_ARGS_ASSERT_GROK_OCT;
380
53305cf1
NC
381 for (; len-- && *s; s++) {
382 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
383 out front allows slicker code. */
384 int digit = *s - '0';
385 if (digit >= 0 && digit <= 7) {
386 /* Write it in this wonky order with a goto to attempt to get the
387 compiler to make the common case integer-only loop pretty tight.
388 */
389 redo:
390 if (!overflowed) {
391 if (value <= max_div_8) {
392 value = (value << 3) | digit;
393 continue;
394 }
395 /* Bah. We're just overflowed. */
9b387841
NC
396 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
397 "Integer overflow in octal number");
53305cf1
NC
398 overflowed = TRUE;
399 value_nv = (NV) value;
400 }
401 value_nv *= 8.0;
98994639 402 /* If an NV has not enough bits in its mantissa to
d1be9408 403 * represent a UV this summing of small low-order numbers
98994639
HS
404 * is a waste of time (because the NV cannot preserve
405 * the low-order bits anyway): we could just remember when
53305cf1
NC
406 * did we overflow and in the end just multiply value_nv by the
407 * right amount of 8-tuples. */
408 value_nv += (NV)digit;
409 continue;
410 }
411 if (digit == ('_' - '0') && len && allow_underscores
412 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
413 {
414 --len;
415 ++s;
416 goto redo;
417 }
418 /* Allow \octal to work the DWIM way (that is, stop scanning
7b667b5f 419 * as soon as non-octal characters are seen, complain only if
53305cf1
NC
420 * someone seems to want to use the digits eight and nine). */
421 if (digit == 8 || digit == 9) {
a2a5de95
NC
422 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
423 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
424 "Illegal octal digit '%c' ignored", *s);
53305cf1
NC
425 }
426 break;
98994639 427 }
53305cf1
NC
428
429 if ( ( overflowed && value_nv > 4294967295.0)
98994639 430#if UVSIZE > 4
53305cf1 431 || (!overflowed && value > 0xffffffff )
98994639
HS
432#endif
433 ) {
a2a5de95
NC
434 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
435 "Octal number > 037777777777 non-portable");
53305cf1
NC
436 }
437 *len_p = s - start;
438 if (!overflowed) {
439 *flags = 0;
440 return value;
98994639 441 }
53305cf1
NC
442 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
443 if (result)
444 *result = value_nv;
445 return UV_MAX;
446}
447
448/*
449=for apidoc scan_bin
450
451For backwards compatibility. Use C<grok_bin> instead.
452
453=for apidoc scan_hex
454
455For backwards compatibility. Use C<grok_hex> instead.
456
457=for apidoc scan_oct
458
459For backwards compatibility. Use C<grok_oct> instead.
460
461=cut
462 */
463
464NV
73d840c0 465Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
466{
467 NV rnv;
468 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 469 const UV ruv = grok_bin (start, &len, &flags, &rnv);
53305cf1 470
7918f24d
NC
471 PERL_ARGS_ASSERT_SCAN_BIN;
472
53305cf1
NC
473 *retlen = len;
474 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
475}
476
477NV
73d840c0 478Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
479{
480 NV rnv;
481 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 482 const UV ruv = grok_oct (start, &len, &flags, &rnv);
53305cf1 483
7918f24d
NC
484 PERL_ARGS_ASSERT_SCAN_OCT;
485
53305cf1
NC
486 *retlen = len;
487 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
488}
489
490NV
73d840c0 491Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
492{
493 NV rnv;
494 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 495 const UV ruv = grok_hex (start, &len, &flags, &rnv);
53305cf1 496
7918f24d
NC
497 PERL_ARGS_ASSERT_SCAN_HEX;
498
53305cf1
NC
499 *retlen = len;
500 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
98994639
HS
501}
502
503/*
504=for apidoc grok_numeric_radix
505
506Scan and skip for a numeric decimal separator (radix).
507
508=cut
509 */
510bool
511Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
512{
513#ifdef USE_LOCALE_NUMERIC
97aff369 514 dVAR;
7918f24d
NC
515
516 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
517
98994639
HS
518 if (PL_numeric_radix_sv && IN_LOCALE) {
519 STRLEN len;
c4420975 520 const char * const radix = SvPV(PL_numeric_radix_sv, len);
98994639
HS
521 if (*sp + len <= send && memEQ(*sp, radix, len)) {
522 *sp += len;
523 return TRUE;
524 }
525 }
526 /* always try "." if numeric radix didn't match because
527 * we may have data from different locales mixed */
528#endif
7918f24d
NC
529
530 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
531
98994639
HS
532 if (*sp < send && **sp == '.') {
533 ++*sp;
534 return TRUE;
535 }
536 return FALSE;
537}
538
539/*
540=for apidoc grok_number
541
542Recognise (or not) a number. The type of the number is returned
543(0 if unrecognised), otherwise it is a bit-ORed combination of
544IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
aa8b85de 545IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
60939fb8
NC
546
547If the value of the number can fit an in UV, it is returned in the *valuep
548IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
549will never be set unless *valuep is valid, but *valuep may have been assigned
550to during processing even though IS_NUMBER_IN_UV is not set on return.
551If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
552valuep is non-NULL, but no actual assignment (or SEGV) will occur.
553
554IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
555seen (in which case *valuep gives the true value truncated to an integer), and
556IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
557absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
558number is larger than a UV.
98994639
HS
559
560=cut
561 */
562int
563Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
564{
60939fb8 565 const char *s = pv;
c4420975 566 const char * const send = pv + len;
60939fb8
NC
567 const UV max_div_10 = UV_MAX / 10;
568 const char max_mod_10 = UV_MAX % 10;
569 int numtype = 0;
570 int sawinf = 0;
aa8b85de 571 int sawnan = 0;
60939fb8 572
7918f24d
NC
573 PERL_ARGS_ASSERT_GROK_NUMBER;
574
60939fb8
NC
575 while (s < send && isSPACE(*s))
576 s++;
577 if (s == send) {
578 return 0;
579 } else if (*s == '-') {
580 s++;
581 numtype = IS_NUMBER_NEG;
582 }
583 else if (*s == '+')
584 s++;
585
586 if (s == send)
587 return 0;
588
589 /* next must be digit or the radix separator or beginning of infinity */
590 if (isDIGIT(*s)) {
591 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
592 overflow. */
593 UV value = *s - '0';
594 /* This construction seems to be more optimiser friendly.
595 (without it gcc does the isDIGIT test and the *s - '0' separately)
596 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
597 In theory the optimiser could deduce how far to unroll the loop
598 before checking for overflow. */
58bb9ec3
NC
599 if (++s < send) {
600 int digit = *s - '0';
60939fb8
NC
601 if (digit >= 0 && digit <= 9) {
602 value = value * 10 + digit;
58bb9ec3
NC
603 if (++s < send) {
604 digit = *s - '0';
60939fb8
NC
605 if (digit >= 0 && digit <= 9) {
606 value = value * 10 + digit;
58bb9ec3
NC
607 if (++s < send) {
608 digit = *s - '0';
60939fb8
NC
609 if (digit >= 0 && digit <= 9) {
610 value = value * 10 + digit;
58bb9ec3
NC
611 if (++s < send) {
612 digit = *s - '0';
60939fb8
NC
613 if (digit >= 0 && digit <= 9) {
614 value = value * 10 + digit;
58bb9ec3
NC
615 if (++s < send) {
616 digit = *s - '0';
60939fb8
NC
617 if (digit >= 0 && digit <= 9) {
618 value = value * 10 + digit;
58bb9ec3
NC
619 if (++s < send) {
620 digit = *s - '0';
60939fb8
NC
621 if (digit >= 0 && digit <= 9) {
622 value = value * 10 + digit;
58bb9ec3
NC
623 if (++s < send) {
624 digit = *s - '0';
60939fb8
NC
625 if (digit >= 0 && digit <= 9) {
626 value = value * 10 + digit;
58bb9ec3
NC
627 if (++s < send) {
628 digit = *s - '0';
60939fb8
NC
629 if (digit >= 0 && digit <= 9) {
630 value = value * 10 + digit;
58bb9ec3 631 if (++s < send) {
60939fb8
NC
632 /* Now got 9 digits, so need to check
633 each time for overflow. */
58bb9ec3 634 digit = *s - '0';
60939fb8
NC
635 while (digit >= 0 && digit <= 9
636 && (value < max_div_10
637 || (value == max_div_10
638 && digit <= max_mod_10))) {
639 value = value * 10 + digit;
58bb9ec3
NC
640 if (++s < send)
641 digit = *s - '0';
60939fb8
NC
642 else
643 break;
644 }
645 if (digit >= 0 && digit <= 9
51bd16da 646 && (s < send)) {
60939fb8
NC
647 /* value overflowed.
648 skip the remaining digits, don't
649 worry about setting *valuep. */
650 do {
651 s++;
652 } while (s < send && isDIGIT(*s));
653 numtype |=
654 IS_NUMBER_GREATER_THAN_UV_MAX;
655 goto skip_value;
656 }
657 }
658 }
98994639 659 }
60939fb8
NC
660 }
661 }
662 }
663 }
664 }
665 }
666 }
667 }
668 }
669 }
670 }
98994639 671 }
60939fb8 672 }
98994639 673 }
60939fb8
NC
674 numtype |= IS_NUMBER_IN_UV;
675 if (valuep)
676 *valuep = value;
677
678 skip_value:
679 if (GROK_NUMERIC_RADIX(&s, send)) {
680 numtype |= IS_NUMBER_NOT_INT;
681 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
682 s++;
98994639 683 }
60939fb8
NC
684 }
685 else if (GROK_NUMERIC_RADIX(&s, send)) {
686 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
687 /* no digits before the radix means we need digits after it */
688 if (s < send && isDIGIT(*s)) {
689 do {
690 s++;
691 } while (s < send && isDIGIT(*s));
692 if (valuep) {
693 /* integer approximation is valid - it's 0. */
694 *valuep = 0;
695 }
98994639 696 }
60939fb8
NC
697 else
698 return 0;
699 } else if (*s == 'I' || *s == 'i') {
700 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
701 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
702 s++; if (s < send && (*s == 'I' || *s == 'i')) {
703 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
704 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
705 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
706 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
707 s++;
98994639 708 }
60939fb8 709 sawinf = 1;
aa8b85de
JH
710 } else if (*s == 'N' || *s == 'n') {
711 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
712 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
713 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
714 s++;
715 sawnan = 1;
716 } else
98994639 717 return 0;
60939fb8
NC
718
719 if (sawinf) {
720 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
721 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
aa8b85de
JH
722 } else if (sawnan) {
723 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
724 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
60939fb8
NC
725 } else if (s < send) {
726 /* we can have an optional exponent part */
727 if (*s == 'e' || *s == 'E') {
728 /* The only flag we keep is sign. Blow away any "it's UV" */
729 numtype &= IS_NUMBER_NEG;
730 numtype |= IS_NUMBER_NOT_INT;
731 s++;
732 if (s < send && (*s == '-' || *s == '+'))
733 s++;
734 if (s < send && isDIGIT(*s)) {
735 do {
736 s++;
737 } while (s < send && isDIGIT(*s));
738 }
739 else
740 return 0;
741 }
742 }
743 while (s < send && isSPACE(*s))
744 s++;
745 if (s >= send)
aa8b85de 746 return numtype;
60939fb8
NC
747 if (len == 10 && memEQ(pv, "0 but true", 10)) {
748 if (valuep)
749 *valuep = 0;
750 return IS_NUMBER_IN_UV;
751 }
752 return 0;
98994639
HS
753}
754
4801ca72 755STATIC NV
98994639
HS
756S_mulexp10(NV value, I32 exponent)
757{
758 NV result = 1.0;
759 NV power = 10.0;
760 bool negative = 0;
761 I32 bit;
762
763 if (exponent == 0)
764 return value;
20f6aaab 765 if (value == 0)
66a1b24b 766 return (NV)0;
87032ba1 767
24866caa 768 /* On OpenVMS VAX we by default use the D_FLOAT double format,
67597c89 769 * and that format does not have *easy* capabilities [1] for
24866caa
CB
770 * overflowing doubles 'silently' as IEEE fp does. We also need
771 * to support G_FLOAT on both VAX and Alpha, and though the exponent
772 * range is much larger than D_FLOAT it still doesn't do silent
773 * overflow. Therefore we need to detect early whether we would
774 * overflow (this is the behaviour of the native string-to-float
775 * conversion routines, and therefore of native applications, too).
67597c89 776 *
24866caa
CB
777 * [1] Trying to establish a condition handler to trap floating point
778 * exceptions is not a good idea. */
87032ba1
JH
779
780 /* In UNICOS and in certain Cray models (such as T90) there is no
781 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
782 * There is something you can do if you are willing to use some
783 * inline assembler: the instruction is called DFI-- but that will
784 * disable *all* floating point interrupts, a little bit too large
785 * a hammer. Therefore we need to catch potential overflows before
786 * it's too late. */
353813d9
HS
787
788#if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
789 STMT_START {
c4420975 790 const NV exp_v = log10(value);
353813d9
HS
791 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
792 return NV_MAX;
793 if (exponent < 0) {
794 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
795 return 0.0;
796 while (-exponent >= NV_MAX_10_EXP) {
797 /* combination does not overflow, but 10^(-exponent) does */
798 value /= 10;
799 ++exponent;
800 }
801 }
802 } STMT_END;
87032ba1
JH
803#endif
804
353813d9
HS
805 if (exponent < 0) {
806 negative = 1;
807 exponent = -exponent;
808 }
98994639
HS
809 for (bit = 1; exponent; bit <<= 1) {
810 if (exponent & bit) {
811 exponent ^= bit;
812 result *= power;
236f0012
CB
813 /* Floating point exceptions are supposed to be turned off,
814 * but if we're obviously done, don't risk another iteration.
815 */
816 if (exponent == 0) break;
98994639
HS
817 }
818 power *= power;
819 }
820 return negative ? value / result : value * result;
821}
822
823NV
824Perl_my_atof(pTHX_ const char* s)
825{
826 NV x = 0.0;
827#ifdef USE_LOCALE_NUMERIC
97aff369 828 dVAR;
7918f24d
NC
829
830 PERL_ARGS_ASSERT_MY_ATOF;
831
98994639
HS
832 if (PL_numeric_local && IN_LOCALE) {
833 NV y;
834
835 /* Scan the number twice; once using locale and once without;
836 * choose the larger result (in absolute value). */
a36244b7 837 Perl_atof2(s, x);
98994639 838 SET_NUMERIC_STANDARD();
a36244b7 839 Perl_atof2(s, y);
98994639
HS
840 SET_NUMERIC_LOCAL();
841 if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
842 return y;
843 }
844 else
a36244b7 845 Perl_atof2(s, x);
98994639 846#else
a36244b7 847 Perl_atof2(s, x);
98994639
HS
848#endif
849 return x;
850}
851
852char*
853Perl_my_atof2(pTHX_ const char* orig, NV* value)
854{
20f6aaab 855 NV result[3] = {0.0, 0.0, 0.0};
e1ec3a88 856 const char* s = orig;
a36244b7 857#ifdef USE_PERL_ATOF
20f6aaab 858 UV accumulator[2] = {0,0}; /* before/after dp */
a36244b7 859 bool negative = 0;
e1ec3a88 860 const char* send = s + strlen(orig) - 1;
8194bf88 861 bool seen_digit = 0;
20f6aaab
AS
862 I32 exp_adjust[2] = {0,0};
863 I32 exp_acc[2] = {-1, -1};
864 /* the current exponent adjust for the accumulators */
98994639 865 I32 exponent = 0;
8194bf88 866 I32 seen_dp = 0;
20f6aaab
AS
867 I32 digit = 0;
868 I32 old_digit = 0;
8194bf88
DM
869 I32 sig_digits = 0; /* noof significant digits seen so far */
870
7918f24d
NC
871 PERL_ARGS_ASSERT_MY_ATOF2;
872
8194bf88
DM
873/* There is no point in processing more significant digits
874 * than the NV can hold. Note that NV_DIG is a lower-bound value,
875 * while we need an upper-bound value. We add 2 to account for this;
876 * since it will have been conservative on both the first and last digit.
877 * For example a 32-bit mantissa with an exponent of 4 would have
878 * exact values in the set
879 * 4
880 * 8
881 * ..
882 * 17179869172
883 * 17179869176
884 * 17179869180
885 *
886 * where for the purposes of calculating NV_DIG we would have to discount
887 * both the first and last digit, since neither can hold all values from
888 * 0..9; but for calculating the value we must examine those two digits.
889 */
890#define MAX_SIG_DIGITS (NV_DIG+2)
891
892/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
893#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
98994639 894
96a05aee
HS
895 /* leading whitespace */
896 while (isSPACE(*s))
897 ++s;
898
98994639
HS
899 /* sign */
900 switch (*s) {
901 case '-':
902 negative = 1;
903 /* fall through */
904 case '+':
905 ++s;
906 }
907
2b54f59f
YST
908 /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
909
910#ifdef HAS_STRTOD
911 if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
c042ae3a 912 const char *p = negative ? s - 1 : s;
2b54f59f
YST
913 char *endp;
914 NV rslt;
915 rslt = strtod(p, &endp);
916 if (endp != p) {
917 *value = rslt;
918 return (char *)endp;
919 }
920 }
921#endif
922
8194bf88
DM
923 /* we accumulate digits into an integer; when this becomes too
924 * large, we add the total to NV and start again */
98994639 925
8194bf88
DM
926 while (1) {
927 if (isDIGIT(*s)) {
928 seen_digit = 1;
20f6aaab 929 old_digit = digit;
8194bf88 930 digit = *s++ - '0';
20f6aaab
AS
931 if (seen_dp)
932 exp_adjust[1]++;
98994639 933
8194bf88
DM
934 /* don't start counting until we see the first significant
935 * digit, eg the 5 in 0.00005... */
936 if (!sig_digits && digit == 0)
937 continue;
938
939 if (++sig_digits > MAX_SIG_DIGITS) {
98994639 940 /* limits of precision reached */
20f6aaab
AS
941 if (digit > 5) {
942 ++accumulator[seen_dp];
943 } else if (digit == 5) {
944 if (old_digit % 2) { /* round to even - Allen */
945 ++accumulator[seen_dp];
946 }
947 }
948 if (seen_dp) {
949 exp_adjust[1]--;
950 } else {
951 exp_adjust[0]++;
952 }
8194bf88 953 /* skip remaining digits */
98994639 954 while (isDIGIT(*s)) {
98994639 955 ++s;
20f6aaab
AS
956 if (! seen_dp) {
957 exp_adjust[0]++;
958 }
98994639
HS
959 }
960 /* warn of loss of precision? */
98994639 961 }
8194bf88 962 else {
20f6aaab 963 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
8194bf88 964 /* add accumulator to result and start again */
20f6aaab
AS
965 result[seen_dp] = S_mulexp10(result[seen_dp],
966 exp_acc[seen_dp])
967 + (NV)accumulator[seen_dp];
968 accumulator[seen_dp] = 0;
969 exp_acc[seen_dp] = 0;
98994639 970 }
20f6aaab
AS
971 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
972 ++exp_acc[seen_dp];
98994639 973 }
8194bf88 974 }
e1ec3a88 975 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
8194bf88 976 seen_dp = 1;
20f6aaab 977 if (sig_digits > MAX_SIG_DIGITS) {
c86f7df5 978 do {
20f6aaab 979 ++s;
c86f7df5 980 } while (isDIGIT(*s));
20f6aaab
AS
981 break;
982 }
8194bf88
DM
983 }
984 else {
985 break;
98994639
HS
986 }
987 }
988
20f6aaab
AS
989 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
990 if (seen_dp) {
991 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
992 }
98994639 993
8194bf88 994 if (seen_digit && (*s == 'e' || *s == 'E')) {
98994639
HS
995 bool expnegative = 0;
996
997 ++s;
998 switch (*s) {
999 case '-':
1000 expnegative = 1;
1001 /* fall through */
1002 case '+':
1003 ++s;
1004 }
1005 while (isDIGIT(*s))
1006 exponent = exponent * 10 + (*s++ - '0');
1007 if (expnegative)
1008 exponent = -exponent;
1009 }
1010
20f6aaab
AS
1011
1012
98994639 1013 /* now apply the exponent */
20f6aaab
AS
1014
1015 if (seen_dp) {
1016 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1017 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1018 } else {
1019 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1020 }
98994639
HS
1021
1022 /* now apply the sign */
1023 if (negative)
20f6aaab 1024 result[2] = -result[2];
a36244b7 1025#endif /* USE_PERL_ATOF */
20f6aaab 1026 *value = result[2];
73d840c0 1027 return (char *)s;
98994639
HS
1028}
1029
55954f19
JH
1030#if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1031long double
1032Perl_my_modfl(long double x, long double *ip)
1033{
1034 *ip = aintl(x);
1035 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1036}
1037#endif
1038
1039#if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1040long double
1041Perl_my_frexpl(long double x, int *e) {
1042 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1043 return (scalbnl(x, -*e));
1044}
1045#endif
66610fdd
RGS
1046
1047/*
ed140128
AD
1048=for apidoc Perl_signbit
1049
1050Return a non-zero integer if the sign bit on an NV is set, and 0 if
1051it is not.
1052
1053If Configure detects this system has a signbit() that will work with
1054our NVs, then we just use it via the #define in perl.h. Otherwise,
1055fall back on this implementation. As a first pass, this gets everything
1056right except -0.0. Alas, catching -0.0 is the main use for this function,
1057so this is not too helpful yet. Still, at least we have the scaffolding
1058in place to support other systems, should that prove useful.
1059
1060
1061Configure notes: This function is called 'Perl_signbit' instead of a
1062plain 'signbit' because it is easy to imagine a system having a signbit()
1063function or macro that doesn't happen to work with our particular choice
1064of NVs. We shouldn't just re-#define signbit as Perl_signbit and expect
1065the standard system headers to be happy. Also, this is a no-context
1066function (no pTHX_) because Perl_signbit() is usually re-#defined in
1067perl.h as a simple macro call to the system's signbit().
1068Users should just always call Perl_signbit().
1069
1070=cut
1071*/
1072#if !defined(HAS_SIGNBIT)
1073int
1074Perl_signbit(NV x) {
1075 return (x < 0.0) ? 1 : 0;
1076}
1077#endif
1078
1079/*
66610fdd
RGS
1080 * Local variables:
1081 * c-indentation-style: bsd
1082 * c-basic-offset: 4
1083 * indent-tabs-mode: t
1084 * End:
1085 *
37442d52
RGS
1086 * ex: set ts=8 sts=4 sw=4 noet:
1087 */