Tcl Source Code

Check-in [c247119234]
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:
[kennykb-numerics-branch]
* generic/tclBasic.c: Re-implemented ExprRoundFunc to use TclGetNumberFromObj.
* generic/tclInt.h: Added new routine TclGetNumberFromObj to * generic/tclObj.c: provide efficient access to the actual internal rep of a numeric Tcl_Obj without conversions.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | kennykb-numerics-branch
Files: files | file ages | folders
SHA1:c247119234520c1c19cba996169a011c7d4f9046
User & Date: dgp 2005-10-03 15:50:18
Context
2005-10-03
18:25
Be more choosy about what doubles get converted to longs. check-in: 9fd8db27ff user: dgp tags: kennykb-numerics-branch
15:50
[kennykb-numerics-branch]
* generic/tclBasic.c: Re-implemented ExprRoundFunc to u...
check-in: c247119234 user: dgp tags: kennykb-numerics-branch
2005-09-30
17:02
[kennykb-numerics-branch]
* generic/tclStringObj.c: Bug fix: Missing cast to ...
check-in: 14a510d9c1 user: dgp tags: kennykb-numerics-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.












1
2
3
4
5
6
7











2005-09-30  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclStringObj.c:	Bug fix: Missing cast to large enough
	integral size before << operations led to broken [format %llx] results.
	Thanks to Robert Henry for reporting the bug.
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
2005-10-03  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclBasic.c:	Re-implemented ExprRoundFunc to use
	TclGetNumberFromObj.

	* generic/tclInt.h:	Added new routine TclGetNumberFromObj to
	* generic/tclObj.c:	provide efficient access to the actual
	internal rep of a numeric Tcl_Obj without conversions.

2005-09-30  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclStringObj.c:	Bug fix: Missing cast to large enough
	integral size before << operations led to broken [format %llx] results.
	Thanks to Robert Henry for reporting the bug.

Changes to generic/tclBasic.c.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
....
5587
5588
5589
5590
5591
5592
5593
5594
5595

5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617

5618
5619
5620
5621
5622
5623



5624
5625





5626



5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641

5642
5643

5644


5645



5646
5647

5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676

5677
5678
5679
5680
5681
5682
5683
5684


5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 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: tclBasic.c,v 1.136.2.35 2005/09/16 19:29:02 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"
................................................................................
ExprRoundFunc(clientData, interp, objc, objv)
    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 */
{
    Tcl_Obj *valuePtr;
    double d, fractPart, intPart;

    mp_int big;
#if 0
    double i, f;
    Tcl_Obj *resPtr;
#endif

    /*
     * Check the argument count.
     */

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

    /*
     * Coerce the argument to a number. Integers are already rounded.
     */

#if 0
    if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {

	return TCL_ERROR;
    }
    if ((valuePtr->typePtr == &tclIntType) ||
	    (valuePtr->typePtr == &tclWideIntType)) {
	Tcl_SetObjResult(interp, valuePtr);
	return TCL_OK;



    }
    GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);









    /*
     * Round the number to the nearest integer. I'd like to use round(), but
     * it's C99 (or BSD), and not yet universal.
     */

    d = valuePtr->internalRep.doubleValue;
    f = modf(d, &i);
    if (d < 0.0) {
	if (f <= -0.5) {
	    i += -1.0;
	}
	if (i <= Tcl_WideAsDouble(LLONG_MIN)) {
	    goto tooLarge;
	} else if (d <= (double) LONG_MIN) {
	    resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));

	} else {
	    resPtr = Tcl_NewLongObj((long) i);

	}


    } else {



	if (f >= 0.5) {
	    i += 1.0;

	}
	if (i >= Tcl_WideAsDouble(LLONG_MAX)) {
	    goto tooLarge;
	} else if (i >= (double) LONG_MAX) {
	    resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
	} else {
	    resPtr = Tcl_NewLongObj((long) i);
	}
    }
    Tcl_SetObjResult(interp, resPtr);
    return TCL_OK;

    /*
     * Error return: result cannot be represented as an integer.
     */

  tooLarge:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "integer value too large to represent", -1));
    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
	    "integer value too large to represent", (char *) NULL);

    return TCL_ERROR;
#else
    if (Tcl_GetDoubleFromObj(interp, valuePtr, &d) != TCL_OK) {
	/* Non-numeric */
	return TCL_ERROR;
    }
    if (Tcl_GetBignumFromObj(NULL, valuePtr, &big) == TCL_OK) {

	/* Integers are already rounded */
	mp_clear(&big);
	Tcl_SetObjResult(interp, valuePtr);
	return TCL_OK;
    }
    fractPart = modf(d, &intPart);
    if (fractPart == 0.0) {
	if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) {


	    return TCL_ERROR;
	}
    } else {
	if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (fractPart < 0.0) {
	    if (fractPart <= -0.5) {
		mp_sub_d(&big, 1, &big);
	    }
	} else if (fractPart >= 0.5) {
	    mp_add_d(&big, 1, &big);
	}
    }
    Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
    return TCL_OK;
#endif
}

static int
ExprSrandFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */







|







 







<
|
>
|
<
<
<
<
<
<
<
<





<

<
<
<
<
<
<
>


<
<
<
<
>
>
>
|
<
>
>
>
>
>
|
>
>
>
|
|
<
<
|
<
<
<
|
<
<
<
<
<
<
>
|
<
>
|
>
>
|
>
>
>
|
<
>
|
<
<
<
<
<
<
<
<
|
|
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
>
|
<
|


<
<
<
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
....
5587
5588
5589
5590
5591
5592
5593

5594
5595
5596








5597
5598
5599
5600
5601

5602






5603
5604
5605




5606
5607
5608
5609

5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620


5621



5622






5623
5624

5625
5626
5627
5628
5629
5630
5631
5632
5633

5634
5635








5636
5637
5638



5639













5640
5641

5642
5643
5644



5645
5646
5647
















5648
5649
5650
5651
5652
5653
5654
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 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: tclBasic.c,v 1.136.2.36 2005/10/03 15:50:19 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
#include "tommath.h"
................................................................................
ExprRoundFunc(clientData, interp, objc, objv)
    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 */
{

    double d;
    ClientData ptr;
    int type;









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








    if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
	return TCL_ERROR;
    }




    if (type == TCL_NUMBER_DOUBLE) {
	double fractPart, intPart;
	long max = LONG_MAX, min = LONG_MIN;


	fractPart = modf(*((CONST double *)ptr), &intPart);
	if (fractPart <= -0.5) {
	    min++;
	} else if (fractPart >= 0.5) {
	    max--;
	}
	if ((intPart > (double)max) || (intPart < (double)min)) {
	    mp_int big;
	    if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
		/* Infinity */
		return TCL_ERROR;


	    }



	    if (fractPart <= -0.5) {






		mp_sub_d(&big, 1, &big);
	    } else if (fractPart >= 0.5) {

		mp_add_d(&big, 1, &big);
	    }
	    Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
	    return TCL_OK;
	} else {
	    long result = (long)intPart;
	    if (fractPart <= -0.5) {
		result--;
	    } else if (fractPart >= 0.5) {

		result++;
	    }








	    Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
	    return TCL_OK;
	}



    }













    if (type != TCL_NUMBER_NAN) {
	/* All integers are already rounded */

	Tcl_SetObjResult(interp, objv[1]);
	return TCL_OK;
    }



    /* Get the error message for NaN */
    Tcl_GetDoubleFromObj(interp, objv[1], &d);
    return TCL_ERROR;
















}

static int
ExprSrandFunc(clientData, interp, objc, objv)
    ClientData clientData;	/* Ignored. */
    Tcl_Interp *interp;		/* The interpreter in which to execute the
				 * function. */

Changes to generic/tclInt.h.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1900
1901
1902
1903
1904
1905
1906












1907
1908
1909
1910
1911
1912
1913
....
2045
2046
2047
2048
2049
2050
2051



2052
2053
2054
2055
2056
2057
2058
 * 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.40 2005/09/16 19:29:02 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
#define TCL_PARSE_HEXADECIMAL_ONLY	4
				/* Parse hexadecimal even without prefix */
#define TCL_PARSE_INTEGER_ONLY		8
				/* Disable floating point parsing */
#define TCL_PARSE_SCAN_PREFIXES		16
				/* Use [scan] rules dealing with 0? prefixes */













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

MODULE_SCOPE char *	tclNativeExecutableName;
................................................................................
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetEncodingFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE int	TclGetNamespaceFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);



MODULE_SCOPE int	TclGetOpenModeEx(Tcl_Interp *interp,
			    CONST char *modeString, int *seekFlagPtr,
			    int *binaryPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData* types);







|







 







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







 







>
>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
....
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
 * 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.41 2005/10/03 15:50:19 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
#define TCL_PARSE_HEXADECIMAL_ONLY	4
				/* Parse hexadecimal even without prefix */
#define TCL_PARSE_INTEGER_ONLY		8
				/* Disable floating point parsing */
#define TCL_PARSE_SCAN_PREFIXES		16
				/* Use [scan] rules dealing with 0? prefixes */

/*
 *----------------------------------------------------------------------
 * Type values TclGetNumberFromObj
 *----------------------------------------------------------------------
 */

#define TCL_NUMBER_LONG		1
#define TCL_NUMBER_WIDE		2
#define TCL_NUMBER_BIG		3
#define TCL_NUMBER_DOUBLE	4
#define TCL_NUMBER_NAN		5

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

MODULE_SCOPE char *	tclNativeExecutableName;
................................................................................
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    CONST char *attributeName, int *indexPtr);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetEncodingFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE int	TclGetNamespaceFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
MODULE_SCOPE int	TclGetNumberFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, ClientData *clientDataPtr,
			    int *typePtr);
MODULE_SCOPE int	TclGetOpenModeEx(Tcl_Interp *interp,
			    CONST char *modeString, int *seekFlagPtr,
			    int *binaryPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE int	TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *unquotedPrefix, int globFlags,
			    Tcl_GlobTypeData* types);

Changes to generic/tclObj.c.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
2928
2929
2930
2931
2932
2933
2934





















































2935
2936
2937
2938
2939
2940
2941
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.
 * 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: tclObj.c,v 1.72.2.39 2005/09/27 18:42:54 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"
#include <float.h>

#define BIGNUM_AUTO_NARROW 1
................................................................................
     * we just packed into the Tcl_Obj.
     */

    bignumValue->dp = NULL;
    bignumValue->alloc = bignumValue->used = 0;
    bignumValue->sign = MP_NEG;
}





















































 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbIncrRefCount --
 *
 *	This procedure is normally called when debugging: i.e., when







|







 







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







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.
 * 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: tclObj.c,v 1.72.2.40 2005/10/03 15:50:19 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"
#include <float.h>

#define BIGNUM_AUTO_NARROW 1
................................................................................
     * we just packed into the Tcl_Obj.
     */

    bignumValue->dp = NULL;
    bignumValue->alloc = bignumValue->used = 0;
    bignumValue->sign = MP_NEG;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetNumberFromObj --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

int TclGetNumberFromObj(interp, objPtr, clientDataPtr, typePtr)
    Tcl_Interp *interp;
    Tcl_Obj *objPtr;
    ClientData *clientDataPtr;
    int *typePtr;
{
    do {
	if (objPtr->typePtr == &tclDoubleType) {
	    if (TclIsNaN(objPtr->internalRep.doubleValue)) {
		*typePtr = TCL_NUMBER_NAN;
	    } else {
		*typePtr = TCL_NUMBER_DOUBLE;
	    }
	    *clientDataPtr = &(objPtr->internalRep.doubleValue);
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclIntType) {
	    *typePtr = TCL_NUMBER_LONG;
	    *clientDataPtr = &(objPtr->internalRep.longValue);
	    return TCL_OK;
	}
	if (objPtr->typePtr == &tclBignumType) {
	    static Tcl_ThreadDataKey bignumKey;
	    mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int)sizeof(mp_int));
	    UNPACK_BIGNUM( objPtr, *bigPtr );
	    *typePtr = TCL_NUMBER_BIG;
	    *clientDataPtr = bigPtr;
	    return TCL_OK;
	}
#ifndef NO_WIDE_TYPE
	if (objPtr->typePtr == &tclWideIntType) {
	    *typePtr = TCL_NUMBER_WIDE;
	    *clientDataPtr = &(objPtr->internalRep.wideValue);
	    return TCL_OK;
	}
#endif
    } while (TCL_OK ==
	    TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DbIncrRefCount --
 *
 *	This procedure is normally called when debugging: i.e., when