Tcl Source Code

/*
 * fixstrtod.c --
 *
 *	Source code for the "fixstrtod" procedure.  This procedure is
 *	used in place of strtod under Solaris 2.4, in order to fix
 *	a bug where the "end" pointer gets set incorrectly.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include <stdio.h>

#undef strtod

/*
 * Declare strtod explicitly rather than including stdlib.h, since in
 * somes systems (e.g. SunOS 4.1.4) stdlib.h doesn't declare strtod.
 */

extern double strtod(char *, char **);

double
fixstrtod(
    char *string,
    char **endPtr)
{
    double d;
    d = strtod(string, endPtr);
    if ((endPtr != NULL) && (*endPtr != string) && ((*endPtr)[-1] == 0)) {
	*endPtr -= 1;
    }
    return d;
}

extern void		exit(int status);
extern int		free(char *blockPtr);
extern char *		getenv(const char *name);
extern char *		malloc(unsigned int numBytes);
extern void		qsort(void *base, int n, int size, int (*compar)(
			    const void *element1, const void *element2));
extern char *		realloc(char *ptr, unsigned int numBytes);
extern double		strtod(const char *string, char **endPtr);
extern long		strtol(const char *string, char **endPtr, int base);
extern unsigned long	strtoul(const char *string, char **endPtr, int base);

#endif /* _STDLIB */

extern void		exit(int status);
extern int		free(char *blockPtr);
extern char *		getenv(const char *name);
extern char *		malloc(unsigned int numBytes);
extern void		qsort(void *base, int n, int size, int (*compar)(
			    const void *element1, const void *element2));
extern char *		realloc(char *ptr, unsigned int numBytes);

extern long		strtol(const char *string, char **endPtr, int base);
extern unsigned long	strtoul(const char *string, char **endPtr, int base);

#endif /* _STDLIB */

/*
 * strtod.c --
 *
 *	Source code for the "strtod" library procedure.
 *
 * Copyright (c) 1988-1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

#ifndef TRUE
#define TRUE 1
#define FALSE 0
#endif
#ifndef NULL
#define NULL 0
#endif

static const int maxExponent = 511;	/* Largest possible base 10 exponent.  Any
				 * exponent larger than this will already
				 * produce underflow or overflow, so there's
				 * no need to worry about additional digits.
				 */
static const double powersOf10[] = {	/* Table giving binary powers of 10.  Entry */
    10.,			/* is 10^2^i.  Used to convert decimal */
    100.,			/* exponents into floating-point numbers. */
    1.0e4,
    1.0e8,
    1.0e16,
    1.0e32,
    1.0e64,
    1.0e128,
    1.0e256
};
 
/*
 *----------------------------------------------------------------------
 *
 * strtod --
 *
 *	This procedure converts a floating-point number from an ASCII
 *	decimal representation to internal double-precision format.
 *
 * Results:
 *	The return value is the double-precision floating-point
 *	representation of the characters in string.  If endPtr isn't
 *	NULL, then *endPtr is filled in with the address of the
 *	next character after the last one that was part of the
 *	floating-point number.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

double
strtod(
    const char *string,		/* A decimal ASCII floating-point number,
				 * optionally preceded by white space. Must
				 * have form "-I.FE-X", where I is the integer
				 * part of the mantissa, F is the fractional
				 * part of the mantissa, and X is the
				 * exponent. Either of the signs may be "+",
				 * "-", or omitted. Either I or F may be
				 * omitted, or both. The decimal point isn't
				 * necessary unless F is present. The "E" may
				 * actually be an "e". E and X may both be
				 * omitted (but not just one). */
    char **endPtr)		/* If non-NULL, store terminating character's
				 * address here. */
{
    int sign, expSign = FALSE;
    double fraction, dblExp;
    const double *d;
    register const char *p;
    register int c;
    int exp = 0;		/* Exponent read from "EX" field. */
    int fracExp = 0;		/* Exponent that derives from the fractional
				 * part. Under normal circumstatnces, it is
				 * the negative of the number of digits in F.
				 * However, if I is very long, the last digits
				 * of I get dropped (otherwise a long I with a
				 * large negative exponent could cause an
				 * unnecessary overflow on I alone). In this
				 * case, fracExp is incremented one for each
				 * dropped digit. */
    int mantSize;		/* Number of digits in mantissa. */
    int decPt;			/* Number of mantissa digits BEFORE decimal
				 * point. */
    const char *pExp;		/* Temporarily holds location of exponent in
				 * string. */

    /*
     * Strip off leading blanks and check for a sign.
     */

    p = string;
    while (isspace(UCHAR(*p))) {
	p += 1;
    }
    if (*p == '-') {
	sign = TRUE;
	p += 1;
    } else {
	if (*p == '+') {
	    p += 1;
	}
	sign = FALSE;
    }

    /*
     * Count the number of digits in the mantissa (including the decimal
     * point), and also locate the decimal point.
     */

    decPt = -1;
    for (mantSize = 0; ; mantSize += 1)
    {
	c = *p;
	if (!isdigit(c)) {
	    if ((c != '.') || (decPt >= 0)) {
		break;
	    }
	    decPt = mantSize;
	}
	p += 1;
    }

    /*
     * Now suck up the digits in the mantissa. Use two integers to collect 9
     * digits each (this is faster than using floating-point). If the mantissa
     * has more than 18 digits, ignore the extras, since they can't affect the
     * value anyway.
     */

    pExp  = p;
    p -= mantSize;
    if (decPt < 0) {
	decPt = mantSize;
    } else {
	mantSize -= 1;		/* One of the digits was the point. */
    }
    if (mantSize > 18) {
	fracExp = decPt - 18;
	mantSize = 18;
    } else {
	fracExp = decPt - mantSize;
    }
    if (mantSize == 0) {
	fraction = 0.0;
	p = string;
	goto done;
    } else {
	int frac1, frac2;

	frac1 = 0;
	for ( ; mantSize > 9; mantSize -= 1) {
	    c = *p;
	    p += 1;
	    if (c == '.') {
		c = *p;
		p += 1;
	    }
	    frac1 = 10*frac1 + (c - '0');
	}
	frac2 = 0;
	for (; mantSize > 0; mantSize -= 1) {
	    c = *p;
	    p += 1;
	    if (c == '.') {
		c = *p;
		p += 1;
	    }
	    frac2 = 10*frac2 + (c - '0');
	}
	fraction = (1.0e9 * frac1) + frac2;
    }

    /*
     * Skim off the exponent.
     */

    p = pExp;
    if ((*p == 'E') || (*p == 'e')) {
	p += 1;
	if (*p == '-') {
	    expSign = TRUE;
	    p += 1;
	} else {
	    if (*p == '+') {
		p += 1;
	    }
	    expSign = FALSE;
	}
	if (!isdigit(UCHAR(*p))) {
	    p = pExp;
	    goto done;
	}
	while (isdigit(UCHAR(*p))) {
	    exp = exp * 10 + (*p - '0');
	    p += 1;
	}
    }
    if (expSign) {
	exp = fracExp - exp;
    } else {
	exp = fracExp + exp;
    }

    /*
     * Generate a floating-point number that represents the exponent. Do this
     * by processing the exponent one bit at a time to combine many powers of
     * 2 of 10. Then combine the exponent with the fraction.
     */

    if (exp < 0) {
	expSign = TRUE;
	exp = -exp;
    } else {
	expSign = FALSE;
    }
    if (exp > maxExponent) {
	exp = maxExponent;
	errno = ERANGE;
    }
    dblExp = 1.0;
    for (d = powersOf10; exp != 0; exp >>= 1, ++d) {
	if (exp & 01) {
	    dblExp *= *d;
	}
    }
    if (expSign) {
	fraction /= dblExp;
    } else {
	fraction *= dblExp;
    }

  done:
    if (endPtr != NULL) {
	*endPtr = (char *) p;
    }

    if (sign) {
	return -fraction;
    }
    return fraction;
}

#--------------------------------------------------------------------------
# Compat binaries, these must be compiled for use in a shared library even
# though they may be placed in a static executable or library. Since they are
# included in both the tcl library and the stub library, they need to be
# relocatable.
#--------------------------------------------------------------------------

fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c

opendir.o: $(COMPAT_DIR)/opendir.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c

mkstemp.o: $(COMPAT_DIR)/mkstemp.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/mkstemp.c

memcmp.o: $(COMPAT_DIR)/memcmp.c
................................................................................

strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c

strstr.o: $(COMPAT_DIR)/strstr.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strstr.c

strtod.o: $(COMPAT_DIR)/strtod.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtod.c

strtol.o: $(COMPAT_DIR)/strtol.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtol.c

strtoul.o: $(COMPAT_DIR)/strtoul.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtoul.c

waitpid.o: $(COMPAT_DIR)/waitpid.c

#--------------------------------------------------------------------------
# Compat binaries, these must be compiled for use in a shared library even
# though they may be placed in a static executable or library. Since they are
# included in both the tcl library and the stub library, they need to be
# relocatable.
#--------------------------------------------------------------------------




opendir.o: $(COMPAT_DIR)/opendir.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c

mkstemp.o: $(COMPAT_DIR)/mkstemp.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/mkstemp.c

memcmp.o: $(COMPAT_DIR)/memcmp.c
................................................................................

strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c

strstr.o: $(COMPAT_DIR)/strstr.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strstr.c




strtol.o: $(COMPAT_DIR)/strtol.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtol.c

strtoul.o: $(COMPAT_DIR)/strtoul.c
	$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtoul.c

waitpid.o: $(COMPAT_DIR)/waitpid.c

	case " $LIBOBJS " in
  *" strtoul.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS strtoul.$ac_objext"
 ;;
esac

	USE_COMPAT=1
    fi


#--------------------------------------------------------------------
#	Check for the strtod function.  This is tricky because in some
#	versions of Linux strtod mis-parses strings starting with "+".
#--------------------------------------------------------------------


    ac_fn_c_check_func "$LINENO" "strtod" "ac_cv_func_strtod"
if test "x$ac_cv_func_strtod" = xyes; then :
  tcl_ok=1
else
  tcl_ok=0
fi

    if test "$tcl_ok" = 1; then
	{ $as_echo "$as_me:${as_lineno-$LINENO}: checking proper strtod implementation" >&5
$as_echo_n "checking proper strtod implementation... " >&6; }
if ${tcl_cv_strtod_unbroken+:} false; then :
  $as_echo_n "(cached) " >&6
else
  if test "$cross_compiling" = yes; then :
  tcl_cv_strtod_unbroken=unknown
else
  cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h.  */
int main() {
    extern double strtod();
    char *term, *string = " +69";
    exit(strtod(string,&term) != 69 || term != string+4);
}
_ACEOF
if ac_fn_c_try_run "$LINENO"; then :
  tcl_cv_strtod_unbroken=ok
else
  tcl_cv_strtod_unbroken=broken
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
  conftest.$ac_objext conftest.beam conftest.$ac_ext
fi

fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtod_unbroken" >&5
$as_echo "$tcl_cv_strtod_unbroken" >&6; }
	if test "$tcl_cv_strtod_unbroken" = "ok"; then
	    tcl_ok=1
	else
	    tcl_ok=0
	fi
    fi
    if test "$tcl_ok" = 0; then
	case " $LIBOBJS " in
  *" strtod.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS strtod.$ac_objext"
 ;;
esac

	USE_COMPAT=1
    fi


#--------------------------------------------------------------------
#	Under Solaris 2.4, strtod returns the wrong value for the
#	terminating character under some conditions.  Check for this
#	and if the problem exists use a substitute procedure
#	"fixstrtod" that corrects the error.
#--------------------------------------------------------------------


    ac_fn_c_check_func "$LINENO" "strtod" "ac_cv_func_strtod"
if test "x$ac_cv_func_strtod" = xyes; then :
  tcl_strtod=1
else
  tcl_strtod=0
fi

    if test "$tcl_strtod" = 1; then
	{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Solaris2.4/Tru64 strtod bugs" >&5
$as_echo_n "checking for Solaris2.4/Tru64 strtod bugs... " >&6; }
if ${tcl_cv_strtod_buggy+:} false; then :
  $as_echo_n "(cached) " >&6
else

	    if test "$cross_compiling" = yes; then :
  tcl_cv_strtod_buggy=buggy
else
  cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h.  */

		extern double strtod();
		int main() {
		    char *infString="Inf", *nanString="NaN", *spaceString=" ";
		    char *term;
		    double value;
		    value = strtod(infString, &term);
		    if ((term != infString) && (term[-1] == 0)) {
			exit(1);
		    }
		    value = strtod(nanString, &term);
		    if ((term != nanString) && (term[-1] == 0)) {
			exit(1);
		    }
		    value = strtod(spaceString, &term);
		    if (term == (spaceString+1)) {
			exit(1);
		    }
		    exit(0);
		}
_ACEOF
if ac_fn_c_try_run "$LINENO"; then :
  tcl_cv_strtod_buggy=ok
else
  tcl_cv_strtod_buggy=buggy
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
  conftest.$ac_objext conftest.beam conftest.$ac_ext
fi

fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtod_buggy" >&5
$as_echo "$tcl_cv_strtod_buggy" >&6; }
	if test "$tcl_cv_strtod_buggy" = buggy; then
	    case " $LIBOBJS " in
  *" fixstrtod.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS fixstrtod.$ac_objext"
 ;;
esac

	    USE_COMPAT=1

$as_echo "#define strtod fixstrtod" >>confdefs.h

	fi
    fi


#--------------------------------------------------------------------
#	Check for various typedefs and provide substitutes if
#	they don't exist.
#--------------------------------------------------------------------

	case " $LIBOBJS " in
  *" strtoul.$ac_objext "* ) ;;
  *) LIBOBJS="$LIBOBJS strtoul.$ac_objext"
 ;;
esac

	USE_COMPAT=1






































































































































    fi


#--------------------------------------------------------------------
#	Check for various typedefs and provide substitutes if
#	they don't exist.
#--------------------------------------------------------------------

SC_TCL_CHECK_BROKEN_FUNC(strtoul, [
    extern int strtoul();
    char *term, *string = "0";
    exit(strtoul(string,&term,0) != 0 || term != string+1);
])

#--------------------------------------------------------------------
#	Check for the strtod function.  This is tricky because in some
#	versions of Linux strtod mis-parses strings starting with "+".
#--------------------------------------------------------------------

SC_TCL_CHECK_BROKEN_FUNC(strtod, [
    extern double strtod();
    char *term, *string = " +69";
    exit(strtod(string,&term) != 69 || term != string+4);
])

#--------------------------------------------------------------------
#	Under Solaris 2.4, strtod returns the wrong value for the
#	terminating character under some conditions.  Check for this
#	and if the problem exists use a substitute procedure
#	"fixstrtod" that corrects the error.
#--------------------------------------------------------------------

SC_BUGGY_STRTOD

#--------------------------------------------------------------------
#	Check for various typedefs and provide substitutes if
#	they don't exist.
#--------------------------------------------------------------------

AC_TYPE_MODE_T
AC_TYPE_PID_T

SC_TCL_CHECK_BROKEN_FUNC(strtoul, [
    extern int strtoul();
    char *term, *string = "0";
    exit(strtoul(string,&term,0) != 0 || term != string+1);
])





















#--------------------------------------------------------------------
#	Check for various typedefs and provide substitutes if
#	they don't exist.
#--------------------------------------------------------------------

AC_TYPE_MODE_T
AC_TYPE_PID_T

		[extern time_t timezone;
		timezone += 1;
		exit (0);],
		tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no)])
	if test $tcl_cv_timezone_time = yes ; then
	    AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?])
	fi
    fi
])

#--------------------------------------------------------------------
# SC_BUGGY_STRTOD
#
#	Under Solaris 2.4, strtod returns the wrong value for the
#	terminating character under some conditions.  Check for this
#	and if the problem exists use a substitute procedure
#	"fixstrtod" (provided by Tcl) that corrects the error.
#	Also, on Compaq's Tru64 Unix 5.0,
#	strtod(" ") returns 0.0 instead of a failure to convert.
#
# Arguments:
#	none
#
# Results:
#
#	Might defines some of the following vars:
#		strtod (=fixstrtod)
#
#--------------------------------------------------------------------

AC_DEFUN([SC_BUGGY_STRTOD], [
    AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
    if test "$tcl_strtod" = 1; then
	AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[
	    AC_TRY_RUN([
		extern double strtod();
		int main() {
		    char *infString="Inf", *nanString="NaN", *spaceString=" ";
		    char *term;
		    double value;
		    value = strtod(infString, &term);
		    if ((term != infString) && (term[-1] == 0)) {
			exit(1);
		    }
		    value = strtod(nanString, &term);
		    if ((term != nanString) && (term[-1] == 0)) {
			exit(1);
		    }
		    value = strtod(spaceString, &term);
		    if (term == (spaceString+1)) {
			exit(1);
		    }
		    exit(0);
		}], tcl_cv_strtod_buggy=ok, tcl_cv_strtod_buggy=buggy,
		    tcl_cv_strtod_buggy=buggy)])
	if test "$tcl_cv_strtod_buggy" = buggy; then
	    AC_LIBOBJ([fixstrtod])
	    USE_COMPAT=1
	    AC_DEFINE(strtod, fixstrtod, [Do we want to use the strtod() in compat?])
	fi
    fi
])

#--------------------------------------------------------------------
# SC_TCL_LINK_LIBS
#
#	Search for the libraries needed to link the Tcl shell.

		[extern time_t timezone;
		timezone += 1;
		exit (0);],
		tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no)])
	if test $tcl_cv_timezone_time = yes ; then
	    AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?])
	fi





















































    fi
])

#--------------------------------------------------------------------
# SC_TCL_LINK_LIBS
#
#	Search for the libraries needed to link the Tcl shell.