Tcl Source Code

Check-in [d6c1d88425]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Now, restore wide(), but make int() the same as entier(). Add new utility function.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-514
Files: files | file ages | folders
SHA3-256:d6c1d884250d5a390bbb45636c1ab1399b51d743bd876c084bfd50dc4cf12db8
User & Date: jan.nijtmans 2018-08-28 22:28:50
Context
2018-08-29
19:30
Fix compilation on 32-bit platforms, and fix unit-tests in this environment check-in: 5598fa3c00 user: jan.nijtmans tags: tip-514
2018-08-28
22:28
Now, restore wide(), but make int() the same as entier(). Add new utility function. check-in: d6c1d88425 user: jan.nijtmans tags: tip-514
2018-08-21
21:36
improved reange checking (also for the Tcl 9.0 proposal). Make platform test platform 32/64-bit inde... check-in: 7ebb863e96 user: jan.nijtmans tags: tip-514
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclBasic.c.

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127

128
129
130
131
132
133
134
...
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
...
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
....
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665









3666
3667
3668
3669
3670
3671
3672
....
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
....
7660
7661
7662
7663
7664
7665
7666
7667
7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
7681
7682
7683
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
7699
7700
7701
....
7934
7935
7936
7937
7938
7939
7940
7941
7942
7943
7944
7945
7946
7947
7948
7949
7950
7951
7952
7953
7954
7955
7956
7957
7958
7959
7960
7961
7962
7963
7964
7965
7966
7967
7968
7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
#   define DTraceCmdReturn	NULL
#endif /* USE_DTRACE */
static Tcl_ObjCmdProc	ExprAbsFunc;
static Tcl_ObjCmdProc	ExprBinaryFunc;
static Tcl_ObjCmdProc	ExprBoolFunc;
static Tcl_ObjCmdProc	ExprCeilFunc;
static Tcl_ObjCmdProc	ExprDoubleFunc;
static Tcl_ObjCmdProc	ExprEntierFunc;
static Tcl_ObjCmdProc	ExprFloorFunc;
static Tcl_ObjCmdProc	ExprIntFunc;
static Tcl_ObjCmdProc	ExprIsqrtFunc;
static Tcl_ObjCmdProc	ExprMaxFunc;
static Tcl_ObjCmdProc	ExprMinFunc;
static Tcl_ObjCmdProc	ExprRandFunc;
static Tcl_ObjCmdProc	ExprRoundFunc;
static Tcl_ObjCmdProc	ExprSqrtFunc;
static Tcl_ObjCmdProc	ExprSrandFunc;
static Tcl_ObjCmdProc	ExprUnaryFunc;

static void		MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
			    int actual, Tcl_Obj *const *objv);
static Tcl_NRPostProc	NRCoroutineCallerCallback;
static Tcl_NRPostProc	NRCoroutineExitCallback;
static Tcl_NRPostProc	NRCommand;

#if !defined(TCL_NO_DEPRECATED)
................................................................................
    { "atan",	ExprUnaryFunc,	(ClientData) atan	},
    { "atan2",	ExprBinaryFunc,	(ClientData) atan2	},
    { "bool",	ExprBoolFunc,	NULL			},
    { "ceil",	ExprCeilFunc,	NULL			},
    { "cos",	ExprUnaryFunc,	(ClientData) cos	},
    { "cosh",	ExprUnaryFunc,	(ClientData) cosh	},
    { "double",	ExprDoubleFunc,	NULL			},
    { "entier",	ExprEntierFunc,	NULL			},
    { "exp",	ExprUnaryFunc,	(ClientData) exp	},
    { "floor",	ExprFloorFunc,	NULL			},
    { "fmod",	ExprBinaryFunc,	(ClientData) fmod	},
    { "hypot",	ExprBinaryFunc,	(ClientData) hypot	},
    { "int",	ExprIntFunc,	NULL			},
    { "isqrt",	ExprIsqrtFunc,	NULL			},
    { "log",	ExprUnaryFunc,	(ClientData) log	},
................................................................................
    { "round",	ExprRoundFunc,	NULL			},
    { "sin",	ExprUnaryFunc,	(ClientData) sin	},
    { "sinh",	ExprUnaryFunc,	(ClientData) sinh	},
    { "sqrt",	ExprSqrtFunc,	NULL			},
    { "srand",	ExprSrandFunc,	NULL			},
    { "tan",	ExprUnaryFunc,	(ClientData) tan	},
    { "tanh",	ExprUnaryFunc,	(ClientData) tanh	},
    { "wide",	ExprIntFunc,	NULL			},
    { NULL, NULL, NULL }
};

/*
 * TIP#174's math operators. All are safe.
 */

................................................................................
	    args[k].type = TCL_DOUBLE;
	    /* FALLTHROUGH */

	case TCL_DOUBLE:
	    args[k].doubleValue = d;
	    break;
	case TCL_INT:
	case TCL_WIDE_INT:
	    if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
		ckfree(args);
		return TCL_ERROR;









	    }
	    valuePtr = Tcl_GetObjResult(interp);
	    TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue);
	    Tcl_ResetResult(interp);
	    break;
	}
    }
................................................................................
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
    return TCL_OK;
}

static int
ExprEntierFunc(
    ClientData clientData,	/* Ignored. */
    Tcl_Interp *interp,		/* The interpreter in which to execute the
				 * function. */
    int objc,			/* Actual parameter count. */
    Tcl_Obj *const *objv)	/* Actual parameter vector. */
{
    double d;
................................................................................
     */

    Tcl_GetDoubleFromObj(interp, objv[1], &d);
    return TCL_ERROR;
}

static int
ExprIntFunc(
    ClientData clientData,	/* Ignored. */
    Tcl_Interp *interp,		/* The interpreter in which to execute the
				 * function. */
    int objc,			/* Actual parameter count. */
    Tcl_Obj *const *objv)	/* Actual parameter vector. */
{
    Tcl_WideInt wResult;
    Tcl_Obj *objPtr;

    if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }
    objPtr = Tcl_GetObjResult(interp);
    if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
	/*
	 * Truncate the bignum; keep only bits in wide int range.
	 */

	mp_int big;

	Tcl_GetBignumFromObj(NULL, objPtr, &big);
	mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
	objPtr = Tcl_NewBignumObj(&big);
	Tcl_IncrRefCount(objPtr);
	TclGetWideIntFromObj(NULL, objPtr, &wResult);
	Tcl_DecrRefCount(objPtr);
    }
    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
    return TCL_OK;
}

/*
 * Common implmentation of max() and min().
 */
................................................................................
    ClientData clientData,	/* Ignored. */
    Tcl_Interp *interp,		/* The interpreter in which to execute the
				 * function. */
    int objc,			/* Actual parameter count. */
    Tcl_Obj *const *objv)	/* Parameter vector. */
{
    Interp *iPtr = (Interp *) interp;
    long i = 0;			/* Initialized to avoid compiler warning. */

    /*
     * Convert argument and use it to reset the seed.
     */

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }

    if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
	Tcl_Obj *objPtr;
	mp_int big;

	if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
	    /* TODO: more ::errorInfo here? or in caller? */
	    return TCL_ERROR;
	}

	mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
	objPtr = Tcl_NewBignumObj(&big);
	Tcl_IncrRefCount(objPtr);
	TclGetLongFromObj(NULL, objPtr, &i);
	Tcl_DecrRefCount(objPtr);
    }

    /*
     * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
     * ExprRandFunc for more details.
     */

    iPtr->flags |= RAND_SEED_INITIALIZED;
    iPtr->randSeed = i;
    iPtr->randSeed &= (unsigned long) 0x7fffffff;
    if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
	iPtr->randSeed ^= 123459876;
    }

    /*
     * To avoid duplicating the random number generation code we simply clean
     * up our state and call the real random number function. That function







<










>







 







|







 







|







 







<



>
>
>
>
>
>
>
>
>







 







|







 







|







<

|


|
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|










|
<
<
<
<
<
|
<
<
<
<
<
<
<








<
|







110
111
112
113
114
115
116

117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
...
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
...
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
....
3655
3656
3657
3658
3659
3660
3661

3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
....
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
7623
7624
7625
7626
....
7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
7681
7682

7683
7684
7685
7686
7687














7688
7689
7690
7691
7692
7693
7694
....
7927
7928
7929
7930
7931
7932
7933
7934
7935
7936
7937
7938
7939
7940
7941
7942
7943
7944
7945





7946







7947
7948
7949
7950
7951
7952
7953
7954

7955
7956
7957
7958
7959
7960
7961
7962
#   define DTraceCmdReturn	NULL
#endif /* USE_DTRACE */
static Tcl_ObjCmdProc	ExprAbsFunc;
static Tcl_ObjCmdProc	ExprBinaryFunc;
static Tcl_ObjCmdProc	ExprBoolFunc;
static Tcl_ObjCmdProc	ExprCeilFunc;
static Tcl_ObjCmdProc	ExprDoubleFunc;

static Tcl_ObjCmdProc	ExprFloorFunc;
static Tcl_ObjCmdProc	ExprIntFunc;
static Tcl_ObjCmdProc	ExprIsqrtFunc;
static Tcl_ObjCmdProc	ExprMaxFunc;
static Tcl_ObjCmdProc	ExprMinFunc;
static Tcl_ObjCmdProc	ExprRandFunc;
static Tcl_ObjCmdProc	ExprRoundFunc;
static Tcl_ObjCmdProc	ExprSqrtFunc;
static Tcl_ObjCmdProc	ExprSrandFunc;
static Tcl_ObjCmdProc	ExprUnaryFunc;
static Tcl_ObjCmdProc	ExprWideFunc;
static void		MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
			    int actual, Tcl_Obj *const *objv);
static Tcl_NRPostProc	NRCoroutineCallerCallback;
static Tcl_NRPostProc	NRCoroutineExitCallback;
static Tcl_NRPostProc	NRCommand;

#if !defined(TCL_NO_DEPRECATED)
................................................................................
    { "atan",	ExprUnaryFunc,	(ClientData) atan	},
    { "atan2",	ExprBinaryFunc,	(ClientData) atan2	},
    { "bool",	ExprBoolFunc,	NULL			},
    { "ceil",	ExprCeilFunc,	NULL			},
    { "cos",	ExprUnaryFunc,	(ClientData) cos	},
    { "cosh",	ExprUnaryFunc,	(ClientData) cosh	},
    { "double",	ExprDoubleFunc,	NULL			},
    { "entier",	ExprIntFunc,	NULL			},
    { "exp",	ExprUnaryFunc,	(ClientData) exp	},
    { "floor",	ExprFloorFunc,	NULL			},
    { "fmod",	ExprBinaryFunc,	(ClientData) fmod	},
    { "hypot",	ExprBinaryFunc,	(ClientData) hypot	},
    { "int",	ExprIntFunc,	NULL			},
    { "isqrt",	ExprIsqrtFunc,	NULL			},
    { "log",	ExprUnaryFunc,	(ClientData) log	},
................................................................................
    { "round",	ExprRoundFunc,	NULL			},
    { "sin",	ExprUnaryFunc,	(ClientData) sin	},
    { "sinh",	ExprUnaryFunc,	(ClientData) sinh	},
    { "sqrt",	ExprSqrtFunc,	NULL			},
    { "srand",	ExprSrandFunc,	NULL			},
    { "tan",	ExprUnaryFunc,	(ClientData) tan	},
    { "tanh",	ExprUnaryFunc,	(ClientData) tanh	},
    { "wide",	ExprWideFunc,	NULL			},
    { NULL, NULL, NULL }
};

/*
 * TIP#174's math operators. All are safe.
 */

................................................................................
	    args[k].type = TCL_DOUBLE;
	    /* FALLTHROUGH */

	case TCL_DOUBLE:
	    args[k].doubleValue = d;
	    break;
	case TCL_INT:

	    if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
		ckfree(args);
		return TCL_ERROR;
	    }
	    valuePtr = Tcl_GetObjResult(interp);
	    Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue);
	    Tcl_ResetResult(interp);
	    break;
	case TCL_WIDE_INT:
	    if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
		ckfree(args);
		return TCL_ERROR;
	    }
	    valuePtr = Tcl_GetObjResult(interp);
	    TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue);
	    Tcl_ResetResult(interp);
	    break;
	}
    }
................................................................................
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
    return TCL_OK;
}

static int
ExprIntFunc(
    ClientData clientData,	/* Ignored. */
    Tcl_Interp *interp,		/* The interpreter in which to execute the
				 * function. */
    int objc,			/* Actual parameter count. */
    Tcl_Obj *const *objv)	/* Actual parameter vector. */
{
    double d;
................................................................................
     */

    Tcl_GetDoubleFromObj(interp, objv[1], &d);
    return TCL_ERROR;
}

static int
ExprWideFunc(
    ClientData clientData,	/* Ignored. */
    Tcl_Interp *interp,		/* The interpreter in which to execute the
				 * function. */
    int objc,			/* Actual parameter count. */
    Tcl_Obj *const *objv)	/* Actual parameter vector. */
{
    Tcl_WideInt wResult;


    if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }
    TclGetLeastSign64bits(NULL, Tcl_GetObjResult(interp), &wResult);














    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
    return TCL_OK;
}

/*
 * Common implmentation of max() and min().
 */
................................................................................
    ClientData clientData,	/* Ignored. */
    Tcl_Interp *interp,		/* The interpreter in which to execute the
				 * function. */
    int objc,			/* Actual parameter count. */
    Tcl_Obj *const *objv)	/* Parameter vector. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_WideInt w = 0;			/* Initialized to avoid compiler warning. */

    /*
     * Convert argument and use it to reset the seed.
     */

    if (objc != 2) {
	MathFuncWrongNumArgs(interp, 2, objc, objv);
	return TCL_ERROR;
    }

    if (TclGetLeastSign64bits(NULL, objv[1], &w) != TCL_OK) {





	return TCL_ERROR;







    }

    /*
     * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
     * ExprRandFunc for more details.
     */

    iPtr->flags |= RAND_SEED_INITIALIZED;

    iPtr->randSeed = w & (unsigned long) 0x7fffffff;
    if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
	iPtr->randSeed ^= 123459876;
    }

    /*
     * To avoid duplicating the random number generation code we simply clean
     * up our state and call the real random number function. That function

Changes to generic/tclBinary.c.

1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
....
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
....
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
FormatNumber(
    Tcl_Interp *interp,		/* Current interpreter, used to report
				 * errors. */
    int type,			/* Type of number to format. */
    Tcl_Obj *src,		/* Number to format. */
    unsigned char **cursorPtr)	/* Pointer to index into destination buffer. */
{
    long value;
    double dvalue;
    Tcl_WideInt wvalue;
    float fvalue;

    switch (type) {
    case 'd':
    case 'q':
................................................................................

	/*
	 * 64-bit integer values.
	 */
    case 'w':
    case 'W':
    case 'm':
	if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
................................................................................

	/*
	 * 32-bit integer values.
	 */
    case 'i':
    case 'I':
    case 'n':
	if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(value);
	    *(*cursorPtr)++ = UCHAR(value >> 8);
	    *(*cursorPtr)++ = UCHAR(value >> 16);
	    *(*cursorPtr)++ = UCHAR(value >> 24);
	} else {
	    *(*cursorPtr)++ = UCHAR(value >> 24);
	    *(*cursorPtr)++ = UCHAR(value >> 16);
	    *(*cursorPtr)++ = UCHAR(value >> 8);
	    *(*cursorPtr)++ = UCHAR(value);
	}
	return TCL_OK;

	/*
	 * 16-bit integer values.
	 */
    case 's':
    case 'S':
    case 't':
	if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(value);
	    *(*cursorPtr)++ = UCHAR(value >> 8);
	} else {
	    *(*cursorPtr)++ = UCHAR(value >> 8);
	    *(*cursorPtr)++ = UCHAR(value);
	}
	return TCL_OK;

	/*
	 * 8-bit integer values.
	 */
    case 'c':
	if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	*(*cursorPtr)++ = UCHAR(value);
	return TCL_OK;

    default:
	Tcl_Panic("unexpected fallthrough");
	return TCL_ERROR;
    }
}







<







 







|







 







|



|
|
|
|

|
|
|
|









|



|
|

|
|







|


|







1959
1960
1961
1962
1963
1964
1965

1966
1967
1968
1969
1970
1971
1972
....
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
....
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
FormatNumber(
    Tcl_Interp *interp,		/* Current interpreter, used to report
				 * errors. */
    int type,			/* Type of number to format. */
    Tcl_Obj *src,		/* Number to format. */
    unsigned char **cursorPtr)	/* Pointer to index into destination buffer. */
{

    double dvalue;
    Tcl_WideInt wvalue;
    float fvalue;

    switch (type) {
    case 'd':
    case 'q':
................................................................................

	/*
	 * 64-bit integer values.
	 */
    case 'w':
    case 'W':
    case 'm':
	if (TclGetLeastSign64bits(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
................................................................................

	/*
	 * 32-bit integer values.
	 */
    case 'i':
    case 'I':
    case 'n':
	if (TclGetLeastSign64bits(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
	} else {
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue);
	}
	return TCL_OK;

	/*
	 * 16-bit integer values.
	 */
    case 's':
    case 'S':
    case 't':
	if (TclGetLeastSign64bits(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	} else {
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue);
	}
	return TCL_OK;

	/*
	 * 8-bit integer values.
	 */
    case 'c':
	if (TclGetLeastSign64bits(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	*(*cursorPtr)++ = UCHAR(wvalue);
	return TCL_OK;

    default:
	Tcl_Panic("unexpected fallthrough");
	return TCL_ERROR;
    }
}

Changes to generic/tclCmdMZ.c.

1618
1619
1620
1621
1622
1623
1624

1625
1626
1627
1628
1629
1630
1631
....
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
	    }
	}
	break;
    }
    case STR_IS_GRAPH:
	chcomp = Tcl_UniCharIsGraph;
	break;

    case STR_IS_ENTIER:
	if ((objPtr->typePtr == &tclIntType) ||
		(objPtr->typePtr == &tclBignumType)) {
	    break;
	}
	string1 = TclGetStringFromObj(objPtr, &length1);
	if (length1 == 0) {
................................................................................
	     * No prefix is a valid integer. Fail at beginning.
	     */

	    result = 0;
	    failat = 0;
	}
	break;
    case STR_IS_INT:
    case STR_IS_WIDE:
	if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
	    break;
	}

	string1 = TclGetStringFromObj(objPtr, &length1);
	if (length1 == 0) {







>







 







<







1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
....
1661
1662
1663
1664
1665
1666
1667

1668
1669
1670
1671
1672
1673
1674
	    }
	}
	break;
    }
    case STR_IS_GRAPH:
	chcomp = Tcl_UniCharIsGraph;
	break;
    case STR_IS_INT:
    case STR_IS_ENTIER:
	if ((objPtr->typePtr == &tclIntType) ||
		(objPtr->typePtr == &tclBignumType)) {
	    break;
	}
	string1 = TclGetStringFromObj(objPtr, &length1);
	if (length1 == 0) {
................................................................................
	     * No prefix is a valid integer. Fail at beginning.
	     */

	    result = 0;
	    failat = 0;
	}
	break;

    case STR_IS_WIDE:
	if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
	    break;
	}

	string1 = TclGetStringFromObj(objPtr, &length1);
	if (length1 == 0) {

Changes to generic/tclCompCmdsSZ.c.

687
688
689
690
691
692
693
694
695
696
697
698

699
700
701
702
703
704
705
	} else {
	    OP(		NUM_TYPE);
	    OP(		DUP);
	    JUMP1(	JUMP_FALSE, end);
	}

	switch (t) {
	case STR_IS_INT:
	case STR_IS_WIDE:
	    PUSH(	"2");
	    OP(		LE);
	    break;

	case STR_IS_ENTIER:
	    PUSH(	"3");
	    OP(		LE);
	    break;
	}
	FIXJUMP1(	end);
	return TCL_OK;







<




>







687
688
689
690
691
692
693

694
695
696
697
698
699
700
701
702
703
704
705
	} else {
	    OP(		NUM_TYPE);
	    OP(		DUP);
	    JUMP1(	JUMP_FALSE, end);
	}

	switch (t) {

	case STR_IS_WIDE:
	    PUSH(	"2");
	    OP(		LE);
	    break;
	case STR_IS_INT:
	case STR_IS_ENTIER:
	    PUSH(	"3");
	    OP(		LE);
	    break;
	}
	FIXJUMP1(	end);
	return TCL_OK;

Changes to generic/tclInt.h.

3040
3041
3042
3043
3044
3045
3046


3047
3048
3049
3050
3051
3052
3053
MODULE_SCOPE Tcl_Obj *	TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    unsigned int *sizePtr);
MODULE_SCOPE int	TclGetLoadedPackagesEx(Tcl_Interp *interp,
				const char *targetName,
				const char *packageName);


MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData *types);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);







>
>







3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
MODULE_SCOPE Tcl_Obj *	TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    unsigned int *sizePtr);
MODULE_SCOPE int	TclGetLoadedPackagesEx(Tcl_Interp *interp,
				const char *targetName,
				const char *packageName);
MODULE_SCOPE int	TclGetLeastSign64bits(Tcl_Interp *, Tcl_Obj *,
				Tcl_WideInt *);
MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData *types);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);

Changes to generic/tclObj.c.

3113
3114
3115
3116
3117
3118
3119




































































3120
3121
3122
3123
3124
3125
3126
		const char *s = "integer value too large to represent";
		Tcl_Obj *msg = Tcl_NewStringObj(s, -1);

		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	    }
	    return TCL_ERROR;




































































	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}
 
/*







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
		const char *s = "integer value too large to represent";
		Tcl_Obj *msg = Tcl_NewStringObj(s, -1);

		Tcl_SetObjResult(interp, msg);
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	    }
	    return TCL_ERROR;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}
 
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetLeastSign64bits --
 *
 *	Attempt to return a wide integer from the Tcl object "objPtr". If the
 *	object is not already a wide int object, an attempt will be made to
 *	convert it to one. Integer out-of-range values don't result in an
 *  error, but only the least significant 64 bit will be returned. 
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during conversion, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	If the object is not already an int object, the conversion will free
 *	any old internal representation.
 *
 *----------------------------------------------------------------------
 */

int
TclGetLeastSign64bits(
    Tcl_Interp *interp,         /* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,            /* Object from which to get a wide int. */
    Tcl_WideInt *wideIntPtr)    /* Place to store resulting wide integer. */
{
    do {
	if (objPtr->typePtr == &tclIntType) {
	    *wideIntPtr = objPtr->internalRep.wideValue;
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclDoubleType) {
	    if (interp != NULL) {
                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "expected integer but got \"%s\"",
                        TclGetString(objPtr)));
		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
	    }
	    return TCL_ERROR;
	}
	if (objPtr->typePtr == &tclBignumType) {
	    mp_int big;

	    Tcl_WideUInt value = 0, scratch;
	    unsigned long numBytes = sizeof(Tcl_WideInt);
	    unsigned char *bytes = (unsigned char *) &scratch;

	    Tcl_GetBignumFromObj(NULL, objPtr, &big);
	    mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
	    mp_to_unsigned_bin_n(&big, bytes, &numBytes);
	    while (numBytes-- > 0) {
		value = (value << CHAR_BIT) | *bytes++;
	    }
	    if (big.sign) {
		value = -value;
	    }
	    *wideIntPtr = (Tcl_WideInt) value;
	    mp_clear(&big);
	    return TCL_OK;
	}
    } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
	    TCL_PARSE_INTEGER_ONLY)==TCL_OK);
    return TCL_ERROR;
}
 
/*

Changes to generic/tclScan.c.

567
568
569
570
571
572
573
574
575
576
577

578
579
580
581
582
583
584
...
919
920
921
922
923
924
925











926
927
928
929
930
931
932
933
...
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    Tcl_WideInt value;
    const char *string, *end, *baseString;
    char op = 0;
    int width, underflow = 0;

    Tcl_UniChar ch = 0, sch = 0;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;
    char buf[513];		/* Temporary buffer to hold scanned number
				 * strings before they are passed to
				 * strtoul. */

................................................................................
		goto done;
	    }
	    string = end;
	    if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		break;
	    }











	    if (flags & SCAN_BIG) {
		if (flags & SCAN_UNSIGNED) {
		    mp_int big;
		    int code = Tcl_GetBignumFromObj(interp, objPtr, &big);

		    if (code == TCL_OK) {
			if (mp_isneg(&big)) {
			    code = TCL_ERROR;
................................................................................
				"unsigned bignum scans are invalid", -1));
			Tcl_SetErrorCode(interp, "TCL", "FORMAT",
				"BADUNSIGNED",NULL);
			return TCL_ERROR;
		    }
		}
	    } else {
		if (TclGetWideIntFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (TclGetString(objPtr)[0] == '-') {
			value = LLONG_MIN;
		    } else {
			value = LLONG_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {
		    sprintf(buf, "%" TCL_LL_MODIFIER "u", value);	/* INTL: ISO digit */
		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    TclSetIntObj(objPtr, value);
		}
	    }
	    objs[objIndex++] = objPtr;
	    break;







|



>







 







>
>
>
>
>
>
>
>
>
>
>
|







 







|

|

|



|







567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
...
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
...
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    long value;
    const char *string, *end, *baseString;
    char op = 0;
    int width, underflow = 0;
    Tcl_WideInt wideValue;
    Tcl_UniChar ch = 0, sch = 0;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;
    char buf[513];		/* Temporary buffer to hold scanned number
				 * strings before they are passed to
				 * strtoul. */

................................................................................
		goto done;
	    }
	    string = end;
	    if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		break;
	    }
	    if (flags & SCAN_LONGER) {
		if (TclGetLeastSign64bits(NULL, objPtr, &wideValue) != TCL_OK) {
		    goto done;
		}
		if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
		    sprintf(buf, "%" TCL_LL_MODIFIER "u",
			    (Tcl_WideUInt)wideValue);
		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    TclSetIntObj(objPtr, wideValue);
		}
	    } else if (flags & SCAN_BIG) {
		if (flags & SCAN_UNSIGNED) {
		    mp_int big;
		    int code = Tcl_GetBignumFromObj(interp, objPtr, &big);

		    if (code == TCL_OK) {
			if (mp_isneg(&big)) {
			    code = TCL_ERROR;
................................................................................
				"unsigned bignum scans are invalid", -1));
			Tcl_SetErrorCode(interp, "TCL", "FORMAT",
				"BADUNSIGNED",NULL);
			return TCL_ERROR;
		    }
		}
	    } else {
		if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (TclGetString(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 {
		    TclSetIntObj(objPtr, value);
		}
	    }
	    objs[objIndex++] = objPtr;
	    break;

Changes to generic/tclStringObj.c.

1789
1790
1791
1792
1793
1794
1795



1796
1797
1798
1799
1800
1801
1802
....
1979
1980
1981
1982
1983
1984
1985




1986
1987
1988
1989
1990



1991
1992
1993
1994
1995
1996
1997
....
2053
2054
2055
2056
2057
2058
2059

2060
2061
2062
2063





2064
2065
2066
2067
2068
2069
2070
....
2075
2076
2077
2078
2079
2080
2081


2082
2083
2084
2085
2086
2087
















2088
2089
2090
2091
2092



2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
....
2149
2150
2151
2152
2153
2154
2155




2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
....
2232
2233
2234
2235
2236
2237
2238










2239
2240
2241
2242
2243
2244
2245
....
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
     * Format string is NUL-terminated.
     */

    while (*format != '\0') {
	char *end;
	int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
	int width, gotPrecision, precision, sawFlag, useShort = 0, useBig = 0;



	int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes;
	Tcl_Obj *segment;
	int step = TclUtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {
	    numBytes += step;
................................................................................
	} else if (ch == 'l') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    if (ch == 'l') {
		useBig = 1;
		format += step;
		step = TclUtfToUniChar(format, &ch);




	    }
	} else if (ch == 'I') {
	    if ((format[1] == '6') && (format[2] == '4')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);



	    } else if ((format[1] == '3') && (format[2] == '2')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
	    } else {
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    }
................................................................................
	case 'o':
	case 'p':
	case 'x':
	case 'X':
	case 'b': {
	    short s = 0;	/* Silence compiler warning; only defined and
				 * used when useShort is true. */

	    Tcl_WideInt w;
	    mp_int big;
	    int toAppend, isNegative = 0;






	    if (useBig) {
		int cmpResult;
		if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
		    goto error;
		}
		cmpResult = mp_cmp_d(&big, 0);
		isNegative = (cmpResult == MP_LT);
................................................................................
			msg = "unsigned bignum format is invalid";
			errCode = "BADUNSIGNED";
			goto errorMsg;
		    } else {
			ch = 'd';
		    }
		}


	    } else if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
		Tcl_Obj *objPtr;

		if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
		    goto error;
		}
















		mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
		objPtr = Tcl_NewBignumObj(&big);
		Tcl_IncrRefCount(objPtr);
		TclGetWideIntFromObj(NULL, objPtr, &w);
		Tcl_DecrRefCount(objPtr);



		if (useShort) {
		    s = (short) w;
		    isNegative = (s < (short) 0);
		    if (s == (short) 0) gotHash = 0;
		} else {
		    isNegative = (w < (long) 0);
		    if (w == (long) 0) gotHash = 0;
		}
	    } else if (useShort) {
		s = (short) w;
		isNegative = (s < (short) 0);
		if (s == (short) 0) gotHash = 0;
	    } else {
		isNegative = (w < (Tcl_WideInt) 0);
		if (w == (Tcl_WideInt) 0) gotHash = 0;
	    }

	    segment = Tcl_NewObj();
	    allocSegment = 1;
	    segmentLimit = INT_MAX;
	    Tcl_IncrRefCount(segment);

................................................................................
	    case 'd': {
		int length;
		Tcl_Obj *pure;
		const char *bytes;

		if (useShort) {
		    pure = Tcl_NewIntObj((int) s);




		} else if (useBig) {
		    pure = Tcl_NewBignumObj(&big);
		} else {
		    pure = Tcl_NewWideIntObj(w);
		}
		Tcl_IncrRefCount(pure);
		bytes = TclGetStringFromObj(pure, &length);

		/*
		 * Already did the sign above.
		 */
................................................................................
		    unsigned short us = (unsigned short) s;

		    bits = (Tcl_WideUInt) us;
		    while (us) {
			numDigits++;
			us /= base;
		    }










		} else if (useBig && big.used) {
		    int leftover = (big.used * DIGIT_BIT) % numBits;
		    mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);

		    numDigits = 1 +
			    (((Tcl_WideInt) big.used * DIGIT_BIT) / numBits);
		    while ((mask & big.dp[big.used-1]) == 0) {
................................................................................
		    }
		    if (numDigits > INT_MAX) {
			msg = overflow;
			errCode = "OVERFLOW";
			goto errorMsg;
		    }
		} else if (!useBig) {
		    Tcl_WideUInt uw = (Tcl_WideUInt) w;

		    bits = (Tcl_WideUInt) uw;
		    while (uw) {
			numDigits++;
			uw /= base;
		    }
		}

		/*
		 * Need to be sure zero becomes "0", not "".
		 */








>
>
>







 







>
>
>
>





>
>
>







 







>




>
>
>
>
>







 







>
>
|
|

|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
>
>
>

|



|
|


|



|
|







 







>
>
>
>



|







 







>
>
>
>
>
>
>
>
>
>







 







|

|
|

|







1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
....
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
....
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
....
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
....
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
....
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
....
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
     * Format string is NUL-terminated.
     */

    while (*format != '\0') {
	char *end;
	int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
	int width, gotPrecision, precision, sawFlag, useShort = 0, useBig = 0;
#ifndef TCL_WIDE_INT_IS_LONG
	int useWide = 0;
#endif
	int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes;
	Tcl_Obj *segment;
	int step = TclUtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {
	    numBytes += step;
................................................................................
	} else if (ch == 'l') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    if (ch == 'l') {
		useBig = 1;
		format += step;
		step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
	    } else {
		useWide = 1;
#endif
	    }
	} else if (ch == 'I') {
	    if ((format[1] == '6') && (format[2] == '4')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
#ifndef TCL_WIDE_INT_IS_LONG
		useWide = 1;
#endif
	    } else if ((format[1] == '3') && (format[2] == '2')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
	    } else {
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    }
................................................................................
	case 'o':
	case 'p':
	case 'x':
	case 'X':
	case 'b': {
	    short s = 0;	/* Silence compiler warning; only defined and
				 * used when useShort is true. */
	    long l;
	    Tcl_WideInt w;
	    mp_int big;
	    int toAppend, isNegative = 0;

#ifndef TCL_WIDE_INT_IS_LONG
	    if (ch == 'p') {
		useWide = 1;
	    }
#endif
	    if (useBig) {
		int cmpResult;
		if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
		    goto error;
		}
		cmpResult = mp_cmp_d(&big, 0);
		isNegative = (cmpResult == MP_LT);
................................................................................
			msg = "unsigned bignum format is invalid";
			errCode = "BADUNSIGNED";
			goto errorMsg;
		    } else {
			ch = 'd';
		    }
		}
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (useWide) {
		if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
		    Tcl_Obj *objPtr;

		    if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
			goto error;
		    }
		    mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big);
		    objPtr = Tcl_NewBignumObj(&big);
		    Tcl_IncrRefCount(objPtr);
		    TclGetWideIntFromObj(NULL, objPtr, &w);
		    Tcl_DecrRefCount(objPtr);
		}
		isNegative = (w < (Tcl_WideInt) 0);
		if (w == (Tcl_WideInt) 0) gotHash = 0;
#endif
	    } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
		if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
		    Tcl_Obj *objPtr;

		    if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
			goto error;
		    }
		    mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
		    objPtr = Tcl_NewBignumObj(&big);
		    Tcl_IncrRefCount(objPtr);
		    TclGetLongFromObj(NULL, objPtr, &l);
		    Tcl_DecrRefCount(objPtr);
		} else {
		    l = Tcl_WideAsLong(w);
		}
		if (useShort) {
		    s = (short) l;
		    isNegative = (s < (short) 0);
		    if (s == (short) 0) gotHash = 0;
		} else {
		    isNegative = (l < (long) 0);
		    if (l == (long) 0) gotHash = 0;
		}
	    } else if (useShort) {
		s = (short) l;
		isNegative = (s < (short) 0);
		if (s == (short) 0) gotHash = 0;
	    } else {
		isNegative = (l < (long) 0);
		if (l == (long) 0) gotHash = 0;
	    }

	    segment = Tcl_NewObj();
	    allocSegment = 1;
	    segmentLimit = INT_MAX;
	    Tcl_IncrRefCount(segment);

................................................................................
	    case 'd': {
		int length;
		Tcl_Obj *pure;
		const char *bytes;

		if (useShort) {
		    pure = Tcl_NewIntObj((int) s);
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (useWide) {
		    pure = Tcl_NewWideIntObj(w);
#endif
		} else if (useBig) {
		    pure = Tcl_NewBignumObj(&big);
		} else {
		    pure = Tcl_NewLongObj(l);
		}
		Tcl_IncrRefCount(pure);
		bytes = TclGetStringFromObj(pure, &length);

		/*
		 * Already did the sign above.
		 */
................................................................................
		    unsigned short us = (unsigned short) s;

		    bits = (Tcl_WideUInt) us;
		    while (us) {
			numDigits++;
			us /= base;
		    }
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (useWide) {
		    Tcl_WideUInt uw = (Tcl_WideUInt) w;

		    bits = uw;
		    while (uw) {
			numDigits++;
			uw /= base;
		    }
#endif
		} else if (useBig && big.used) {
		    int leftover = (big.used * DIGIT_BIT) % numBits;
		    mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);

		    numDigits = 1 +
			    (((Tcl_WideInt) big.used * DIGIT_BIT) / numBits);
		    while ((mask & big.dp[big.used-1]) == 0) {
................................................................................
		    }
		    if (numDigits > INT_MAX) {
			msg = overflow;
			errCode = "OVERFLOW";
			goto errorMsg;
		    }
		} else if (!useBig) {
		    unsigned long ul = (unsigned long) l;

		    bits = (Tcl_WideUInt) ul;
		    while (ul) {
			numDigits++;
			ul /= base;
		    }
		}

		/*
		 * Need to be sure zero becomes "0", not "".
		 */

Changes to tests/compExpr-old.test.

74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
	default {
	    return 0
	}
    }
}
testConstraint ieeeFloatingPoint [testIEEE]

testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]

# procedures used below

proc put_hello_char {c} {
    global a
    append a [format %c $c]
    return $c
................................................................................
test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8

# The following test is different for 32-bit versus 64-bit
# architectures because LONG_MIN is different

test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
    expr {int(1<<63)}
} -9223372036854775808
test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
    expr {int(1<<31)}
} -2147483648

test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body {
    expr x>>3
} -returnCodes error -match glob -result *







|
|







 







|







74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
	default {
	    return 0
	}
    }
}
testConstraint ieeeFloatingPoint [testIEEE]

testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]

# procedures used below

proc put_hello_char {c} {
    global a
    append a [format %c $c]
    return $c
................................................................................
test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8

# The following test is different for 32-bit versus 64-bit
# architectures because LONG_MIN is different

test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
    expr {int(1<<63)}
} 9223372036854775808
test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
    expr {int(1<<31)}
} -2147483648

test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body {
    expr x>>3
} -returnCodes error -match glob -result *

Changes to tests/expr-old.test.

809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
    expr int(-1.4)
} {-1}
test expr-old-32.32 {math functions in expressions} {
    expr int(-1.6)
} {-1}
test expr-old-32.33 {math functions in expressions} {
    expr int(1e60)
} 0
test expr-old-32.34 {math functions in expressions} {
    expr int(-1e60)
} 0
test expr-old-32.35 {math functions in expressions} {
    expr round(1.49)
} {1}
test expr-old-32.36 {math functions in expressions} {
    expr round(1.51)
} {2}
test expr-old-32.37 {math functions in expressions} {







|


|







809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
    expr int(-1.4)
} {-1}
test expr-old-32.32 {math functions in expressions} {
    expr int(-1.6)
} {-1}
test expr-old-32.33 {math functions in expressions} {
    expr int(1e60)
} 999999999999999949387135297074018866963645011013410073083904
test expr-old-32.34 {math functions in expressions} {
    expr int(-1e60)
} -999999999999999949387135297074018866963645011013410073083904
test expr-old-32.35 {math functions in expressions} {
    expr round(1.49)
} {1}
test expr-old-32.36 {math functions in expressions} {
    expr round(1.51)
} {2}
test expr-old-32.37 {math functions in expressions} {

Changes to tests/expr.test.

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
...
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.

testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
testConstraint wideIs64bit \
	[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
................................................................................

test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
    expr {int(1<<63)}
} -9223372036854775808
test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
    expr {int(1<<31)}
} -2147483648
test expr-9.6 {CompileRelationalExpr: error in shift expr} -body {
    expr x>>3
} -returnCodes error -match glob -result *
test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1







|
|







 







|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
...
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.

testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit \
	[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
................................................................................

test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
    expr {int(1<<63)}
} 9223372036854775808
test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
    expr {int(1<<31)}
} -2147483648
test expr-9.6 {CompileRelationalExpr: error in shift expr} -body {
    expr x>>3
} -returnCodes error -match glob -result *
test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1

Changes to tests/format.test.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
...
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
...
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# %u output depends on word length, so this test is not portable.
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
testConstraint wideIs64bit \
	[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
 
test format-1.1 {integer formatting} {
    format "%*d %d %d %d" 6 34 16923 -12 -1
} {    34 16923 -12 -1}
test format-1.2 {integer formatting} {
    format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
................................................................................
for {set i 290} {$i < 400} {incr i} {
    test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
        format {%s} $b
    } $b
    append b "x"
}

test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} {
    format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {wideIs64bit} {
    format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {wideIs64bit} {
    format %ld 42
................................................................................
    lappend result [expr {$a == $b}]
    set b 0xaaaa
    append b aaaa
    lappend result [expr {$a == $b}]
    format %08x $b
    lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
    set a [expr {0xaaaaaaaaaa + 1}]
    set b 0xaaaaaaaaab
    list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}

test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
    set x 0x8fedc654







|
|


<







 







|







 







|







12
13
14
15
16
17
18
19
20
21
22

23
24
25
26
27
28
29
...
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
...
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# %u output depends on word length, so this test is not portable.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit \
	[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]

testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
 
test format-1.1 {integer formatting} {
    format "%*d %d %d %d" 6 34 16923 -12 -1
} {    34 16923 -12 -1}
test format-1.2 {integer formatting} {
    format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
................................................................................
for {set i 290} {$i < 400} {incr i} {
    test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
        format {%s} $b
    } $b
    append b "x"
}

test format-17.1 {testing %d with wide} {wideIs64bit longIs32bit} {
    format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {wideIs64bit} {
    format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {wideIs64bit} {
    format %ld 42
................................................................................
    lappend result [expr {$a == $b}]
    set b 0xaaaa
    append b aaaa
    lappend result [expr {$a == $b}]
    format %08x $b
    lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {longIs32bit} {
    set a [expr {0xaaaaaaaaaa + 1}]
    set b 0xaaaaaaaaab
    list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}

test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
    set x 0x8fedc654

Changes to tests/get.test.

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testgetint [llength [info commands testgetint]]
testConstraint testdoubleobj [llength [info commands testdoubleobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
 
test get-1.1 {Tcl_GetInt procedure} testgetint {
    testgetint 44 { 	  22}
} {66}
test get-1.2 {Tcl_GetInt procedure} testgetint {
    testgetint 44 -3
} {41}







|
|







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testgetint [llength [info commands testgetint]]
testConstraint testdoubleobj [llength [info commands testdoubleobj]]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
 
test get-1.1 {Tcl_GetInt procedure} testgetint {
    testgetint 44 { 	  22}
} {66}
test get-1.2 {Tcl_GetInt procedure} testgetint {
    testgetint 44 -3
} {41}

Changes to tests/obj.test.

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
...
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit	[expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
    set r 1
    foreach {t} {
	bytearray
	bytecode
	cmdName
................................................................................
    set x {}
    for {set i 0} {$i<100000} {incr i} {
	set x [list $x {}]
    }
    unset x
} {}

test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x 0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x 0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {integer overflow on input} {
    set x 0x100000000; append x 00000000
    list [string is integer $x] [expr { $x }]
} {0 18446744073709551616}
test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0x8000; append x 0001
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
    set x -0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {
    set x -0x100000000; append x 00000000
    list [string is integer $x] [expr { $x }]
} {0 -18446744073709551616}

test obj-34.1 {mp_iseven} testobj {
    set result ""
    lappend result [testbignumobj set 1 0]
    lappend result [testbignumobj iseven 1]    ;
    lappend result [testobj type 1]
} {0 1 int}







<







 







|



|



|


|
|



|



|






|







17
18
19
20
21
22
23

24
25
26
27
28
29
30
...
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit	[expr {int(0x80000000) < 0}]


test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
    set r 1
    foreach {t} {
	bytearray
	bytecode
	cmdName
................................................................................
    set x {}
    for {set i 0} {$i<100000} {incr i} {
	set x [list $x {}]
    }
    unset x
} {}

test obj-33.1 {integer overflow on input} {longIs32bit} {
    set x 0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-33.2 {integer overflow on input} {longIs32bit} {
    set x 0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {no integer overflow on input} {
    set x 0x100000000; append x 00000000
    list [string is integer $x] [expr { $x }]
} {1 18446744073709551616}
test obj-33.4 {integer overflow on input} {longIs32bit} {
    set x -0x8000; append x 0000
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-33.5 {integer overflow on input} {longIs32bit} {
    set x -0x8000; append x 0001
    list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-33.6 {integer overflow on input} {longIs32bit} {
    set x -0xffff; append x ffff
    list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {
    set x -0x100000000; append x 00000000
    list [string is integer $x] [expr { $x }]
} {1 -18446744073709551616}

test obj-34.1 {mp_iseven} testobj {
    set result ""
    lappend result [testbignumobj set 1 0]
    lappend result [testbignumobj iseven 1]    ;
    lappend result [testobj type 1]
} {0 1 int}

Changes to tests/scan.test.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
...
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# procedure that returns the range of integers

proc int_range {} {
    for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} {
	set MIN_INT [expr { $MIN_INT << 1 }]
    }
    set MIN_INT [expr {int($MIN_INT)}]
    set MAX_INT [expr { ~ $MIN_INT }]
    return [list $MIN_INT $MAX_INT]
}

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
................................................................................
} -cleanup {
    unset -nocomplain y
    unset -nocomplain z
} -result {1 {can't set "z": variable is array} abc}

test scan-4.62 {scanning of large and negative octal integers} {
    lassign [int_range] MIN_INT MAX_INT
    set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT]
    list [scan $scanstring {%o %o %o} a b c] \
	[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
test scan-4.63 {scanning of large and negative hex integers} {
    lassign [int_range] MIN_INT MAX_INT
    set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT]
    list [scan $scanstring {%x %x %x} a b c] \
	[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
test scan-4.64 {scanning of hex with %X} {
    scan "123 abc f78" %X%X%X
} {291 2748 3960}

test scan-5.1 {integer scanning} -setup {







|
|
<
<
<







 







|
|




|
|







15
16
17
18
19
20
21
22
23



24
25
26
27
28
29
30
...
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# procedure that returns the range of integers

proc int_range {} {
    set MAX_INT [expr {[format %lu -2]/2}]
    set MIN_INT [expr { ~ $MAX_INT }]



    return [list $MIN_INT $MAX_INT]
}

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
................................................................................
} -cleanup {
    unset -nocomplain y
    unset -nocomplain z
} -result {1 {can't set "z": variable is array} abc}

test scan-4.62 {scanning of large and negative octal integers} {
    lassign [int_range] MIN_INT MAX_INT
    set scanstring [format {%lo %lo %lo} -1 $MIN_INT $MAX_INT]
    list [scan $scanstring {%lo %lo %lo} a b c] \
	[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
test scan-4.63 {scanning of large and negative hex integers} {
    lassign [int_range] MIN_INT MAX_INT
    set scanstring [format {%lx %lx %lx} -1 $MIN_INT $MAX_INT]
    list [scan $scanstring {%lx %lx %lx} a b c] \
	[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
test scan-4.64 {scanning of hex with %X} {
    scan "123 abc f78" %X%X%X
} {291 2748 3960}

test scan-5.1 {integer scanning} -setup {

Changes to tests/string.test.

670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
...
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
} 1
test string-6.53.$noComp {string is integer, true with whitespace} {
    run {string is integer "  \n1234\v"}
} 1
test string-6.54.$noComp {string is integer, false} {
    list [run {string is integer -fail var 123abc}] $var
} {0 3}
test string-6.55.$noComp {string is integer, false on overflow} {
    list [run {string is integer -fail var +[largest_int]0}] $var
} {0 -1}
test string-6.56.$noComp {string is integer, false} {
    list [run {string is integer -fail var [expr double(1)]}] $var
} {0 1}
test string-6.57.$noComp {string is integer, false} {
    list [run {string is integer -fail var "    "}] $var
} {0 0}
test string-6.58.$noComp {string is integer, false on bad octal} {
................................................................................
    set result ""
    set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
    foreach num $numbers {
	lappend result [run {string is double -strict $num}]
    }
    return $result
} {1 1 0 0 0 1 0 0}
test string-6.92.$noComp {string is integer, 64-bit overflow} {
    # Bug 718878
    set x 0x10000000000000000
    list [run {string is integer -failindex var $x}] $var
} {0 -1}
test string-6.93.$noComp {string is integer, 64-bit overflow} {
    # Bug 718878
    set x 0x10000000000000000
    append x ""
    list [run {string is integer -failindex var $x}] $var
} {0 -1}
test string-6.94.$noComp {string is integer, 64-bit overflow} {
    # Bug 718878
    set x 0x10000000000000000
    list [run {string is integer -failindex var [expr {$x}]}] $var
} {0 -1}
test string-6.95.$noComp {string is wideinteger, true} {
    run {string is wideinteger +1234567890}
} 1
test string-6.96.$noComp {string is wideinteger, true on type} {
    run {string is wideinteger [expr wide(50.0)]}
} 1
test string-6.97.$noComp {string is wideinteger, true} {







|
|
|







 







|


|
|
|



|
|
|


|
|







670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
...
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
} 1
test string-6.53.$noComp {string is integer, true with whitespace} {
    run {string is integer "  \n1234\v"}
} 1
test string-6.54.$noComp {string is integer, false} {
    list [run {string is integer -fail var 123abc}] $var
} {0 3}
test string-6.55.$noComp {string is integer, no overflow possible} {
    run {string is integer +[largest_int]0}
} 1
test string-6.56.$noComp {string is integer, false} {
    list [run {string is integer -fail var [expr double(1)]}] $var
} {0 1}
test string-6.57.$noComp {string is integer, false} {
    list [run {string is integer -fail var "    "}] $var
} {0 0}
test string-6.58.$noComp {string is integer, false on bad octal} {
................................................................................
    set result ""
    set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
    foreach num $numbers {
	lappend result [run {string is double -strict $num}]
    }
    return $result
} {1 1 0 0 0 1 0 0}
test string-6.92.$noComp {string is integer, no 64-bit overflow} {
    # Bug 718878
    set x 0x10000000000000000
    run {string is integer $x}
} 1
test string-6.93.$noComp {string is integer, no 64-bit overflow} {
    # Bug 718878
    set x 0x10000000000000000
    append x ""
    run {string is integer $x}
} 1
test string-6.94.$noComp {string is integer, no 64-bit overflow} {
    # Bug 718878
    set x 0x10000000000000000
    run {string is integer [expr {$x}]}
} 1
test string-6.95.$noComp {string is wideinteger, true} {
    run {string is wideinteger +1234567890}
} 1
test string-6.96.$noComp {string is wideinteger, true on type} {
    run {string is wideinteger [expr wide(50.0)]}
} 1
test string-6.97.$noComp {string is wideinteger, true} {