Tcl Source Code

Check-in [7ebb863e96]
Login

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

Overview
Comment:improved reange checking (also for the Tcl 9.0 proposal). Make platform test platform 32/64-bit independant
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-514
Files: files | file ages | folders
SHA3-256:7ebb863e9688b80428ca3672ab3c05b983208058e80e0a7db3035a3fad0217b8
User & Date: jan.nijtmans 2018-08-21 21:36:03
Context
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
2018-08-19
09:33
Re-base branch "all-wideint" to core-8-branch. Still WIP check-in: 4932848e36 user: jan.nijtmans tags: tip-514
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclBasic.c.

112
113
114
115
116
117
118

119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
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	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	ExprIntFunc;
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)







>








<







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

128
129
130
131
132
133
134
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)

Changes to generic/tclInt.h.

2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
    (((objPtr)->typePtr == &tclIntType)	\
	    ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#else
#define TclGetLongFromObj(interp, objPtr, longPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(ULONG_MAX))	\
	    ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#endif

#define TclGetIntFromObj(interp, objPtr, intPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(UINT_MAX))	\
	    ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    && (objPtr)->internalRep.wideValue >= INT_MIN \
	    && (objPtr)->internalRep.wideValue <= INT_MAX)	\
	    ? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \







|







|







2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
    (((objPtr)->typePtr == &tclIntType)	\
	    ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#else
#define TclGetLongFromObj(interp, objPtr, longPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX))	\
	    ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#endif

#define TclGetIntFromObj(interp, objPtr, intPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
	    && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX))	\
	    ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
	    : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
    (((objPtr)->typePtr == &tclIntType \
	    && (objPtr)->internalRep.wideValue >= INT_MIN \
	    && (objPtr)->internalRep.wideValue <= INT_MAX)	\
	    ? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \

Changes to generic/tclObj.c.

2512
2513
2514
2515
2516
2517
2518






2519

2520
2521
2522
2523
2524
2525
2526
....
2801
2802
2803
2804
2805
2806
2807
2808

2809




2810
2811
2812
2813
2814
2815
2816
....
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845







2846
2847
2848
2849
2850
2851

2852
2853
2854
2855
2856
2857
2858
    return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
#else
    long l;

    if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
	return TCL_ERROR;
    }






    if ((ULONG_MAX > UINT_MAX) && ((l > (long)(UINT_MAX)) || (l < (long)(INT_MIN)))) {

	if (interp != NULL) {
	    const char *s =
		    "integer value too large to represent as non-long integer";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	}
	return TCL_ERROR;
................................................................................
	     * existing semantics for conversion of integers on input, but
	     * avoids inadvertent demotion of wide integers to 32-bit ones in
	     * the internal rep.
	     */

	    Tcl_WideInt w = objPtr->internalRep.wideValue;

	    if (w >= (Tcl_WideInt)(LONG_MIN)

		    && w <= (Tcl_WideInt)(ULONG_MAX)) {




		*longPtr = Tcl_WideAsLong(w);
		return TCL_OK;
	    }
	    goto tooLarge;
	}
#endif
	if (objPtr->typePtr == &tclDoubleType) {
................................................................................
	     * long range get auto-narrowed to tclIntType, while all the
	     * values in the unsigned long range will fit in a long.
	     */

	    mp_int big;

	    UNPACK_BIGNUM(objPtr, big);
	    if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
		    / DIGIT_BIT) {
		unsigned long value = 0, numBytes = sizeof(long);
		long scratch;
		unsigned char *bytes = (unsigned char *) &scratch;

		if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
		    while (numBytes-- > 0) {
			value = (value << CHAR_BIT) | *bytes++;
		    }







		    if (big.sign) {
			*longPtr = - (long) value;
		    } else {
			*longPtr = (long) value;
		    }
		    return TCL_OK;

		}
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	tooLarge:
#endif
	    if (interp != NULL) {
		const char *s = "integer value too large to represent";







>
>
>
>
>
>
|
>







 







|
>
|
>
>
>
>







 







|

|
<






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







2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
....
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
....
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850

2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
    return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
#else
    long l;

    if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
	return TCL_ERROR;
    }
    if (
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
	    (l > (long)(UINT_MAX))
#else
	    (l > (long)(INT_MAX))
#endif
	    || (l < (long)(INT_MIN))
	) {
	if (interp != NULL) {
	    const char *s =
		    "integer value too large to represent as non-long integer";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
	    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
	}
	return TCL_ERROR;
................................................................................
	     * existing semantics for conversion of integers on input, but
	     * avoids inadvertent demotion of wide integers to 32-bit ones in
	     * the internal rep.
	     */

	    Tcl_WideInt w = objPtr->internalRep.wideValue;

	    if (
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
		    w <= (Tcl_WideInt)(ULONG_MAX)) {
#else
		    w <= (Tcl_WideInt)(LONG_MAX)) {
#endif
		    && w >= (Tcl_WideInt)(LONG_MIN)
		*longPtr = Tcl_WideAsLong(w);
		return TCL_OK;
	    }
	    goto tooLarge;
	}
#endif
	if (objPtr->typePtr == &tclDoubleType) {
................................................................................
	     * long range get auto-narrowed to tclIntType, while all the
	     * values in the unsigned long range will fit in a long.
	     */

	    mp_int big;

	    UNPACK_BIGNUM(objPtr, big);
	    if ((size_t) big.used <= (CHAR_BIT * sizeof(unsigned long) + DIGIT_BIT - 1)
		    / DIGIT_BIT) {
		unsigned long scratch, value = 0, numBytes = sizeof(unsigned long);

		unsigned char *bytes = (unsigned char *) &scratch;

		if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
		    while (numBytes-- > 0) {
			value = (value << CHAR_BIT) | *bytes++;
		    }
		    if (
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 8
			    big.sign ? (value <= 1 + (unsigned long)LONG_MAX) : (value <= (unsigned long)ULONG_MAX)
#else
			    big.sign ? (value <= 1 + (unsigned long)LONG_MAX) : (value <= (unsigned long)LONG_MAX)
#endif
		    ) {
			if (big.sign) {
			    *longPtr = - (long) value;
			} else {
			    *longPtr = (long) value;
			    }
			return TCL_OK;
		    }
		}
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	tooLarge:
#endif
	    if (interp != NULL) {
		const char *s = "integer value too large to represent";

Changes to generic/tclTest.c.

288
289
290
291
292
293
294


295
296
297
298
299
300
301
...
640
641
642
643
644
645
646


647
648
649
650
651
652
653
....
6931
6932
6933
6934
6935
6936
6937


















6938
6939
6940
6941
6942
6943
6944
static int		TestfilelinkCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int		TestfeventCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestgetassocdataCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestgetintCmd(ClientData dummy,


			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestgetplatformCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestgetvarfullnameCmd(
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		TestinterpdeleteCmd(ClientData dummy,
................................................................................
    Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testhashsystemhash",
	    TestHashSystemHashCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,


	    NULL, NULL);
    Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testgetvarfullname",
	    TestgetvarfullnameCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
	    NULL, NULL);
................................................................................
	    }
	    total += val;
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(total));
	return TCL_OK;
    }
}


















 
static int
NREUnwind_callback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{







>
>







 







>
>







 







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







288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
...
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
....
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
static int		TestfilelinkCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int		TestfeventCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestgetassocdataCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestgetintCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestlongsizeCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestgetplatformCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestgetvarfullnameCmd(
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		TestinterpdeleteCmd(ClientData dummy,
................................................................................
    Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testhashsystemhash",
	    TestHashSystemHashCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testgetvarfullname",
	    TestgetvarfullnameCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
	    NULL, NULL);
................................................................................
	    }
	    total += val;
	}
	Tcl_SetObjResult(interp, Tcl_NewIntObj(total));
	return TCL_OK;
    }
}
 
/*
 * Used for determining sizeof(long) at script level.
 */
static int
TestlongsizeCmd(
    ClientData dummy,
    Tcl_Interp *interp,
    int argc,
    const char **argv)
{
    if (argc != 1) {
	Tcl_AppendResult(interp, "wrong # args", NULL);
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewIntObj((int)sizeof(long)));
    return TCL_OK;
}
 
static int
NREUnwind_callback(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{

Changes to tests/platform.test.

21
22
23
24
25
26
27

28
29
30
31
32
33
34
..
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
    #variable ::tcl_platform
    namespace upvar :: tcl_platform tcl_platform

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

testConstraint testCPUID [llength [info commands testcpuid]]


test platform-1.0 {tcl_platform(engine)} {
  set tcl_platform(engine)
} {Tcl}

test platform-1.1 {TclpSetVariables: tcl_platform} {
    interp create i
................................................................................
    i eval {catch {unset tcl_platform(debug)}}
    i eval {catch {unset tcl_platform(threaded)}}
    set result [i eval {lsort [array names tcl_platform]}]
    interp delete i
    set result
} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}

# Test assumes twos-complement arithmetic, which is true of virtually
# everything these days.  Note that this does *not* use wide(), and
# this is intentional since that could make Tcl's numbers wider than
# the machine-integer on some platforms...
test platform-2.1 {tcl_platform(wordSize) indicates size of native word} nonPortable {
    set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}]
    # Result must be the largest bit in a machine word, which this checks
    # without assuming how wide the word really is
    list [expr {$result < 0}] [expr {$result ^ int($result - 1)}]
} {1 -1}

# On Windows/UNIX, test that the CPU ID works

test platform-3.1 {CPU ID on Windows/UNIX} \
    -constraints testCPUID \
    -body {
	set cpudata [testcpuid 0]







>







 







<
<
<
<
|
|
<
<
<
|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
..
36
37
38
39
40
41
42




43
44



45
46
47
48
49
50
51
52
    #variable ::tcl_platform
    namespace upvar :: tcl_platform tcl_platform

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

testConstraint testCPUID [llength [info commands testcpuid]]
testConstraint testlongsize [llength [info commands testlongsize]]

test platform-1.0 {tcl_platform(engine)} {
  set tcl_platform(engine)
} {Tcl}

test platform-1.1 {TclpSetVariables: tcl_platform} {
    interp create i
................................................................................
    i eval {catch {unset tcl_platform(debug)}}
    i eval {catch {unset tcl_platform(threaded)}}
    set result [i eval {lsort [array names tcl_platform]}]
    interp delete i
    set result
} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}





test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize {
    expr {$tcl_platform(wordSize) == [testlongsize]}



} {1}

# On Windows/UNIX, test that the CPU ID works

test platform-3.1 {CPU ID on Windows/UNIX} \
    -constraints testCPUID \
    -body {
	set cpudata [testcpuid 0]