syswrite() is old news.

[p5sagit/p5-mst-13.2.git] / numeric.c

diff --git a/numeric.c b/numeric.c
index 2e1e261..f95fde3 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -1,6 +1,6 @@
 /*    numeric.c
  *
- *    Copyright (c) 2001, Larry Wall
+ *    Copyright (c) 2001-2002, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -12,6 +12,10 @@
  * wizards count differently to other people."
  */
 
+/*
+=head1 Numeric functions
+*/
+
 #include "EXTERN.h"
 #define PERL_IN_NUMERIC_C
 #include "perl.h"
@@ -122,7 +126,7 @@ returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
 and writes the value to I<*result> (or the value is discarded if I<result>
 is NULL).
 
-The hex number may optinally be prefixed with "0b" or "b" unless
+The hex number may optionally be prefixed with "0b" or "b" unless
 C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary
 number may use '_' characters to separate digits.
@@ -171,14 +175,14 @@ Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
                 }
                 /* Bah. We're just overflowed.  */
                 if (ckWARN_d(WARN_OVERFLOW))
-                    Perl_warner(aTHX_ WARN_OVERFLOW,
+                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
                                 "Integer overflow in binary number");
                 overflowed = TRUE;
                 value_nv = (NV) value;
             }
             value_nv *= 2.0;
            /* If an NV has not enough bits in its mantissa to
-            * represent an UV this summing of small low-order numbers
+            * represent a UV this summing of small low-order numbers
             * is a waste of time (because the NV cannot preserve
             * the low-order bits anyway): we could just remember when
             * did we overflow and in the end just multiply value_nv by the
@@ -194,7 +198,7 @@ Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
                 goto redo;
            }
         if (ckWARN(WARN_DIGIT))
-            Perl_warner(aTHX_ WARN_DIGIT,
+            Perl_warner(aTHX_ packWARN(WARN_DIGIT),
                         "Illegal binary digit '%c' ignored", *s);
         break;
     }
@@ -205,7 +209,7 @@ Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
 #endif
        ) {
        if (ckWARN(WARN_PORTABLE))
-           Perl_warner(aTHX_ WARN_PORTABLE,
+           Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
                        "Binary number > 0b11111111111111111111111111111111 non-portable");
     }
     *len_p = s - start;
@@ -236,7 +240,7 @@ returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
 and writes the value to I<*result> (or the value is discarded if I<result>
 is NULL).
 
-The hex number may optinally be prefixed with "0x" or "x" unless
+The hex number may optionally be prefixed with "0x" or "x" unless
 C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
 number may use '_' characters to separate digits.
@@ -286,14 +290,14 @@ Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
                 }
                 /* Bah. We're just overflowed.  */
                 if (ckWARN_d(WARN_OVERFLOW))
-                    Perl_warner(aTHX_ WARN_OVERFLOW,
+                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
                                 "Integer overflow in hexadecimal number");
                 overflowed = TRUE;
                 value_nv = (NV) value;
             }
             value_nv *= 16.0;
            /* If an NV has not enough bits in its mantissa to
-            * represent an UV this summing of small low-order numbers
+            * represent a UV this summing of small low-order numbers
             * is a waste of time (because the NV cannot preserve
             * the low-order bits anyway): we could just remember when
             * did we overflow and in the end just multiply value_nv by the
@@ -309,7 +313,7 @@ Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
                 goto redo;
            }
         if (ckWARN(WARN_DIGIT))
-            Perl_warner(aTHX_ WARN_DIGIT,
+            Perl_warner(aTHX_ packWARN(WARN_DIGIT),
                         "Illegal hexadecimal digit '%c' ignored", *s);
         break;
     }
@@ -320,7 +324,7 @@ Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
 #endif
        ) {
        if (ckWARN(WARN_PORTABLE))
-           Perl_warner(aTHX_ WARN_PORTABLE,
+           Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
                        "Hexadecimal number > 0xffffffff non-portable");
     }
     *len_p = s - start;
@@ -368,14 +372,14 @@ Perl_grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
                 }
                 /* Bah. We're just overflowed.  */
                 if (ckWARN_d(WARN_OVERFLOW))
-                    Perl_warner(aTHX_ WARN_OVERFLOW,
+                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
                                 "Integer overflow in octal number");
                 overflowed = TRUE;
                 value_nv = (NV) value;
             }
             value_nv *= 8.0;
            /* If an NV has not enough bits in its mantissa to
-            * represent an UV this summing of small low-order numbers
+            * represent a UV this summing of small low-order numbers
             * is a waste of time (because the NV cannot preserve
             * the low-order bits anyway): we could just remember when
             * did we overflow and in the end just multiply value_nv by the
@@ -395,7 +399,7 @@ Perl_grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
          * someone seems to want to use the digits eight and nine). */
         if (digit == 8 || digit == 9) {
             if (ckWARN(WARN_DIGIT))
-                Perl_warner(aTHX_ WARN_DIGIT,
+                Perl_warner(aTHX_ packWARN(WARN_DIGIT),
                             "Illegal octal digit '%c' ignored", *s);
         }
         break;
@@ -407,7 +411,7 @@ Perl_grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) {
 #endif
        ) {
        if (ckWARN(WARN_PORTABLE))
-           Perl_warner(aTHX_ WARN_PORTABLE,
+           Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
                        "Octal number > 037777777777 non-portable");
     }
     *len_p = s - start;
@@ -740,9 +744,8 @@ S_mulexp10(NV value, I32 exponent)
      * [1] Trying to establish a condition handler to trap floating point
      *     exceptions is not a good idea. */
 #if defined(VMS) && !defined(__IEEE_FP) && defined(NV_MAX_10_EXP)
-    if (!negative &&
-        (log10(value) + exponent) >= (NV_MAX_10_EXP))
-        return NV_MAX;
+    if ((log10(value) + exponent) >= (NV_MAX_10_EXP))
+        return negative ? 0.0 : NV_MAX;
 #endif
 
     /* In UNICOS and in certain Cray models (such as T90) there is no
@@ -762,8 +765,11 @@ S_mulexp10(NV value, I32 exponent)
        if (exponent & bit) {
            exponent ^= bit;
            result *= power;
+           /* Floating point exceptions are supposed to be turned off,
+            *  but if we're obviously done, don't risk another iteration.  
+            */
+            if (exponent == 0) break;
        }
-       /* Floating point exceptions are supposed to be turned off. */
        power *= power;
     }
     return negative ? value / result : value * result;
@@ -779,17 +785,17 @@ Perl_my_atof(pTHX_ const char* s)
 
        /* Scan the number twice; once using locale and once without;
         * choose the larger result (in absolute value). */
-       Perl_atof2(aTHX_ s, &x);
+       Perl_atof2(s, x);
        SET_NUMERIC_STANDARD();
-       Perl_atof2(aTHX_ s, &y);
+       Perl_atof2(s, y);
        SET_NUMERIC_LOCAL();
        if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
            return y;
     }
     else
-       Perl_atof2(aTHX_ s, &x);
+       Perl_atof2(s, x);
 #else
-    Perl_atof2(aTHX_ s, &x);
+    Perl_atof2(s, x);
 #endif
     return x;
 }
@@ -798,8 +804,9 @@ char*
 Perl_my_atof2(pTHX_ const char* orig, NV* value)
 {
     NV result = 0.0;
-    bool negative = 0;
     char* s = (char*)orig;
+#ifdef USE_PERL_ATOF
+    bool negative = 0;
     char* send = s + strlen(orig) - 1;
     bool seendigit = 0;
     I32 expextra = 0;
@@ -922,6 +929,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
     /* now apply the sign */
     if (negative)
        result = -result;
+#endif /* USE_PERL_ATOF */
     *value = result;
     return s;
 }