Tcl Source Code

Check-in [53add32158]
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/tclExecute.c: Updated TclIncrObj() to more efficiently add native long integers. Also updated IllegalExprOperandType and the INST_UMINUS and INST_BITNOT sections for performance.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | kennykb-numerics-branch
Files: files | file ages | folders
SHA1:53add32158bf66fbb5ca825d4a543c1abd1d338b
User & Date: dgp 2005-10-04 18:33:54
Context
2005-10-04
21:02
[kennykb-numerics-branch]
* generic/tclExecute.c: Updated TclIncrObj() to more effi...
check-in: 8d4c5bb62b user: dgp tags: kennykb-numerics-branch
18:33
[kennykb-numerics-branch]
* generic/tclExecute.c: Updated TclIncrObj() to more effi...
check-in: 53add32158 user: dgp tags: kennykb-numerics-branch
16:00
[kennykb-numerics-branch]
* generic/tclExecute.c: Updated TclIncrObj() to more effi...
check-in: 0f923b5cc0 user: dgp tags: kennykb-numerics-branch
Changes
Hide Diffs Unified Diffs Show Whitespace Changes Patch

Changes to ChangeLog.

1
2
3
4
5
6

7
8
9
10
11
12
13
2005-10-04  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Updated TclIncrObj() to more efficiently
	add native long integers.


	* generic/tclBasic.c:	Updated more callers to make use of
	TclGetNumberFromObj.  Removed some dead code.

2005-10-03  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]





|
>







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

	[kennykb-numerics-branch]

	* generic/tclExecute.c:	Updated TclIncrObj() to more efficiently
	add native long integers.  Also updated IllegalExprOperandType
	and the INST_UMINUS and INST_BITNOT sections for performance.

	* generic/tclBasic.c:	Updated more callers to make use of
	TclGetNumberFromObj.  Removed some dead code.

2005-10-03  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

Changes to generic/tclExecute.c.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
....
5117
5118
5119
5120
5121
5122
5123



5124

5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140





5141
5142






























5143
5144
5145
5146

5147
5148




5149



5150
5151
5152
5153

5154
5155

























5156
5157
5158
5159
5160
5161
5162
5163
5164


5165
5166
5167
5168
5169
5170
5171



5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
....
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583

6584

6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610







6611
6612
6613
6614



6615
6616
6617
6618
6619
6620
6621
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002-2005 by Miguel Sofer.
 * Copyright (c) 2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167.2.43 2005/10/04 16:00:13 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"

#include <math.h>
................................................................................
	    goto checkForCatch;
	}
	/* TODO: Consider peephole opt. */
	objResultPtr = eePtr->constants[!b];
	NEXT_INST_F(1, 1, 1);
    }

    case INST_BITNOT:
    case INST_UMINUS: {
	/*
	 * The operand must be numeric.  If the operand object is unshared
	 * modify it directly, otherwise create a copy to modify: this is
	 * "copy on write".  
	 */

	double d;
	Tcl_Obj *valuePtr;

#if 0
	long i;
	int negate_value = 1;
	Tcl_WideInt w;
	Tcl_ObjType *tPtr;

	valuePtr = *tosPtr;
................................................................................
	} else {
	    d = valuePtr->internalRep.doubleValue;
	    TclSetDoubleObj(valuePtr, -d);
	    TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
	}
	NEXT_INST_F(1, 0, 0);
#else



	valuePtr = *tosPtr;

	result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
	if ((result == TCL_OK) 
#ifdef ACCEPT_NAN
		|| valuePtr->typePtr == &tclDoubleType
#endif
		) {
	    /* Value is now numeric (including NaN) */
#ifdef ACCEPT_NAN
	    if (result != TCL_OK) {
	        /* Value is NaN */
		if (*pc == INST_BITNOT) {
		    /* ~NaN => error; arg must be an integer */
		    goto error;
		}
		/* -NaN => NaN */
		result = TCL_OK;





		NEXT_INST_F(1, 0, 0);
	    }






























#endif
	    if (valuePtr->typePtr == &tclDoubleType) {
		if (*pc == INST_BITNOT) {
		    /* ~ arg must be an integer */

		    result = TCL_ERROR;
		    goto error;




		}



		if (Tcl_IsShared(valuePtr)) {
		    TclNewDoubleObj(objResultPtr, -d);
		    NEXT_INST_F(1, 1, 1);
		}

		TclSetDoubleObj(valuePtr, -d);
		NEXT_INST_F(1, 0, 0);

























	    } else {
		/* TODO: optimize use of narrower native integers */
		mp_int big;
		Tcl_GetBignumFromObj(NULL, valuePtr, &big);
		mp_neg(&big, &big);
		if (*pc == INST_BITNOT) {
		    /* ~a = - a - 1 */
		    mp_sub_d(&big, 1, &big);
		}


		if (Tcl_IsShared(valuePtr)) {
		    objResultPtr = Tcl_NewBignumObj(&big);
		    NEXT_INST_F(1, 1, 1);
		}
		Tcl_SetBignumObj(valuePtr, &big);
		NEXT_INST_F(1, 0, 0);
	    }



	}
	/* ... -$NonNumeric => raise an error */
    error:
	TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
	IllegalExprOperandType(interp, pc, valuePtr);
	goto checkForCatch;
#endif
    }

#if 0
    case INST_BITNOT: {
	/*
	 * The operand must be an integer. If the operand object is unshared
................................................................................
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    unsigned char *pc;		/* Points to the instruction being executed
				 * when the illegal type was found. */
    Tcl_Obj *opndPtr;		/* Points to the operand holding the value
				 * with the illegal type. */
{
    Tcl_Obj *msg = Tcl_NewStringObj("can't use ", -1);
    double d;
    int isNumeric;
    unsigned char opCode = *pc;

    CONST char *operator = operatorStrings[opCode - INST_LOR];

    if (opCode == INST_EXPON) {
	operator = "**";
    }

    /* TODO: Consider alternative that need not write to d */
    isNumeric = (Tcl_GetDoubleFromObj(NULL, opndPtr, &d) == TCL_OK);

    if (opndPtr->typePtr == &tclDoubleType) {
	if (!isNumeric) {
	    Tcl_AppendToObj(msg, "non-numeric ", -1);
	}
	Tcl_AppendToObj(msg, "floating-point value", -1);
    } else if (isNumeric) {
	/* TODO: check callers, might be able to eliminate this */
	Tcl_AppendToObj(msg, "(big) integer", -1);
    } else {
        /* TODO: When to post "integer value too large to represent" ? */
	int numBytes;
	CONST char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
	if (numBytes == 0) {
	    Tcl_AppendToObj(msg, "empty string", -1);
	} else if (TclCheckBadOctal(NULL, bytes)) {
	    Tcl_AppendToObj(msg, "invalid octal number", -1);
	} else {
	    Tcl_AppendToObj(msg, "non-numeric string", -1);
	}







    }
    Tcl_AppendToObj(msg, " as operand of \"", -1);
    Tcl_AppendToObj(msg, operator, -1);
    Tcl_AppendToObj(msg, "\"", -1);



    Tcl_SetObjResult(interp, msg);
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetSrcInfoForPc --







|







 







|
<
<
<
<
<
<
<
<
<
<







 







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

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

>
>







>
>
>

<
<
<
<
<
<







 







|
<
|
|
>
|
>
|



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



|

|

|

>
>
>
>
>
>
>

<
<
<
>
>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
5014
5015
5016
5017
5018
5019
5020
5021










5022
5023
5024
5025
5026
5027
5028
....
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120




5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168



5169
5170

5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211


5212




5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226






5227
5228
5229
5230
5231
5232
5233
....
6621
6622
6623
6624
6625
6626
6627
6628

6629
6630
6631
6632
6633
6634
6635
6636
6637

6638











6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655



6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002-2005 by Miguel Sofer.
 * Copyright (c) 2005 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.167.2.44 2005/10/04 18:33:54 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tommath.h"

#include <math.h>
................................................................................
	    goto checkForCatch;
	}
	/* TODO: Consider peephole opt. */
	objResultPtr = eePtr->constants[!b];
	NEXT_INST_F(1, 1, 1);
    }

    case INST_BITNOT: {










#if 0
	long i;
	int negate_value = 1;
	Tcl_WideInt w;
	Tcl_ObjType *tPtr;

	valuePtr = *tosPtr;
................................................................................
	} else {
	    d = valuePtr->internalRep.doubleValue;
	    TclSetDoubleObj(valuePtr, -d);
	    TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
	}
	NEXT_INST_F(1, 0, 0);
#else
	mp_int big;
	ClientData ptr;
	int type;
	Tcl_Obj *valuePtr = *tosPtr;

	result = TclGetNumberFromObj(NULL, valuePtr, &ptr, &type);
	if ((result != TCL_OK)




		|| (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {
	    /* ... ~$NonInteger => raise an error */
	    result = TCL_ERROR;
	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}
	if (type == TCL_NUMBER_LONG) {
	    long l = *((CONST long *)ptr);
	    if (Tcl_IsShared(valuePtr)) {
		TclNewLongObj(objResultPtr, ~l);
		NEXT_INST_F(1, 1, 1);
	    }
	    TclSetLongObj(valuePtr, ~l);
	    NEXT_INST_F(1, 0, 0);
	}
	if (type == TCL_NUMBER_WIDE) {
	    TclBNInitBignumFromWideInt(&big, *((CONST Tcl_WideInt*)ptr));
	} else {
	    if (Tcl_IsShared(valuePtr)) {
		Tcl_GetBignumFromObj(NULL, valuePtr, &big);
	    } else {
		Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);
	    }
	}
	/* ~a = - a - 1 */
	mp_neg(&big, &big);
	mp_sub_d(&big, 1, &big);
	if (Tcl_IsShared(valuePtr)) {
	    objResultPtr = Tcl_NewBignumObj(&big);
	    NEXT_INST_F(1, 1, 1);
	}
	Tcl_SetBignumObj(valuePtr, &big);
	NEXT_INST_F(1, 0, 0);
    }

    case INST_UMINUS: {
	mp_int big;
	ClientData ptr;
	int type;
	Tcl_Obj *valuePtr = *tosPtr;

	result = TclGetNumberFromObj(NULL, valuePtr, &ptr, &type);
	if ((result != TCL_OK)
#ifndef ACCEPT_NAN
		|| (type == TCL_NUMBER_NAN)
#endif



		) {
	    result = TCL_ERROR;

	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
	    IllegalExprOperandType(interp, pc, valuePtr);
	    goto checkForCatch;
	}
	switch (type) {
	case TCL_NUMBER_DOUBLE: {
	    double d;
	    if (Tcl_IsShared(valuePtr)) {
		TclNewDoubleObj(objResultPtr, -(*((CONST double *)ptr)));
		NEXT_INST_F(1, 1, 1);
	    }
	    d = *((CONST double *)ptr);
	    TclSetDoubleObj(valuePtr, -d);
	    NEXT_INST_F(1, 0, 0);
	}
	case TCL_NUMBER_LONG: {
	    long l = *((CONST long *)ptr);
	    if (l != LONG_MIN) {
		if (Tcl_IsShared(valuePtr)) {
		    TclNewLongObj(objResultPtr, -l);
		    NEXT_INST_F(1, 1, 1);
		}
		TclSetLongObj(valuePtr, -l);
		NEXT_INST_F(1, 0, 0);
	    }
	    /* FALLTHROUGH */
	}
	case TCL_NUMBER_WIDE:
	case TCL_NUMBER_BIG: {
	    switch (type) {
	    case TCL_NUMBER_LONG:
		TclBNInitBignumFromLong(&big, *((CONST long *)ptr));
		break;
	    case TCL_NUMBER_WIDE:
		TclBNInitBignumFromWideInt(&big, *((CONST Tcl_WideInt*)ptr));
		break;
	    case TCL_NUMBER_BIG:
		if (Tcl_IsShared(valuePtr)) {
		    Tcl_GetBignumFromObj(NULL, valuePtr, &big);
		} else {


		    Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);




		}
	    }
	    mp_neg(&big, &big);
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewBignumObj(&big);
		NEXT_INST_F(1, 1, 1);
	    }
	    Tcl_SetBignumObj(valuePtr, &big);
	    NEXT_INST_F(1, 0, 0);
	}
	case TCL_NUMBER_NAN:
	    /* -NaN => NaN */
	    NEXT_INST_F(1, 0, 0);
	}






#endif
    }

#if 0
    case INST_BITNOT: {
	/*
	 * The operand must be an integer. If the operand object is unshared
................................................................................
    Tcl_Interp *interp;		/* Interpreter to which error information
				 * pertains. */
    unsigned char *pc;		/* Points to the instruction being executed
				 * when the illegal type was found. */
    Tcl_Obj *opndPtr;		/* Points to the operand holding the value
				 * with the illegal type. */
{
    ClientData ptr;

    int type;
    unsigned char opcode = *pc;
    CONST char *description, *operator = operatorStrings[opcode - INST_LOR];
    Tcl_Obj *msg = Tcl_NewObj();

    if (opcode == INST_EXPON) {
	operator = "**";
    }


    if (TclGetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {











	int numBytes;
	CONST char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
	if (numBytes == 0) {
	    description = "empty string";
	} else if (TclCheckBadOctal(NULL, bytes)) {
	    description = "invalid octal number";
	} else {
	    description = "non-numeric string";
	}
    } else if (type == TCL_NUMBER_NAN) {
	description = "non-numeric floating-point value";
    } else if (type == TCL_NUMBER_DOUBLE) {
	description = "floating-point value";
    } else {
	/* TODO: No caller needs this.  Eliminate? */
	description = "(big) integer";
    }




    TclObjPrintf(NULL, msg, "can't use %s as operand of \"%s\"",
	    description, operator);
    Tcl_SetObjResult(interp, msg);
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetSrcInfoForPc --