This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge branch 'grok_bin_oct_hex' into blead
[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 20
7fefc6c1
KW
21=cut
22
166f8a29
DM
23This file contains all the stuff needed by perl for manipulating numeric
24values, including such things as replacements for the OS's atof() function
25
ccfc67b7
JH
26*/
27
98994639
HS
28#include "EXTERN.h"
29#define PERL_IN_NUMERIC_C
30#include "perl.h"
31
9ec8aea5
KW
32#ifdef Perl_strtod
33
34PERL_STATIC_INLINE NV
35S_strtod(pTHX_ const char * const s, char ** e)
36{
37 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
38 NV result;
39
40 STORE_LC_NUMERIC_SET_TO_NEEDED();
41
42# ifdef USE_QUADMATH
43
44 result = strtoflt128(s, e);
45
46# elif defined(HAS_STRTOLD) && defined(HAS_LONG_DOUBLE) \
47 && defined(USE_LONG_DOUBLE)
48# if defined(__MINGW64_VERSION_MAJOR)
49 /***********************************************
50 We are unable to use strtold because of
51 https://sourceforge.net/p/mingw-w64/bugs/711/
52 &
53 https://sourceforge.net/p/mingw-w64/bugs/725/
54
55 but __mingw_strtold is fine.
56 ***********************************************/
57
58 result = __mingw_strtold(s, e);
59
60# else
61
62 result = strtold(s, e);
63
64# endif
65# elif defined(HAS_STRTOD)
66
67 result = strtod(s, e);
68
02fd9d54
KW
69# else
70# error No strtod() equivalent found
9ec8aea5
KW
71# endif
72
73 RESTORE_LC_NUMERIC();
74
75 return result;
76}
77
78#endif /* #ifdef Perl_strtod */
79
80/*
81
82=for apidoc my_strtod
83
84This function is equivalent to the libc strtod() function, and is available
85even on platforms that lack plain strtod(). Its return value is the best
86available precision depending on platform capabilities and F<Configure>
87options.
88
89It properly handles the locale radix character, meaning it expects a dot except
90when called from within the scope of S<C<use locale>>, in which case the radix
91character should be that specified by the current locale.
92
e7a3fd45 93The synonym Strtod() may be used instead.
9ec8aea5
KW
94
95=cut
96
97*/
98
99NV
0f3d8cd4 100Perl_my_strtod(const char * const s, char **e)
9ec8aea5
KW
101{
102 dTHX;
103
104 PERL_ARGS_ASSERT_MY_STRTOD;
105
106#ifdef Perl_strtod
107
108 return S_strtod(aTHX_ s, e);
109
110#else
111
112 {
113 NV result;
114 char ** end_ptr = NULL;
115
116 *end_ptr = my_atof2(s, &result);
117 if (e) {
118 *e = *end_ptr;
119 }
120
121 if (! *end_ptr) {
122 result = 0.0;
123 }
124
125 return result;
126 }
127
128#endif
129
130}
131
132
98994639 133U32
ddeaf645 134Perl_cast_ulong(NV f)
98994639
HS
135{
136 if (f < 0.0)
137 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
138 if (f < U32_MAX_P1) {
139#if CASTFLAGS & 2
140 if (f < U32_MAX_P1_HALF)
141 return (U32) f;
142 f -= U32_MAX_P1_HALF;
071db91b 143 return ((U32) f) | (1 + (U32_MAX >> 1));
98994639
HS
144#else
145 return (U32) f;
146#endif
147 }
148 return f > 0 ? U32_MAX : 0 /* NaN */;
149}
150
151I32
ddeaf645 152Perl_cast_i32(NV f)
98994639
HS
153{
154 if (f < I32_MAX_P1)
155 return f < I32_MIN ? I32_MIN : (I32) f;
156 if (f < U32_MAX_P1) {
157#if CASTFLAGS & 2
158 if (f < U32_MAX_P1_HALF)
159 return (I32)(U32) f;
160 f -= U32_MAX_P1_HALF;
071db91b 161 return (I32)(((U32) f) | (1 + (U32_MAX >> 1)));
98994639
HS
162#else
163 return (I32)(U32) f;
164#endif
165 }
166 return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
167}
168
169IV
ddeaf645 170Perl_cast_iv(NV f)
98994639
HS
171{
172 if (f < IV_MAX_P1)
173 return f < IV_MIN ? IV_MIN : (IV) f;
174 if (f < UV_MAX_P1) {
175#if CASTFLAGS & 2
176 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
177 if (f < UV_MAX_P1_HALF)
178 return (IV)(UV) f;
179 f -= UV_MAX_P1_HALF;
071db91b 180 return (IV)(((UV) f) | (1 + (UV_MAX >> 1)));
98994639
HS
181#else
182 return (IV)(UV) f;
183#endif
184 }
185 return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
186}
187
188UV
ddeaf645 189Perl_cast_uv(NV f)
98994639
HS
190{
191 if (f < 0.0)
192 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
193 if (f < UV_MAX_P1) {
194#if CASTFLAGS & 2
195 if (f < UV_MAX_P1_HALF)
196 return (UV) f;
197 f -= UV_MAX_P1_HALF;
071db91b 198 return ((UV) f) | (1 + (UV_MAX >> 1));
98994639
HS
199#else
200 return (UV) f;
201#endif
202 }
203 return f > 0 ? UV_MAX : 0 /* NaN */;
204}
205
53305cf1
NC
206/*
207=for apidoc grok_bin
98994639 208
53305cf1
NC
209converts a string representing a binary number to numeric form.
210
6974a337
KW
211On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
212conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
213scan stops at the end of the string, or at just before the first invalid
214character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
215encountering an invalid character (except NUL) will also trigger a warning. On
216return C<*len_p> is set to the length of the scanned string, and C<*flags>
217gives output flags.
53305cf1 218
7fc63493 219If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
796b6530
KW
220and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_bin>
221returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
6974a337
KW
222and writes an approximation of the correct value into C<*result> (which is an
223NV; or the approximation is discarded if C<result> is NULL).
53305cf1 224
796b6530 225The binary number may optionally be prefixed with C<"0b"> or C<"b"> unless
6974a337
KW
226C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
227
228If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
229digits may be separated from each other by a single underscore; also a single
230leading underscore is accepted.
53305cf1 231
ceea512d
KW
232=for apidoc Amnh||PERL_SCAN_ALLOW_UNDERSCORES
233=for apidoc Amnh||PERL_SCAN_DISALLOW_PREFIX
234=for apidoc Amnh||PERL_SCAN_GREATER_THAN_UV_MAX
235=for apidoc Amnh||PERL_SCAN_SILENT_ILLDIGIT
ceea512d 236
53305cf1 237=cut
02470786
KW
238
239Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
240which suppresses any message for non-portable numbers that are still valid
241on this platform.
53305cf1
NC
242 */
243
244UV
7918f24d
NC
245Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
246{
7918f24d
NC
247 PERL_ARGS_ASSERT_GROK_BIN;
248
bcfb98ec 249 return grok_bin(start, len_p, flags, result);
98994639
HS
250}
251
53305cf1
NC
252/*
253=for apidoc grok_hex
254
255converts a string representing a hex number to numeric form.
256
2d7f6611 257On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
6974a337
KW
258conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
259scan stops at the end of the string, or at just before the first invalid
260character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
261encountering an invalid character (except NUL) will also trigger a warning. On
262return C<*len_p> is set to the length of the scanned string, and C<*flags>
263gives output flags.
53305cf1 264
796b6530
KW
265If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
266and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_hex>
267returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
6974a337
KW
268and writes an approximation of the correct value into C<*result> (which is an
269NV; or the approximation is discarded if C<result> is NULL).
53305cf1 270
796b6530 271The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless
6974a337
KW
272C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
273
274If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
275digits may be separated from each other by a single underscore; also a single
276leading underscore is accepted.
53305cf1
NC
277
278=cut
02470786 279
2e046c5b 280Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
baf48926 281which suppresses any message for non-portable numbers, but which are valid
02470786 282on this platform.
53305cf1
NC
283 */
284
285UV
7918f24d
NC
286Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
287{
bcfb98ec
KW
288 PERL_ARGS_ASSERT_GROK_HEX;
289
290 return grok_hex(start, len_p, flags, result);
291}
292
d05c9ddb
KW
293/*
294=for apidoc grok_oct
295
296converts a string representing an octal number to numeric form.
297
6974a337
KW
298On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
299conversion flags, and C<result> should be C<NULL> or a pointer to an NV. The
300scan stops at the end of the string, or at just before the first invalid
301character. Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
302encountering an invalid character (except NUL) will also trigger a warning. On
303return C<*len_p> is set to the length of the scanned string, and C<*flags>
304gives output flags.
d05c9ddb
KW
305
306If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
307and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_oct>
308returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
6974a337
KW
309and writes an approximation of the correct value into C<*result> (which is an
310NV; or the approximation is discarded if C<result> is NULL).
311
312If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
313digits may be separated from each other by a single underscore; also a single
314leading underscore is accepted.
d05c9ddb 315
6974a337
KW
316The the C<PERL_SCAN_DISALLOW_PREFIX> flag is always treated as being set for
317this function.
d05c9ddb
KW
318
319=cut
320
321Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
322which suppresses any message for non-portable numbers, but which are valid
323on this platform.
324 */
325
326UV
327Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
328{
329 PERL_ARGS_ASSERT_GROK_OCT;
330
331 return grok_oct(start, len_p, flags, result);
332}
333
c969ff22
KW
334STATIC void
335S_output_non_portable(pTHX_ const U8 base)
336{
337 /* Display the proper message for a number in the given input base not
338 * fitting in 32 bits */
339 const char * which = (base == 2)
340 ? "Binary number > 0b11111111111111111111111111111111"
341 : (base == 8)
342 ? "Octal number > 037777777777"
343 : "Hexadecimal number > 0xffffffff";
344
345 PERL_ARGS_ASSERT_OUTPUT_NON_PORTABLE;
346
347 /* Also there are listings for the other two. That's because, since they
348 * are the first word, it would be hard for a user to find them there
349 * starting with a %s */
350 /* diag_listed_as: Hexadecimal number > 0xffffffff non-portable */
351 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "%s non-portable", which);
352}
353
bcfb98ec
KW
354UV
355Perl_grok_bin_oct_hex(pTHX_ const char *start,
356 STRLEN *len_p,
357 I32 *flags,
358 NV *result,
c969ff22 359 const unsigned shift, /* 1 for binary; 3 for octal;
bcfb98ec 360 4 for hex */
c969ff22
KW
361 const U8 class_bit,
362 const char prefix
363 )
364
bcfb98ec 365{
c969ff22
KW
366 const char *s0 = start;
367 const char *s;
53305cf1 368 STRLEN len = *len_p;
c969ff22 369 STRLEN bytes_so_far; /* How many real digits have been processed */
53305cf1
NC
370 UV value = 0;
371 NV value_nv = 0;
c969ff22
KW
372 const PERL_UINT_FAST8_T base = 1 << shift; /* 2, 8, or 16 */
373 const UV max_div= UV_MAX / base; /* Value above which, the next digit
374 processed would overflow */
4b24f703
KW
375 const I32 input_flags = *flags;
376 const bool allow_underscores =
377 cBOOL(input_flags & PERL_SCAN_ALLOW_UNDERSCORES);
c969ff22 378 bool overflowed = FALSE;
cddf31e4
KW
379
380 /* In overflows, this keeps track of how much to multiply the overflowed NV
381 * by as we continue to parse the remaining digits */
c969ff22
KW
382 UV factor;
383
384 /* This function unifies the core of grok_bin, grok_oct, and grok_hex. It
385 * is optimized for hex conversion. For example, it uses XDIGIT_VALUE to
386 * find the numeric value of a digit. That requires more instructions than
387 * OCTAL_VALUE would, but gives the same result for the narrowed range of
388 * octal digits; same for binary. If it were ever critical to squeeze more
389 * performance from this, the function could become grok_hex, and a regen
390 * perl script could scan it and write out two edited copies for the other
391 * two functions. That would improve the performance of all three
392 * somewhat. Besides eliminating XDIGIT_VALUE for the other two, extra
393 * parameters are now passed to this to avoid conditionals. Those could
394 * become declared consts, like:
395 * const U8 base = 16;
396 * const U8 base = 8;
397 * ...
398 */
98994639 399
bcfb98ec
KW
400 PERL_ARGS_ASSERT_GROK_BIN_OCT_HEX;
401
402 ASSUME(inRANGE(shift, 1, 4) && shift != 2);
7918f24d 403
4b24f703
KW
404 /* Clear output flags; unlikely to find a problem that sets them */
405 *flags = 0;
406
c969ff22 407 if (!(input_flags & PERL_SCAN_DISALLOW_PREFIX)) {
bcfb98ec
KW
408
409 /* strip off leading b or 0b; x or 0x.
410 for compatibility silently suffer "b" and "0b" as valid binary; "x"
411 and "0x" as valid hex numbers. */
a4c04bdc 412 if (len >= 1) {
c969ff22
KW
413 if (isALPHA_FOLD_EQ(s0[0], prefix)) {
414 s0++;
a4c04bdc
NC
415 len--;
416 }
c969ff22
KW
417 else if (len >= 2 && s0[0] == '0' && (isALPHA_FOLD_EQ(s0[1], prefix))) {
418 s0+=2;
a4c04bdc
NC
419 len-=2;
420 }
421 }
98994639
HS
422 }
423
c969ff22
KW
424 s = s0; /* s0 potentially advanced from 'start' */
425
426 /* Unroll the loop so that the first 7 digits are branchless except for the
427 * switch. An eighth one could overflow a 32 bit word. This should
428 * completely handle the common case without needing extra checks */
429 switch (len) {
430 case 0:
431 return 0;
432 default:
433 if (! _generic_isCC(*s, class_bit)) break;
434 value = (value << shift) | XDIGIT_VALUE(*s);
435 s++;
436 /* FALLTHROUGH */
437 case 6:
438 if (! _generic_isCC(*s, class_bit)) break;
439 value = (value << shift) | XDIGIT_VALUE(*s);
440 s++;
441 /* FALLTHROUGH */
442 case 5:
443 if (! _generic_isCC(*s, class_bit)) break;
444 value = (value << shift) | XDIGIT_VALUE(*s);
445 s++;
446 /* FALLTHROUGH */
447 case 4:
448 if (! _generic_isCC(*s, class_bit)) break;
449 value = (value << shift) | XDIGIT_VALUE(*s);
450 s++;
451 /* FALLTHROUGH */
452 case 3:
453 if (! _generic_isCC(*s, class_bit)) break;
454 value = (value << shift) | XDIGIT_VALUE(*s);
455 s++;
456 /* FALLTHROUGH */
457 case 2:
458 if (! _generic_isCC(*s, class_bit)) break;
459 value = (value << shift) | XDIGIT_VALUE(*s);
460 s++;
461 /* FALLTHROUGH */
462 case 1:
463 if (! _generic_isCC(*s, class_bit)) break;
464 value = (value << shift) | XDIGIT_VALUE(*s);
465
466 if (LIKELY(len <= 7)) {
467 return value;
468 }
469
470 s++;
471 break;
472 }
473
474 bytes_so_far = s - s0;
475 factor = shift << bytes_so_far;
476 len -= bytes_so_far;
477
478 for (; len--; s++) {
bcfb98ec 479 if (_generic_isCC(*s, class_bit)) {
53305cf1
NC
480 /* Write it in this wonky order with a goto to attempt to get the
481 compiler to make the common case integer-only loop pretty tight.
35e5392d
KW
482 With gcc seems to be much straighter code than old scan_hex.
483 (khw suspects that adding a LIKELY() just above would do the
484 same thing) */
53305cf1 485 redo:
ebf83045
KW
486 if (LIKELY(value <= max_div)) {
487 value = (value << shift) | XDIGIT_VALUE(*s);
488 /* Note XDIGIT_VALUE() is branchless, works on binary
489 * and octal as well, so can be used here, without
490 * slowing those down */
491 factor <<= shift;
492 continue;
493 }
cddf31e4
KW
494
495 /* Bah. We are about to overflow. Instead, add the unoverflowed
496 * value to an NV that contains an approximation to the correct
497 * value. Each time through the loop we have increased 'factor' so
498 * that it gives how much the current approximation needs to
499 * effectively be shifted to make room for this new value */
500 value_nv *= (NV) factor;
501 value_nv += (NV) value;
502
503 /* Then we keep accumulating digits, until all are parsed. We
504 * start over using the current input value. This will be added to
505 * 'value_nv' eventually, either when all digits are gone, or we
506 * have overflowed this fresh start. */
507 value = XDIGIT_VALUE(*s);
508 factor = 1 << shift;
509
c969ff22
KW
510 if (! overflowed) {
511 overflowed = TRUE;
bcfb98ec
KW
512 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
513 "Integer overflow in %s number",
514 (base == 16) ? "hexadecimal"
515 : (base == 2)
516 ? "binary"
517 : "octal");
53305cf1 518 }
53305cf1
NC
519 continue;
520 }
ebf83045 521
bcfb98ec
KW
522 if ( *s == '_'
523 && len
524 && allow_underscores
525 && _generic_isCC(s[1], class_bit))
526 {
527 --len;
528 ++s;
529 goto redo;
530 }
ebf83045 531
c969ff22
KW
532 if ( *s
533 && ! (input_flags & PERL_SCAN_SILENT_ILLDIGIT)
ebf83045 534 && ckWARN(WARN_DIGIT))
bcfb98ec
KW
535 {
536 if (base != 8) {
537 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
538 "Illegal %s digit '%c' ignored",
c969ff22
KW
539 ((base == 2)
540 ? "binary"
bcfb98ec
KW
541 : "hexadecimal"),
542 *s);
543 }
544 else if (isDIGIT(*s)) { /* octal base */
545
546 /* Allow \octal to work the DWIM way (that is, stop scanning as
547 * soon as non-octal characters are seen, complain only if
548 * someone seems to want to use the digits eight and nine.
549 * Since we know it is not octal, then if isDIGIT, must be an 8
550 * or 9). */
551 Perl_warner(aTHX_ packWARN(WARN_DIGIT),
552 "Illegal octal digit '%c' ignored", *s);
553 }
554 }
ebf83045 555
53305cf1
NC
556 break;
557 }
19c1206d 558
c969ff22 559 *len_p = s - start;
cddf31e4 560
c969ff22 561 if (LIKELY(! overflowed)) {
53305cf1 562#if UVSIZE > 4
c969ff22 563 if ( UNLIKELY(value > 0xffffffff)
4b24f703 564 && ! (input_flags & PERL_SCAN_SILENT_NON_PORTABLE))
c969ff22
KW
565 {
566 output_non_portable(base);
567 }
53305cf1 568#endif
c969ff22 569 return value;
53305cf1 570 }
bcfb98ec 571
c969ff22
KW
572 /* Overflowed: Calculate the final overflow approximation */
573 value_nv *= (NV) factor;
574 value_nv += (NV) value;
cddf31e4 575
c969ff22 576 output_non_portable(base);
ebf83045 577
53305cf1
NC
578 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
579 if (result)
580 *result = value_nv;
581 return UV_MAX;
582}
583
584/*
53305cf1
NC
585=for apidoc scan_bin
586
72d33970 587For backwards compatibility. Use C<grok_bin> instead.
53305cf1
NC
588
589=for apidoc scan_hex
590
72d33970 591For backwards compatibility. Use C<grok_hex> instead.
53305cf1
NC
592
593=for apidoc scan_oct
594
72d33970 595For backwards compatibility. Use C<grok_oct> instead.
53305cf1
NC
596
597=cut
598 */
599
600NV
73d840c0 601Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
602{
603 NV rnv;
604 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 605 const UV ruv = grok_bin (start, &len, &flags, &rnv);
53305cf1 606
7918f24d
NC
607 PERL_ARGS_ASSERT_SCAN_BIN;
608
53305cf1
NC
609 *retlen = len;
610 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
611}
612
613NV
73d840c0 614Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
615{
616 NV rnv;
617 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 618 const UV ruv = grok_oct (start, &len, &flags, &rnv);
53305cf1 619
7918f24d
NC
620 PERL_ARGS_ASSERT_SCAN_OCT;
621
53305cf1
NC
622 *retlen = len;
623 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
624}
625
626NV
73d840c0 627Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
53305cf1
NC
628{
629 NV rnv;
630 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
73d840c0 631 const UV ruv = grok_hex (start, &len, &flags, &rnv);
53305cf1 632
7918f24d
NC
633 PERL_ARGS_ASSERT_SCAN_HEX;
634
53305cf1
NC
635 *retlen = len;
636 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
98994639
HS
637}
638
639/*
640=for apidoc grok_numeric_radix
641
642Scan and skip for a numeric decimal separator (radix).
643
644=cut
645 */
646bool
647Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
648{
7918f24d
NC
649 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
650
7ea85fa8
KW
651#ifdef USE_LOCALE_NUMERIC
652
d6ded950 653 if (IN_LC(LC_NUMERIC)) {
f0dafd73
KW
654 STRLEN len;
655 char * radix;
656 bool matches_radix = FALSE;
67d796ae 657 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
f0dafd73 658
a1395eaf 659 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
f0dafd73
KW
660
661 radix = SvPV(PL_numeric_radix_sv, len);
662 radix = savepvn(radix, len);
663
21431899 664 RESTORE_LC_NUMERIC();
f0dafd73
KW
665
666 if (*sp + len <= send) {
667 matches_radix = memEQ(*sp, radix, len);
668 }
669
670 Safefree(radix);
671
672 if (matches_radix) {
673 *sp += len;
674 return TRUE;
675 }
98994639 676 }
f0dafd73 677
98994639 678#endif
7918f24d 679
f0dafd73
KW
680 /* always try "." if numeric radix didn't match because
681 * we may have data from different locales mixed */
98994639
HS
682 if (*sp < send && **sp == '.') {
683 ++*sp;
684 return TRUE;
685 }
f0dafd73 686
98994639
HS
687 return FALSE;
688}
689
569f27e5 690/*
ff4eb398
JH
691=for apidoc grok_infnan
692
796b6530 693Helper for C<grok_number()>, accepts various ways of spelling "infinity"
ff4eb398
JH
694or "not a number", and returns one of the following flag combinations:
695
5962c2f6 696 IS_NUMBER_INFINITY
ff4eb398 697 IS_NUMBER_NAN
5962c2f6 698 IS_NUMBER_INFINITY | IS_NUMBER_NEG
ff4eb398
JH
699 IS_NUMBER_NAN | IS_NUMBER_NEG
700 0
701
796b6530 702possibly |-ed with C<IS_NUMBER_TRAILING>.
b489e20f 703
796b6530 704If an infinity or a not-a-number is recognized, C<*sp> will point to
62bdc035 705one byte past the end of the recognized string. If the recognition fails,
796b6530 706zero is returned, and C<*sp> will not move.
ff4eb398 707
ceea512d
KW
708=for apidoc Amn|bool|IS_NUMBER_GREATER_THAN_UV_MAX
709=for apidoc Amn|bool|IS_NUMBER_INFINITY
710=for apidoc Amn|bool|IS_NUMBER_IN_UV
711=for apidoc Amn|bool|IS_NUMBER_NAN
712=for apidoc Amn|bool|IS_NUMBER_NEG
713=for apidoc Amn|bool|IS_NUMBER_NOT_INT
714
ff4eb398
JH
715=cut
716*/
717
718int
3823048b 719Perl_grok_infnan(pTHX_ const char** sp, const char* send)
ff4eb398
JH
720{
721 const char* s = *sp;
722 int flags = 0;
a5dc2484 723#if defined(NV_INF) || defined(NV_NAN)
62bdc035 724 bool odh = FALSE; /* one-dot-hash: 1.#INF */
ff4eb398
JH
725
726 PERL_ARGS_ASSERT_GROK_INFNAN;
727
8c12dc63
JH
728 if (*s == '+') {
729 s++; if (s == send) return 0;
730 }
731 else if (*s == '-') {
ff4eb398
JH
732 flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */
733 s++; if (s == send) return 0;
734 }
735
736 if (*s == '1') {
62bdc035
JH
737 /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN)
738 * Let's keep the dot optional. */
ff4eb398
JH
739 s++; if (s == send) return 0;
740 if (*s == '.') {
741 s++; if (s == send) return 0;
742 }
743 if (*s == '#') {
744 s++; if (s == send) return 0;
745 } else
746 return 0;
e855f543 747 odh = TRUE;
ff4eb398
JH
748 }
749
305b8651 750 if (isALPHA_FOLD_EQ(*s, 'I')) {
62bdc035
JH
751 /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */
752
305b8651 753 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
ff4eb398 754 s++; if (s == send) return 0;
305b8651 755 if (isALPHA_FOLD_EQ(*s, 'F')) {
ff4eb398 756 s++;
b8974fcb
JH
757 if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
758 int fail =
759 flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING;
760 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail;
761 s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail;
762 s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail;
763 s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail;
3396ed30 764 s++;
b8974fcb
JH
765 } else if (odh) {
766 while (*s == '0') { /* 1.#INF00 */
767 s++;
768 }
3396ed30 769 }
b489e20f
JH
770 while (s < send && isSPACE(*s))
771 s++;
772 if (s < send && *s) {
3396ed30 773 flags |= IS_NUMBER_TRAILING;
fae4db12 774 }
ff4eb398
JH
775 flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
776 }
e855f543 777 else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
ff4eb398
JH
778 s++;
779 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
fae4db12
JH
780 while (*s == '0') { /* 1.#IND00 */
781 s++;
782 }
1e9aa12f
JH
783 if (*s) {
784 flags |= IS_NUMBER_TRAILING;
785 }
ff4eb398
JH
786 } else
787 return 0;
ff4eb398
JH
788 }
789 else {
62bdc035 790 /* Maybe NAN of some sort */
3823048b
JH
791
792 if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
793 /* snan, qNaN */
794 /* XXX do something with the snan/qnan difference */
795 s++; if (s == send) return 0;
796 }
797
798 if (isALPHA_FOLD_EQ(*s, 'N')) {
799 s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
800 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
801 s++;
802
803 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
dca9f615
KW
804 if (s == send) {
805 return flags;
806 }
3823048b
JH
807
808 /* NaN can be followed by various stuff (NaNQ, NaNS), but
809 * there are also multiple different NaN values, and some
810 * implementations output the "payload" values,
811 * e.g. NaN123, NAN(abc), while some legacy implementations
812 * have weird stuff like NaN%. */
813 if (isALPHA_FOLD_EQ(*s, 'q') ||
814 isALPHA_FOLD_EQ(*s, 's')) {
815 /* "nanq" or "nans" are ok, though generating
816 * these portably is tricky. */
817 s++;
81d11450
KW
818 if (s == send) {
819 return flags;
820 }
3823048b
JH
821 }
822 if (*s == '(') {
823 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
824 const char *t;
825 s++;
826 if (s == send) {
827 return flags | IS_NUMBER_TRAILING;
828 }
829 t = s + 1;
830 while (t < send && *t && *t != ')') {
831 t++;
832 }
833 if (t == send) {
834 return flags | IS_NUMBER_TRAILING;
835 }
836 if (*t == ')') {
837 int nantype;
838 UV nanval;
839 if (s[0] == '0' && s + 2 < t &&
840 isALPHA_FOLD_EQ(s[1], 'x') &&
841 isXDIGIT(s[2])) {
842 STRLEN len = t - s;
843 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
844 nanval = grok_hex(s, &len, &flags, NULL);
845 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
846 nantype = 0;
847 } else {
848 nantype = IS_NUMBER_IN_UV;
849 }
850 s += len;
851 } else if (s[0] == '0' && s + 2 < t &&
852 isALPHA_FOLD_EQ(s[1], 'b') &&
853 (s[2] == '0' || s[2] == '1')) {
854 STRLEN len = t - s;
855 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
856 nanval = grok_bin(s, &len, &flags, NULL);
857 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
858 nantype = 0;
859 } else {
860 nantype = IS_NUMBER_IN_UV;
861 }
862 s += len;
863 } else {
864 const char *u;
865 nantype =
866 grok_number_flags(s, t - s, &nanval,
867 PERL_SCAN_TRAILING |
868 PERL_SCAN_ALLOW_UNDERSCORES);
869 /* Unfortunately grok_number_flags() doesn't
870 * tell how far we got and the ')' will always
871 * be "trailing", so we need to double-check
872 * whether we had something dubious. */
873 for (u = s; u < t; u++) {
874 if (!isDIGIT(*u)) {
875 flags |= IS_NUMBER_TRAILING;
876 break;
877 }
878 }
879 s = u;
880 }
881
882 /* XXX Doesn't do octal: nan("0123").
883 * Probably not a big loss. */
884
885 if ((nantype & IS_NUMBER_NOT_INT) ||
886 !(nantype && IS_NUMBER_IN_UV)) {
887 /* XXX the nanval is currently unused, that is,
888 * not inserted as the NaN payload of the NV.
889 * But the above code already parses the C99
890 * nan(...) format. See below, and see also
891 * the nan() in POSIX.xs.
892 *
893 * Certain configuration combinations where
894 * NVSIZE is greater than UVSIZE mean that
895 * a single UV cannot contain all the possible
896 * NaN payload bits. There would need to be
897 * some more generic syntax than "nan($uv)".
898 *
899 * Issues to keep in mind:
900 *
901 * (1) In most common cases there would
902 * not be an integral number of bytes that
903 * could be set, only a certain number of bits.
904 * For example for the common case of
905 * NVSIZE == UVSIZE == 8 there is room for 52
906 * bits in the payload, but the most significant
907 * bit is commonly reserved for the
908 * signaling/quiet bit, leaving 51 bits.
909 * Furthermore, the C99 nan() is supposed
910 * to generate quiet NaNs, so it is doubtful
911 * whether it should be able to generate
912 * signaling NaNs. For the x86 80-bit doubles
913 * (if building a long double Perl) there would
914 * be 62 bits (s/q bit being the 63rd).
915 *
916 * (2) Endianness of the payload bits. If the
917 * payload is specified as an UV, the low-order
918 * bits of the UV are naturally little-endianed
919 * (rightmost) bits of the payload. The endianness
920 * of UVs and NVs can be different. */
921 return 0;
922 }
923 if (s < t) {
924 flags |= IS_NUMBER_TRAILING;
925 }
926 } else {
927 /* Looked like nan(...), but no close paren. */
928 flags |= IS_NUMBER_TRAILING;
929 }
930 } else {
931 while (s < send && isSPACE(*s))
932 s++;
933 if (s < send && *s) {
934 /* Note that we here implicitly accept (parse as
935 * "nan", but with warnings) also any other weird
936 * trailing stuff for "nan". In the above we just
937 * check that if we got the C99-style "nan(...)",
938 * the "..." looks sane.
939 * If in future we accept more ways of specifying
940 * the nan payload, the accepting would happen around
941 * here. */
942 flags |= IS_NUMBER_TRAILING;
943 }
944 }
945 s = send;
946 }
947 else
948 return 0;
ff4eb398
JH
949 }
950
b489e20f
JH
951 while (s < send && isSPACE(*s))
952 s++;
953
a5dc2484
JH
954#else
955 PERL_UNUSED_ARG(send);
956#endif /* #if defined(NV_INF) || defined(NV_NAN) */
a1fe7cea
JH
957 *sp = s;
958 return flags;
ff4eb398
JH
959}
960
13393a5e 961/*
3823048b 962=for apidoc grok_number_flags
13393a5e
JH
963
964Recognise (or not) a number. The type of the number is returned
965(0 if unrecognised), otherwise it is a bit-ORed combination of
796b6530
KW
966C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>,
967C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h).
968
969If the value of the number can fit in a UV, it is returned in C<*valuep>.
970C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV>
971will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned
972to during processing even though C<IS_NUMBER_IN_UV> is not set on return.
973If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when
974C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur.
975
976C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were
977seen (in which case C<*valuep> gives the true value truncated to an integer), and
978C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the
979absolute value). C<IS_NUMBER_IN_UV> is not set if e notation was used or the
13393a5e
JH
980number is larger than a UV.
981
982C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
983non-numeric text on an otherwise successful I<grok>, setting
984C<IS_NUMBER_TRAILING> on the result.
985
0b929024
KW
986=for apidoc Amnh||PERL_SCAN_TRAILING
987
13393a5e
JH
988=for apidoc grok_number
989
796b6530 990Identical to C<grok_number_flags()> with C<flags> set to zero.
13393a5e
JH
991
992=cut
993 */
994int
995Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
996{
997 PERL_ARGS_ASSERT_GROK_NUMBER;
998
999 return grok_number_flags(pv, len, valuep, 0);
1000}
1001
945b524a
JH
1002static const UV uv_max_div_10 = UV_MAX / 10;
1003static const U8 uv_max_mod_10 = UV_MAX % 10;
1004
3f7602fa 1005int
3823048b 1006Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
3f7602fa 1007{
60939fb8 1008 const char *s = pv;
c4420975 1009 const char * const send = pv + len;
ae776a2c 1010 const char *d;
60939fb8 1011 int numtype = 0;
60939fb8 1012
3823048b 1013 PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
7918f24d 1014
60939fb8
NC
1015 while (s < send && isSPACE(*s))
1016 s++;
1017 if (s == send) {
1018 return 0;
1019 } else if (*s == '-') {
1020 s++;
1021 numtype = IS_NUMBER_NEG;
1022 }
1023 else if (*s == '+')
aa42a541 1024 s++;
60939fb8
NC
1025
1026 if (s == send)
1027 return 0;
1028
ae776a2c 1029 /* The first digit (after optional sign): note that might
8c12dc63 1030 * also point to "infinity" or "nan", or "1.#INF". */
ae776a2c
JH
1031 d = s;
1032
8c12dc63 1033 /* next must be digit or the radix separator or beginning of infinity/nan */
60939fb8
NC
1034 if (isDIGIT(*s)) {
1035 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1036 overflow. */
1037 UV value = *s - '0';
1038 /* This construction seems to be more optimiser friendly.
1039 (without it gcc does the isDIGIT test and the *s - '0' separately)
1040 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
1041 In theory the optimiser could deduce how far to unroll the loop
1042 before checking for overflow. */
58bb9ec3
NC
1043 if (++s < send) {
1044 int digit = *s - '0';
f85b645f 1045 if (inRANGE(digit, 0, 9)) {
60939fb8 1046 value = value * 10 + digit;
58bb9ec3
NC
1047 if (++s < send) {
1048 digit = *s - '0';
f85b645f 1049 if (inRANGE(digit, 0, 9)) {
60939fb8 1050 value = value * 10 + digit;
58bb9ec3
NC
1051 if (++s < send) {
1052 digit = *s - '0';
f85b645f 1053 if (inRANGE(digit, 0, 9)) {
60939fb8 1054 value = value * 10 + digit;
58bb9ec3
NC
1055 if (++s < send) {
1056 digit = *s - '0';
f85b645f 1057 if (inRANGE(digit, 0, 9)) {
60939fb8 1058 value = value * 10 + digit;
58bb9ec3
NC
1059 if (++s < send) {
1060 digit = *s - '0';
f85b645f 1061 if (inRANGE(digit, 0, 9)) {
60939fb8 1062 value = value * 10 + digit;
58bb9ec3
NC
1063 if (++s < send) {
1064 digit = *s - '0';
f85b645f 1065 if (inRANGE(digit, 0, 9)) {
60939fb8 1066 value = value * 10 + digit;
58bb9ec3
NC
1067 if (++s < send) {
1068 digit = *s - '0';
f85b645f 1069 if (inRANGE(digit, 0, 9)) {
60939fb8 1070 value = value * 10 + digit;
58bb9ec3
NC
1071 if (++s < send) {
1072 digit = *s - '0';
f85b645f 1073 if (inRANGE(digit, 0, 9)) {
60939fb8 1074 value = value * 10 + digit;
58bb9ec3 1075 if (++s < send) {
60939fb8
NC
1076 /* Now got 9 digits, so need to check
1077 each time for overflow. */
58bb9ec3 1078 digit = *s - '0';
f85b645f 1079 while ( inRANGE(digit, 0, 9)
945b524a
JH
1080 && (value < uv_max_div_10
1081 || (value == uv_max_div_10
1082 && digit <= uv_max_mod_10))) {
60939fb8 1083 value = value * 10 + digit;
58bb9ec3
NC
1084 if (++s < send)
1085 digit = *s - '0';
60939fb8
NC
1086 else
1087 break;
1088 }
f85b645f 1089 if (inRANGE(digit, 0, 9)
51bd16da 1090 && (s < send)) {
60939fb8
NC
1091 /* value overflowed.
1092 skip the remaining digits, don't
1093 worry about setting *valuep. */
1094 do {
1095 s++;
1096 } while (s < send && isDIGIT(*s));
1097 numtype |=
1098 IS_NUMBER_GREATER_THAN_UV_MAX;
1099 goto skip_value;
1100 }
1101 }
1102 }
98994639 1103 }
60939fb8
NC
1104 }
1105 }
1106 }
1107 }
1108 }
1109 }
1110 }
1111 }
1112 }
1113 }
1114 }
98994639 1115 }
60939fb8 1116 }
98994639 1117 }
60939fb8
NC
1118 numtype |= IS_NUMBER_IN_UV;
1119 if (valuep)
1120 *valuep = value;
1121
1122 skip_value:
1123 if (GROK_NUMERIC_RADIX(&s, send)) {
1124 numtype |= IS_NUMBER_NOT_INT;
1125 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
1126 s++;
98994639 1127 }
60939fb8
NC
1128 }
1129 else if (GROK_NUMERIC_RADIX(&s, send)) {
1130 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1131 /* no digits before the radix means we need digits after it */
1132 if (s < send && isDIGIT(*s)) {
1133 do {
1134 s++;
1135 } while (s < send && isDIGIT(*s));
1136 if (valuep) {
1137 /* integer approximation is valid - it's 0. */
1138 *valuep = 0;
1139 }
98994639 1140 }
60939fb8 1141 else
ae776a2c 1142 return 0;
ff4eb398 1143 }
60939fb8 1144
926f5fc6 1145 if (s > d && s < send) {
60939fb8 1146 /* we can have an optional exponent part */
305b8651 1147 if (isALPHA_FOLD_EQ(*s, 'e')) {
60939fb8
NC
1148 s++;
1149 if (s < send && (*s == '-' || *s == '+'))
1150 s++;
1151 if (s < send && isDIGIT(*s)) {
1152 do {
1153 s++;
1154 } while (s < send && isDIGIT(*s));
1155 }
3f7602fa
TC
1156 else if (flags & PERL_SCAN_TRAILING)
1157 return numtype | IS_NUMBER_TRAILING;
60939fb8 1158 else
3f7602fa
TC
1159 return 0;
1160
1161 /* The only flag we keep is sign. Blow away any "it's UV" */
1162 numtype &= IS_NUMBER_NEG;
1163 numtype |= IS_NUMBER_NOT_INT;
60939fb8
NC
1164 }
1165 }
1166 while (s < send && isSPACE(*s))
1167 s++;
1168 if (s >= send)
aa8b85de 1169 return numtype;
b59bf0b2 1170 if (memEQs(pv, len, "0 but true")) {
60939fb8
NC
1171 if (valuep)
1172 *valuep = 0;
1173 return IS_NUMBER_IN_UV;
1174 }
8c12dc63 1175 /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
4aada8b9 1176 if ((s + 2 < send) && memCHRs("inqs#", toFOLD(*s))) {
8c12dc63
JH
1177 /* Really detect inf/nan. Start at d, not s, since the above
1178 * code might have already consumed the "1." or "1". */
7eff3d39 1179 const int infnan = Perl_grok_infnan(aTHX_ &d, send);
8c12dc63
JH
1180 if ((infnan & IS_NUMBER_INFINITY)) {
1181 return (numtype | infnan); /* Keep sign for infinity. */
1182 }
1183 else if ((infnan & IS_NUMBER_NAN)) {
1184 return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
1185 }
1186 }
3f7602fa
TC
1187 else if (flags & PERL_SCAN_TRAILING) {
1188 return numtype | IS_NUMBER_TRAILING;
1189 }
1190
60939fb8 1191 return 0;
98994639
HS
1192}
1193
6313e544 1194/*
5d4a52b5 1195=for apidoc grok_atoUV
6313e544 1196
5d4a52b5 1197parse a string, looking for a decimal unsigned integer.
338aa8b0 1198
5d4a52b5
KW
1199On entry, C<pv> points to the beginning of the string;
1200C<valptr> points to a UV that will receive the converted value, if found;
1201C<endptr> is either NULL or points to a variable that points to one byte
1202beyond the point in C<pv> that this routine should examine.
1203If C<endptr> is NULL, C<pv> is assumed to be NUL-terminated.
f4379102 1204
5d4a52b5
KW
1205Returns FALSE if C<pv> doesn't represent a valid unsigned integer value (with
1206no leading zeros). Otherwise it returns TRUE, and sets C<*valptr> to that
1207value.
6313e544 1208
5d4a52b5
KW
1209If you constrain the portion of C<pv> that is looked at by this function (by
1210passing a non-NULL C<endptr>), and if the intial bytes of that portion form a
1211valid value, it will return TRUE, setting C<*endptr> to the byte following the
1212final digit of the value. But if there is no constraint at what's looked at,
1213all of C<pv> must be valid in order for TRUE to be returned.
6313e544 1214
5d4a52b5 1215The only characters this accepts are the decimal digits '0'..'9'.
338aa8b0 1216
5d4a52b5
KW
1217As opposed to L<atoi(3)> or L<strtol(3)>, C<grok_atoUV> does NOT allow optional
1218leading whitespace, nor negative inputs. If such features are required, the
1219calling code needs to explicitly implement those.
6313e544 1220
5d4a52b5
KW
1221Note that this function returns FALSE for inputs that would overflow a UV,
1222or have leading zeros. Thus a single C<0> is accepted, but not C<00> nor
1223C<01>, C<002>, I<etc>.
1224
1225Background: C<atoi> has severe problems with illegal inputs, it cannot be
d62b8c6a 1226used for incremental parsing, and therefore should be avoided
5d4a52b5 1227C<atoi> and C<strtol> are also affected by locale settings, which can also be
d62b8c6a
JH
1228seen as a bug (global state controlled by user environment).
1229
238217e5
JK
1230=cut
1231
6313e544
JH
1232*/
1233
22ff3130
HS
1234bool
1235Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr)
6313e544
JH
1236{
1237 const char* s = pv;
1238 const char** eptr;
1239 const char* end2; /* Used in case endptr is NULL. */
22ff3130 1240 UV val = 0; /* The parsed value. */
6313e544 1241
22ff3130 1242 PERL_ARGS_ASSERT_GROK_ATOUV;
6313e544 1243
5d4a52b5
KW
1244 if (endptr) {
1245 eptr = endptr;
1246 }
1247 else {
1248 end2 = s + strlen(s);
1249 eptr = &end2;
1250 }
1251
1252 if ( *eptr <= s
1253 || ! isDIGIT(*s))
1254 {
1255 return FALSE;
1256 }
1257
97d95d46
KW
1258 /* Single-digit inputs are quite common. */
1259 val = *s++ - '0';
1260 if (s < *eptr && isDIGIT(*s)) {
1261 /* Fail on extra leading zeros. */
1262 if (val == 0)
1263 return FALSE;
1264 while (s < *eptr && isDIGIT(*s)) {
1265 /* This could be unrolled like in grok_number(), but
1266 * the expected uses of this are not speed-needy, and
1267 * unlikely to need full 64-bitness. */
1268 const U8 digit = *s++ - '0';
1269 if (val < uv_max_div_10 ||
1270 (val == uv_max_div_10 && digit <= uv_max_mod_10)) {
1271 val = val * 10 + digit;
1272 } else {
22ff3130 1273 return FALSE;
6313e544
JH
1274 }
1275 }
97d95d46
KW
1276 }
1277
5d4a52b5
KW
1278 if (endptr == NULL) {
1279 if (*s) {
1280 return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */
1281 }
1282 }
1283 else {
1284 *endptr = s;
75feedba 1285 }
97d95d46 1286
22ff3130
HS
1287 *valptr = val;
1288 return TRUE;
6313e544
JH
1289}
1290
ce6f496d 1291#ifndef Perl_strtod
4801ca72 1292STATIC NV
98994639
HS
1293S_mulexp10(NV value, I32 exponent)
1294{
1295 NV result = 1.0;
1296 NV power = 10.0;
1297 bool negative = 0;
1298 I32 bit;
1299
1300 if (exponent == 0)
1301 return value;
659c4b96
DM
1302 if (value == 0)
1303 return (NV)0;
87032ba1 1304
24866caa 1305 /* On OpenVMS VAX we by default use the D_FLOAT double format,
67597c89 1306 * and that format does not have *easy* capabilities [1] for
19c1206d
KW
1307 * overflowing doubles 'silently' as IEEE fp does. We also need
1308 * to support G_FLOAT on both VAX and Alpha, and though the exponent
1309 * range is much larger than D_FLOAT it still doesn't do silent
1310 * overflow. Therefore we need to detect early whether we would
1311 * overflow (this is the behaviour of the native string-to-float
24866caa 1312 * conversion routines, and therefore of native applications, too).
67597c89 1313 *
24866caa
CB
1314 * [1] Trying to establish a condition handler to trap floating point
1315 * exceptions is not a good idea. */
87032ba1
JH
1316
1317 /* In UNICOS and in certain Cray models (such as T90) there is no
1318 * IEEE fp, and no way at all from C to catch fp overflows gracefully.
1319 * There is something you can do if you are willing to use some
1320 * inline assembler: the instruction is called DFI-- but that will
1321 * disable *all* floating point interrupts, a little bit too large
1322 * a hammer. Therefore we need to catch potential overflows before
1323 * it's too late. */
353813d9 1324
a7157111 1325#if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP)
353813d9 1326 STMT_START {
c4420975 1327 const NV exp_v = log10(value);
353813d9
HS
1328 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
1329 return NV_MAX;
1330 if (exponent < 0) {
1331 if (-(exponent + exp_v) >= NV_MAX_10_EXP)
1332 return 0.0;
1333 while (-exponent >= NV_MAX_10_EXP) {
1334 /* combination does not overflow, but 10^(-exponent) does */
1335 value /= 10;
1336 ++exponent;
1337 }
1338 }
1339 } STMT_END;
87032ba1
JH
1340#endif
1341
353813d9
HS
1342 if (exponent < 0) {
1343 negative = 1;
1344 exponent = -exponent;
b27804d8
DM
1345#ifdef NV_MAX_10_EXP
1346 /* for something like 1234 x 10^-309, the action of calculating
1347 * the intermediate value 10^309 then returning 1234 / (10^309)
1348 * will fail, since 10^309 becomes infinity. In this case try to
1349 * refactor it as 123 / (10^308) etc.
1350 */
1351 while (value && exponent > NV_MAX_10_EXP) {
1352 exponent--;
1353 value /= 10;
1354 }
48853916
JH
1355 if (value == 0.0)
1356 return value;
b27804d8 1357#endif
353813d9 1358 }
c62e754c
JH
1359#if defined(__osf__)
1360 /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV)
1361 * Tru64 fp behavior on inf/nan is somewhat broken. Another way
1362 * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF)
1363 * but that breaks another set of infnan.t tests. */
1364# define FP_OVERFLOWS_TO_ZERO
1365#endif
98994639
HS
1366 for (bit = 1; exponent; bit <<= 1) {
1367 if (exponent & bit) {
1368 exponent ^= bit;
1369 result *= power;
c62e754c
JH
1370#ifdef FP_OVERFLOWS_TO_ZERO
1371 if (result == 0)
a7157111 1372# ifdef NV_INF
c62e754c 1373 return value < 0 ? -NV_INF : NV_INF;
a7157111
JH
1374# else
1375 return value < 0 ? -FLT_MAX : FLT_MAX;
1376# endif
c62e754c 1377#endif
236f0012 1378 /* Floating point exceptions are supposed to be turned off,
19c1206d 1379 * but if we're obviously done, don't risk another iteration.
236f0012
CB
1380 */
1381 if (exponent == 0) break;
98994639
HS
1382 }
1383 power *= power;
1384 }
1385 return negative ? value / result : value * result;
1386}
ce6f496d 1387#endif /* #ifndef Perl_strtod */
98994639 1388
ce6f496d 1389#ifdef Perl_strtod
b93d1309 1390# define ATOF(s, x) my_atof2(s, &x)
f7b64c80 1391#else
b93d1309 1392# define ATOF(s, x) Perl_atof2(s, x)
f7b64c80 1393#endif
b93d1309 1394
98994639
HS
1395NV
1396Perl_my_atof(pTHX_ const char* s)
1397{
f720c878
KW
1398 /* 's' must be NUL terminated */
1399
98994639 1400 NV x = 0.0;
9eda1ea6
KW
1401
1402 PERL_ARGS_ASSERT_MY_ATOF;
1403
b93d1309 1404#if ! defined(USE_LOCALE_NUMERIC)
9eda1ea6 1405
b93d1309 1406 ATOF(s, x);
9eda1ea6
KW
1407
1408#else
7918f24d 1409
a2287a13 1410 {
67d796ae
KW
1411 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1412 STORE_LC_NUMERIC_SET_TO_NEEDED();
fdf55d20
KW
1413 if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) {
1414 ATOF(s,x);
1415 }
1416 else {
19c1206d 1417
e4850248
KW
1418 /* Look through the string for the first thing that looks like a
1419 * decimal point: either the value in the current locale or the
1420 * standard fallback of '.'. The one which appears earliest in the
1421 * input string is the one that we should have atof look for. Note
1422 * that we have to determine this beforehand because on some
1423 * systems, Perl_atof2 is just a wrapper around the system's atof.
1424 * */
1ae85f6c
KW
1425 const char * const standard_pos = strchr(s, '.');
1426 const char * const local_pos
1427 = strstr(s, SvPV_nolen(PL_numeric_radix_sv));
1428 const bool use_standard_radix
1429 = standard_pos && (!local_pos || standard_pos < local_pos);
78787052 1430
665873e9 1431 if (use_standard_radix) {
e4850248 1432 SET_NUMERIC_STANDARD();
665873e9
KW
1433 LOCK_LC_NUMERIC_STANDARD();
1434 }
78787052 1435
b93d1309 1436 ATOF(s,x);
78787052 1437
665873e9
KW
1438 if (use_standard_radix) {
1439 UNLOCK_LC_NUMERIC_STANDARD();
67d796ae 1440 SET_NUMERIC_UNDERLYING();
665873e9 1441 }
e4850248 1442 }
a2287a13
KW
1443 RESTORE_LC_NUMERIC();
1444 }
9eda1ea6 1445
98994639 1446#endif
9eda1ea6 1447
98994639
HS
1448 return x;
1449}
1450
a7157111 1451#if defined(NV_INF) || defined(NV_NAN)
3c81f0b3 1452
829757a4 1453static char*
5563f457 1454S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value)
829757a4
JH
1455{
1456 const char *p0 = negative ? s - 1 : s;
1457 const char *p = p0;
7eff3d39 1458 const int infnan = grok_infnan(&p, send);
829757a4
JH
1459 if (infnan && p != p0) {
1460 /* If we can generate inf/nan directly, let's do so. */
1461#ifdef NV_INF
1462 if ((infnan & IS_NUMBER_INFINITY)) {
3823048b 1463 *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
829757a4
JH
1464 return (char*)p;
1465 }
1466#endif
1467#ifdef NV_NAN
1468 if ((infnan & IS_NUMBER_NAN)) {
3823048b 1469 *value = NV_NAN;
829757a4
JH
1470 return (char*)p;
1471 }
1472#endif
1473#ifdef Perl_strtod
68611e6f 1474 /* If still here, we didn't have either NV_INF or NV_NAN,
829757a4
JH
1475 * and can try falling back to native strtod/strtold.
1476 *
1477 * The native interface might not recognize all the possible
1478 * inf/nan strings Perl recognizes. What we can try
1479 * is to try faking the input. We will try inf/-inf/nan
1480 * as the most promising/portable input. */
1481 {
6d37e916 1482 const char* fake = "silence compiler warning";
829757a4
JH
1483 char* endp;
1484 NV nv;
a7157111 1485#ifdef NV_INF
829757a4
JH
1486 if ((infnan & IS_NUMBER_INFINITY)) {
1487 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
1488 }
a7157111
JH
1489#endif
1490#ifdef NV_NAN
1491 if ((infnan & IS_NUMBER_NAN)) {
829757a4
JH
1492 fake = "nan";
1493 }
a7157111 1494#endif
6d37e916 1495 assert(strNE(fake, "silence compiler warning"));
9ec8aea5 1496 nv = S_strtod(aTHX_ fake, &endp);
829757a4 1497 if (fake != endp) {
a7157111 1498#ifdef NV_INF
829757a4 1499 if ((infnan & IS_NUMBER_INFINITY)) {
a7157111 1500# ifdef Perl_isinf
829757a4
JH
1501 if (Perl_isinf(nv))
1502 *value = nv;
a7157111 1503# else
829757a4
JH
1504 /* last resort, may generate SIGFPE */
1505 *value = Perl_exp((NV)1e9);
1506 if ((infnan & IS_NUMBER_NEG))
1507 *value = -*value;
a7157111 1508# endif
829757a4
JH
1509 return (char*)p; /* p, not endp */
1510 }
a7157111
JH
1511#endif
1512#ifdef NV_NAN
1513 if ((infnan & IS_NUMBER_NAN)) {
1514# ifdef Perl_isnan
829757a4
JH
1515 if (Perl_isnan(nv))
1516 *value = nv;
a7157111 1517# else
829757a4
JH
1518 /* last resort, may generate SIGFPE */
1519 *value = Perl_log((NV)-1.0);
a7157111 1520# endif
829757a4 1521 return (char*)p; /* p, not endp */
a7157111 1522#endif
829757a4
JH
1523 }
1524 }
1525 }
1526#endif /* #ifdef Perl_strtod */
1527 }
1528 return NULL;
1529}
1530
a7157111
JH
1531#endif /* if defined(NV_INF) || defined(NV_NAN) */
1532
98994639
HS
1533char*
1534Perl_my_atof2(pTHX_ const char* orig, NV* value)
1535{
6928bedc
KW
1536 PERL_ARGS_ASSERT_MY_ATOF2;
1537 return my_atof3(orig, value, 0);
1538}
1539
1540char*
16411967 1541Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len)
6928bedc 1542{
e1ec3a88 1543 const char* s = orig;
a4eca1d4 1544 NV result[3] = {0.0, 0.0, 0.0};
ce6f496d 1545#if defined(USE_PERL_ATOF) || defined(Perl_strtod)
6928bedc
KW
1546 const char* send = s + ((len != 0)
1547 ? len
1548 : strlen(orig)); /* one past the last */
a4eca1d4
JH
1549 bool negative = 0;
1550#endif
ce6f496d 1551#if defined(USE_PERL_ATOF) && !defined(Perl_strtod)
a4eca1d4 1552 UV accumulator[2] = {0,0}; /* before/after dp */
8194bf88 1553 bool seen_digit = 0;
20f6aaab
AS
1554 I32 exp_adjust[2] = {0,0};
1555 I32 exp_acc[2] = {-1, -1};
1556 /* the current exponent adjust for the accumulators */
98994639 1557 I32 exponent = 0;
8194bf88 1558 I32 seen_dp = 0;
20f6aaab
AS
1559 I32 digit = 0;
1560 I32 old_digit = 0;
8194bf88 1561 I32 sig_digits = 0; /* noof significant digits seen so far */
a4eca1d4 1562#endif
8194bf88 1563
ce6f496d 1564#if defined(USE_PERL_ATOF) || defined(Perl_strtod)
6928bedc 1565 PERL_ARGS_ASSERT_MY_ATOF3;
7918f24d 1566
a4eca1d4 1567 /* leading whitespace */
6928bedc 1568 while (s < send && isSPACE(*s))
a4eca1d4
JH
1569 ++s;
1570
1571 /* sign */
1572 switch (*s) {
1573 case '-':
1574 negative = 1;
1575 /* FALLTHROUGH */
1576 case '+':
1577 ++s;
1578 }
1579#endif
1580
ce6f496d 1581#ifdef Perl_strtod
a4eca1d4
JH
1582 {
1583 char* endp;
d94e901a
KW
1584 char* copy = NULL;
1585
adc55e02 1586 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
a4eca1d4 1587 return endp;
d94e901a 1588
14d26b44
TC
1589 /* strtold() accepts 0x-prefixed hex and in POSIX implementations,
1590 0b-prefixed binary numbers, which is backward incompatible
1591 */
e56dfd96 1592 if ((len == 0 || len - (s-orig) >= 2) && *s == '0' &&
14d26b44
TC
1593 (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) {
1594 *value = 0;
1595 return (char *)s+1;
1596 }
1597
d94e901a
KW
1598 /* If the length is passed in, the input string isn't NUL-terminated,
1599 * and in it turns out the function below assumes it is; therefore we
1600 * create a copy and NUL-terminate that */
1601 if (len) {
1602 Newx(copy, len + 1, char);
1603 Copy(orig, copy, len, char);
1604 copy[len] = '\0';
1605 s = copy + (s - orig);
1606 }
1607
9ec8aea5 1608 result[2] = S_strtod(aTHX_ s, &endp);
d94e901a
KW
1609
1610 /* If we created a copy, 'endp' is in terms of that. Convert back to
1611 * the original */
1612 if (copy) {
aac39b03 1613 s = (s - copy) + (char *) orig;
d94e901a
KW
1614 endp = (endp - copy) + (char *) orig;
1615 Safefree(copy);
1616 }
1617
a4eca1d4
JH
1618 if (s != endp) {
1619 *value = negative ? -result[2] : result[2];
1620 return endp;
1621 }
1622 return NULL;
1623 }
1624#elif defined(USE_PERL_ATOF)
1625
8194bf88
DM
1626/* There is no point in processing more significant digits
1627 * than the NV can hold. Note that NV_DIG is a lower-bound value,
1628 * while we need an upper-bound value. We add 2 to account for this;
1629 * since it will have been conservative on both the first and last digit.
1630 * For example a 32-bit mantissa with an exponent of 4 would have
1631 * exact values in the set
1632 * 4
1633 * 8
1634 * ..
1635 * 17179869172
1636 * 17179869176
1637 * 17179869180
1638 *
1639 * where for the purposes of calculating NV_DIG we would have to discount
1640 * both the first and last digit, since neither can hold all values from
1641 * 0..9; but for calculating the value we must examine those two digits.
1642 */
ffa277e5
EAS
1643#ifdef MAX_SIG_DIG_PLUS
1644 /* It is not necessarily the case that adding 2 to NV_DIG gets all the
1645 possible digits in a NV, especially if NVs are not IEEE compliant
1646 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */
1647# define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS)
1648#else
1649# define MAX_SIG_DIGITS (NV_DIG+2)
1650#endif
8194bf88
DM
1651
1652/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
1653#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
98994639 1654
a5dc2484 1655#if defined(NV_INF) || defined(NV_NAN)
ae776a2c 1656 {
7eff3d39 1657 char* endp;
5563f457 1658 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value)))
7eff3d39 1659 return endp;
ae776a2c 1660 }
a5dc2484 1661#endif
2b54f59f 1662
8194bf88
DM
1663 /* we accumulate digits into an integer; when this becomes too
1664 * large, we add the total to NV and start again */
98994639 1665
6928bedc 1666 while (s < send) {
8194bf88
DM
1667 if (isDIGIT(*s)) {
1668 seen_digit = 1;
20f6aaab 1669 old_digit = digit;
8194bf88 1670 digit = *s++ - '0';
20f6aaab
AS
1671 if (seen_dp)
1672 exp_adjust[1]++;
98994639 1673
8194bf88
DM
1674 /* don't start counting until we see the first significant
1675 * digit, eg the 5 in 0.00005... */
1676 if (!sig_digits && digit == 0)
1677 continue;
1678
1679 if (++sig_digits > MAX_SIG_DIGITS) {
98994639 1680 /* limits of precision reached */
20f6aaab
AS
1681 if (digit > 5) {
1682 ++accumulator[seen_dp];
1683 } else if (digit == 5) {
1684 if (old_digit % 2) { /* round to even - Allen */
1685 ++accumulator[seen_dp];
1686 }
1687 }
1688 if (seen_dp) {
1689 exp_adjust[1]--;
1690 } else {
1691 exp_adjust[0]++;
1692 }
8194bf88 1693 /* skip remaining digits */
6928bedc 1694 while (s < send && isDIGIT(*s)) {
98994639 1695 ++s;
20f6aaab
AS
1696 if (! seen_dp) {
1697 exp_adjust[0]++;
1698 }
98994639
HS
1699 }
1700 /* warn of loss of precision? */
98994639 1701 }
8194bf88 1702 else {
20f6aaab 1703 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
8194bf88 1704 /* add accumulator to result and start again */
20f6aaab
AS
1705 result[seen_dp] = S_mulexp10(result[seen_dp],
1706 exp_acc[seen_dp])
1707 + (NV)accumulator[seen_dp];
1708 accumulator[seen_dp] = 0;
1709 exp_acc[seen_dp] = 0;
98994639 1710 }
20f6aaab
AS
1711 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
1712 ++exp_acc[seen_dp];
98994639 1713 }
8194bf88 1714 }
e1ec3a88 1715 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
8194bf88 1716 seen_dp = 1;
20f6aaab 1717 if (sig_digits > MAX_SIG_DIGITS) {
6928bedc 1718 while (s < send && isDIGIT(*s)) {
20f6aaab 1719 ++s;
9604fbf0 1720 }
20f6aaab
AS
1721 break;
1722 }
8194bf88
DM
1723 }
1724 else {
1725 break;
98994639
HS
1726 }
1727 }
1728
20f6aaab
AS
1729 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
1730 if (seen_dp) {
1731 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
1732 }
98994639 1733
6928bedc 1734 if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
98994639
HS
1735 bool expnegative = 0;
1736
1737 ++s;
1738 switch (*s) {
1739 case '-':
1740 expnegative = 1;
924ba076 1741 /* FALLTHROUGH */
98994639
HS
1742 case '+':
1743 ++s;
1744 }
6928bedc 1745 while (s < send && isDIGIT(*s))
98994639
HS
1746 exponent = exponent * 10 + (*s++ - '0');
1747 if (expnegative)
1748 exponent = -exponent;
1749 }
1750
1751 /* now apply the exponent */
20f6aaab
AS
1752
1753 if (seen_dp) {
1754 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1755 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1756 } else {
1757 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1758 }
98994639
HS
1759
1760 /* now apply the sign */
1761 if (negative)
20f6aaab 1762 result[2] = -result[2];
a36244b7 1763#endif /* USE_PERL_ATOF */
20f6aaab 1764 *value = result[2];
73d840c0 1765 return (char *)s;
98994639
HS
1766}
1767
5d34af89 1768/*
3d9d9213 1769=for apidoc isinfnan
5d34af89 1770
5f4d68d1 1771C<Perl_isinfnan()> is a utility function that returns true if the NV
796b6530
KW
1772argument is either an infinity or a C<NaN>, false otherwise. To test
1773in more detail, use C<Perl_isinf()> and C<Perl_isnan()>.
5d34af89 1774
68611e6f
JH
1775This is also the logical inverse of Perl_isfinite().
1776
5d34af89
JH
1777=cut
1778*/
1cd88304
JH
1779bool
1780Perl_isinfnan(NV nv)
1781{
a5dc2484 1782 PERL_UNUSED_ARG(nv);
1cd88304
JH
1783#ifdef Perl_isinf
1784 if (Perl_isinf(nv))
1785 return TRUE;
1786#endif
1787#ifdef Perl_isnan
1788 if (Perl_isnan(nv))
1789 return TRUE;
1790#endif
1791 return FALSE;
1792}
1793
354b74ae 1794/*
af147c81 1795=for apidoc isinfnansv
354b74ae 1796
796b6530 1797Checks whether the argument would be either an infinity or C<NaN> when used
354b74ae 1798as a number, but is careful not to trigger non-numeric or uninitialized
796b6530 1799warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already.
354b74ae
FC
1800
1801=cut
1802*/
1803
1804bool
1805Perl_isinfnansv(pTHX_ SV *sv)
1806{
1807 PERL_ARGS_ASSERT_ISINFNANSV;
1808 if (!SvOK(sv))
1809 return FALSE;
1810 if (SvNOKp(sv))
1811 return Perl_isinfnan(SvNVX(sv));
1812 if (SvIOKp(sv))
1813 return FALSE;
1814 {
1815 STRLEN len;
1816 const char *s = SvPV_nomg_const(sv, len);
3823048b 1817 return cBOOL(grok_infnan(&s, s+len));
354b74ae
FC
1818 }
1819}
1820
d67dac15 1821#ifndef HAS_MODFL
68611e6f
JH
1822/* C99 has truncl, pre-C99 Solaris had aintl. We can use either with
1823 * copysignl to emulate modfl, which is in some platforms missing or
1824 * broken. */
d67dac15
JH
1825# if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
1826long double
1827Perl_my_modfl(long double x, long double *ip)
1828{
68611e6f
JH
1829 *ip = truncl(x);
1830 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
d67dac15
JH
1831}
1832# elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
55954f19
JH
1833long double
1834Perl_my_modfl(long double x, long double *ip)
1835{
68611e6f
JH
1836 *ip = aintl(x);
1837 return (x == *ip ? copysignl(0.0L, x) : x - *ip);
55954f19 1838}
d67dac15 1839# endif
55954f19
JH
1840#endif
1841
7b9b7dff 1842/* Similarly, with ilogbl and scalbnl we can emulate frexpl. */
55954f19
JH
1843#if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1844long double
1845Perl_my_frexpl(long double x, int *e) {
68611e6f
JH
1846 *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1847 return (scalbnl(x, -*e));
55954f19
JH
1848}
1849#endif
66610fdd
RGS
1850
1851/*
ed140128
AD
1852=for apidoc Perl_signbit
1853
1854Return a non-zero integer if the sign bit on an NV is set, and 0 if
19c1206d 1855it is not.
ed140128 1856
796b6530
KW
1857If F<Configure> detects this system has a C<signbit()> that will work with
1858our NVs, then we just use it via the C<#define> in F<perl.h>. Otherwise,
8b7fad81 1859fall back on this implementation. The main use of this function
796b6530 1860is catching C<-0.0>.
ed140128 1861
796b6530
KW
1862C<Configure> notes: This function is called C<'Perl_signbit'> instead of a
1863plain C<'signbit'> because it is easy to imagine a system having a C<signbit()>
ed140128 1864function or macro that doesn't happen to work with our particular choice
796b6530 1865of NVs. We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect
ed140128 1866the standard system headers to be happy. Also, this is a no-context
796b6530
KW
1867function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in
1868F<perl.h> as a simple macro call to the system's C<signbit()>.
1869Users should just always call C<Perl_signbit()>.
ed140128
AD
1870
1871=cut
1872*/
1873#if !defined(HAS_SIGNBIT)
1874int
1875Perl_signbit(NV x) {
8b7fad81 1876# ifdef Perl_fp_class_nzero
406d5545
JH
1877 return Perl_fp_class_nzero(x);
1878 /* Try finding the high byte, and assume it's highest bit
1879 * is the sign. This assumption is probably wrong somewhere. */
572cd850
JH
1880# elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
1881 return (((unsigned char *)&x)[9] & 0x80);
1882# elif defined(NV_LITTLE_ENDIAN)
1883 /* Note that NVSIZE is sizeof(NV), which would make the below be
1884 * wrong if the end bytes are unused, which happens with the x86
1885 * 80-bit long doubles, which is why take care of that above. */
1886 return (((unsigned char *)&x)[NVSIZE - 1] & 0x80);
1887# elif defined(NV_BIG_ENDIAN)
1888 return (((unsigned char *)&x)[0] & 0x80);
1889# else
406d5545 1890 /* This last resort fallback is wrong for the negative zero. */
3585840c 1891 return (x < 0.0) ? 1 : 0;
572cd850 1892# endif
ed140128
AD
1893}
1894#endif
1895
1896/*
14d04a33 1897 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1898 */