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