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