Tcl Source Code

2005-09-01  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclScan.c:	Extended [scan] to accept the %lld,
	%llo, %llx, and %lli formats.  Numeric scanning is now done
	via TclParseNumber calls.

	* generic/tclInt.h:	Extended TclParseNumber to accept new flag
	* generic/tclStrToD.c:	values TCL_PARSE_INTEGER_ONLY,
	TCL_PARSE_OCTAL_ONLY, and TCL_PARSE_HEXIDECIMAL_ONLY, to give caller
	more control over the parsing rules.

2005-08-30  Don Porter  <[email protected]>

	[kennykb-numerics-branch]

	* generic/tclObj.c:	Extended bignum support to include bignums
	so large they will not pack into a Tcl_Obj.  When they outgrow Tcl's
	string rep length limits, a panic will result.

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.35 2005/08/29 18:38:45 dgp Exp $
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.36 2005/09/01 16:09:56 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options

 *----------------------------------------------------------------------
 * Flags for TclParseNumber
 *----------------------------------------------------------------------
 */

#define TCL_PARSE_DECIMAL_ONLY 1
				/* Leading zero doesn't denote octal or hex */
#define TCL_PARSE_OCTAL_ONLY 2	/* Parse octal even without prefix */
#define TCL_PARSE_HEXADECIMAL_ONLY 4
				/* Parse hexadecimal even without prefix */
#define TCL_PARSE_INTEGER_ONLY 8
				/* Disable floating point parsing */

/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */

/*
 * tclScan.c --
 *
 *	This file contains the implementation of the "scan" command.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclScan.c,v 1.16.2.3 2005/08/23 18:28:51 kennykb Exp $
 * RCS: @(#) $Id: tclScan.c,v 1.16.2.4 2005/09/01 16:09:57 dgp Exp $
 */

#include "tclInt.h"

/*
 * Flag values used by Tcl_ScanObjCmd.
 */

#define SCAN_NOSKIP	0x1		/* Don't skip blanks. */
#define SCAN_SUPPRESS	0x2		/* Suppress assignment. */
#define SCAN_UNSIGNED	0x4		/* Read an unsigned value. */
#define SCAN_WIDTH	0x8		/* A width value was supplied. */

#if 0
#define SCAN_SIGNOK	0x10		/* A +/- character is allowed. */
#define SCAN_NODIGITS	0x20		/* No digits have been scanned. */
#define SCAN_NOZERO	0x40		/* No zero digits have been scanned. */
#define SCAN_XOK	0x80		/* An 'x' is allowed. */
#define SCAN_PTOK	0x100		/* Decimal point is allowed. */
#define SCAN_EXPOK	0x200		/* An exponent is allowed. */
#endif

#define SCAN_LONGER	0x400		/* Asked for a wide value. */
#define SCAN_BIG	0x800		/* Asked for a bignum value. */

/*
 * The following structure contains the information associated with a
 * character set.
 */

typedef struct CharSet {

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':
	    if (*format == 'l') {
		flags |= SCAN_BIG;
		format += 1;
		format += Tcl_UtfToUniChar(format, &ch);
		break;
	    }
	case 'L':
	    flags |= SCAN_LONGER;
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {

		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'n':
	case 's':
	    if (flags & SCAN_LONGER) {
	    invalidLonger:
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
	    invalidFieldSize:
		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		Tcl_AppendResult(interp,
			"'l' modifier may not be specified in %", buf,
			"field size modifier may not be specified in %", buf,
			" conversion", NULL);
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'd':
	case 'e':
	case 'f':
	case 'g':
	case 'i':
	case 'o':
	case 'u':
	case 'x':
	case 'x':
	    break;
	case 'u':
	    if (flags & SCAN_BIG) {
		Tcl_SetResult(interp,
			"unsigned bignum scans are invalid", TCL_STATIC);
		goto error;
	    }
	    break;
	    /*
	     * Bracket terms need special checking
	     */
	case '[':
	    if (flags & SCAN_LONGER) {
		goto invalidLonger;
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
		goto invalidFieldSize;
	    }
	    if (*format == '\0') {
		goto badSet;
	    }
	    format += Tcl_UtfToUniChar(format, &ch);
	    if (ch == '^') {
		if (*format == '\0') {

    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    long value;
    char *string, *end, *baseString;
    CONST char *string, *end, *baseString;
    char op = 0;
    int base = 0;
    int underflow = 0;
    size_t width;
    long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL;
    Tcl_WideInt wideValue;
#endif
    Tcl_UniChar ch, sch;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;
    char buf[513];		/* Temporary buffer to hold scanned number
				 * strings before they are passed to
				 * strtoul. */
#if 0
    int base = 0;
    long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#endif
#endif

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"string format ?varName varName ...?");
	return TCL_ERROR;
    }

     * reach the end of input, the end of the format string, or there is a
     * mismatch.
     */

    objIndex = 0;
    nconversions = 0;
    while (*format != '\0') {
	int parseFlag = 0;
	format += Tcl_UtfToUniChar(format, &ch);

	flags = 0;

	/*
	 * If we see whitespace in the format, skip whitespace in the string.
	 */

	 * ('%n$').
	 */

	if (ch == '*') {
	    flags |= SCAN_SUPPRESS;
	    format += Tcl_UtfToUniChar(format, &ch);
	} else if ((ch < 0x80) && isdigit(UCHAR(ch))) {	/* INTL: "C" locale. */
	    char *formatEnd;
	    value = strtoul(format-1, &end, 10);	/* INTL: "C" locale. */
	    if (*end == '$') {
		format = end+1;
	    value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
	    if (*formatEnd == '$') {
		format = formatEnd+1;
		format += Tcl_UtfToUniChar(format, &ch);
		objIndex = (int) value - 1;
	    }
	}

	/*
	 * Parse any width specifier.

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':
	    if (*format == 'l') {
		flags |= SCAN_BIG;
		format += 1;
		format += Tcl_UtfToUniChar(format, &ch);
		break;
	    }
	case 'L':
	    flags |= SCAN_LONGER;
	    /*
	     * Fall through so we skip to the next character.
	     */
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);

		objs[objIndex++] = objPtr;
	    }
	    nconversions++;
	    continue;

	case 'd':
	    op = 'i';
	    parseFlag = TCL_PARSE_DECIMAL_ONLY;
#if 0
	    base = 10;
	    fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif
#endif
	    break;
	case 'i':
	    op = 'i';
#if 0
	    base = 0;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif
#endif
	    break;
	case 'o':
	    op = 'i';
	    parseFlag = TCL_PARSE_OCTAL_ONLY;
#if 0
	    base = 8;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;
	case 'x':
	    op = 'i';
	    parseFlag = TCL_PARSE_HEXADECIMAL_ONLY;
#if 0
	    base = 16;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;
	case 'u':
	    op = 'i';
	    base = 10;
	    flags |= SCAN_UNSIGNED;
#if 0
	    base = 10;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;

	case 'f':
	case 'e':
	case 'g':
	    op = 'f';

	    break;

	case 'i':
	    /*
	     * Scan an unsigned or signed integer.
	     */

#if 0
	    if ((width == 0) || (width > sizeof(buf) - 1)) {
		width = sizeof(buf) - 1;
	    }
	    flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO;
	    for (end = buf; width > 0; width--) {
		switch (*string) {
		    /*

		}
#endif
		Tcl_IncrRefCount(objPtr);
		objs[objIndex++] = objPtr;
	    }

	    break;
#else
	    objPtr = Tcl_NewLongObj(0);
	    Tcl_IncrRefCount(objPtr);
	    if (width == 0) {
		width = -1;

	    }
	    if (TclParseNumber(NULL, objPtr, NULL, string, width, &end,
		    TCL_PARSE_INTEGER_ONLY | parseFlag) != TCL_OK) {
		Tcl_DecrRefCount(objPtr);
		/* TODO: set underflow?  test scan-4.44 */
		goto done;
	    }
	    string = end;
	    if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		break;
	    }
	    if (flags & SCAN_LONGER) {
		if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {		    wideValue = ~(Tcl_WideUInt)0 >> 1;	/* WIDE_MAX */
		    if (Tcl_GetString(objPtr)[0] == '-') {
			wideValue++;	/* WIDE_MAX + 1 = WIDE_MIN */
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
		    sprintf(buf, "%" TCL_LL_MODIFIER "u",
			    (Tcl_WideUInt)wideValue);
		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    Tcl_SetWideIntObj(objPtr, wideValue);
		}
	    } else if (!(flags & SCAN_BIG)) {
		if (Tcl_GetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (Tcl_GetString(objPtr)[0] == '-') {
			value = LONG_MIN;
		    } else {
			value = LONG_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {
		    sprintf(buf, "%lu", value);	/* INTL: ISO digit */
		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    Tcl_SetLongObj(objPtr, value);
		}
	    }
	    objs[objIndex++] = objPtr;
	    break;
#endif

	case 'f':
	    /*
	     * Scan a floating point number
	     */

	    flags &= ~SCAN_LONGER;
	    objPtr = Tcl_NewObj();
	    objPtr = Tcl_NewDoubleObj(0.0);
	    Tcl_IncrRefCount(objPtr);
	    if (width == 0) {
		width = -1;
	    }
	    if (TclParseNumber(NULL, objPtr, "", string, width, &end,
	    if (TclParseNumber(NULL, objPtr, NULL, string, width, &end,
			       TCL_PARSE_DECIMAL_ONLY) != TCL_OK) {
		/* TODO: set underflow?  test scan-4.55 */
		Tcl_DecrRefCount(objPtr);
		goto done;
	    } else if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		string = end;
	    } else {
		double dvalue;
		if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
		    if (objPtr->typePtr == &tclDoubleType) {
			dValue = objPtr->internalRep.doubleValue;
		    } else
#endif
		    {
		    Tcl_DecrRefCount(objPtr);
		    goto done;
		    }
		}
		Tcl_SetDoubleObj(objPtr, dvalue);
		objs[objIndex++] = objPtr;
		string = end;
	    }
	}
	nconversions++;

 *	interconversion among 'double' and 'mp_int' types.
 *
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.34 2005/08/24 21:49:23 dgp Exp $
 * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.35 2005/09/01 16:09:57 dgp Exp $
 *
 *----------------------------------------------------------------------
 */

#include <tclInt.h>
#include <stdio.h>
#include <stdlib.h>

	    if (c == '0') {
		if (flags & TCL_PARSE_DECIMAL_ONLY) {
		    state = DECIMAL;
		} else {
		    state = ZERO;
		}
		break;
	    } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
		goto zerox;
	    } else if (flags & TCL_PARSE_OCTAL_ONLY) {
		goto zeroo;
	    } else if (isdigit(UCHAR(c))) {
		significandWide = c - '0';
		numSigDigs = 1;
		state = DECIMAL;
		break;
	    } else if (flags & TCL_PARSE_INTEGER_ONLY) {
		goto endgame;
	    } else if (c == '.') {
		state = LEADING_RADIX_POINT;
		break;
	    } else if (c == 'I' || c == 'i') {
		state = sI;
		break;
#ifdef IEEE_FLOATING_POINT

	    }
	    if (c == 'o' || c == 'O') {
		explicitOctal = 1;
		state = ZERO_O;
		break;
	    }
#endif
	    if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
		goto zerox;
	    }
#ifdef KILL_OCTAL
	    goto decimal;
#endif
	    /* FALLTHROUGH */

	case OCTAL:
	    /*
	     * Scanned an optional + or -, followed by a string of
	     * octal digits.  Acceptable inputs are more digits,
	     * period, or E.  If 8 or 9 is encountered, commit to
	     * floating point.
	     */
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
#ifdef TIP_114_FORMATS
	    /* FALLTHROUGH */
	case ZERO_O:
#endif
	zeroo:
	    if (c == '0') {
		++numTrailZeros;
		state = OCTAL;
		break;
	    } else if (c >= '1' && c <= '7') {
		if (objPtr != NULL) {
		    shift = 3 * (numTrailZeros + 1);

	case BAD_OCTAL:
#ifdef TIP_114_FORMATS
	    if (explicitOctal) {
		/* No forgiveness for bad digits in explicitly octal numbers */
		goto endgame;
	    }
#endif
	    if (flags & TCL_PARSE_INTEGER_ONLY) {
		/* No seeking floating point when parsing only integer */
		goto endgame;
	    }
#ifndef KILL_OCTAL
	    /*
	     * Scanned a number with a leading zero that contains an
	     * 8, 9, radix point or E.  This is an invalid octal number,
	     * but might still be floating point.  
	     */
	    if (c == '0') {

	     */
	case HEXADECIMAL:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    /* FALLTHROUGH */
	case ZERO_X:
	zerox:
	    if (c == '0') {
		++numTrailZeros;
		state = HEXADECIMAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		d = (c-'0');
	    } else if (c >= 'A' && c <= 'F') {

					       &significandBig, 
					       significandOverflow);
		}
		numSigDigs += ( numTrailZeros + 1 );
		numTrailZeros = 0;
		state = DECIMAL;
		break;
	    } else if (flags & TCL_PARSE_INTEGER_ONLY) {
		goto endgame;
	    } else if (c == '.') {
		state = FRACTION;
		break;
	    } else if (c == 'E' || c == 'e') {
		state = EXPONENT_START;
		break;
	    }