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 Side-by-Side Diffs Ignore Whitespace Patch

Changes to ChangeLog.

     1      1   2005-10-04  Don Porter  <dgp@users.sourceforge.net>
     2      2   
     3      3   	[kennykb-numerics-branch]
     4      4   
     5      5   	* generic/tclExecute.c:	Updated TclIncrObj() to more efficiently
     6         -	add native long integers.
            6  +	add native long integers.  Also updated IllegalExprOperandType
            7  +	and the INST_UMINUS and INST_BITNOT sections for performance.
     7      8   
     8      9   	* generic/tclBasic.c:	Updated more callers to make use of
     9     10   	TclGetNumberFromObj.  Removed some dead code.
    10     11   
    11     12   2005-10-03  Don Porter  <dgp@users.sourceforge.net>
    12     13   
    13     14   	[kennykb-numerics-branch]

Changes to generic/tclExecute.c.

     8      8    * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
     9      9    * Copyright (c) 2002-2005 by Miguel Sofer.
    10     10    * Copyright (c) 2005 by Donal K. Fellows.
    11     11    *
    12     12    * See the file "license.terms" for information on usage and redistribution of
    13     13    * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    14     14    *
    15         - * RCS: @(#) $Id: tclExecute.c,v 1.167.2.43 2005/10/04 16:00:13 dgp Exp $
           15  + * RCS: @(#) $Id: tclExecute.c,v 1.167.2.44 2005/10/04 18:33:54 dgp Exp $
    16     16    */
    17     17   
    18     18   #include "tclInt.h"
    19     19   #include "tclCompile.h"
    20     20   #include "tommath.h"
    21     21   
    22     22   #include <math.h>
................................................................................
  5014   5014   	    goto checkForCatch;
  5015   5015   	}
  5016   5016   	/* TODO: Consider peephole opt. */
  5017   5017   	objResultPtr = eePtr->constants[!b];
  5018   5018   	NEXT_INST_F(1, 1, 1);
  5019   5019       }
  5020   5020   
  5021         -    case INST_BITNOT:
  5022         -    case INST_UMINUS: {
  5023         -	/*
  5024         -	 * The operand must be numeric.  If the operand object is unshared
  5025         -	 * modify it directly, otherwise create a copy to modify: this is
  5026         -	 * "copy on write".  
  5027         -	 */
  5028         -
  5029         -	double d;
  5030         -	Tcl_Obj *valuePtr;
  5031         -
         5021  +    case INST_BITNOT: {
  5032   5022   #if 0
  5033   5023   	long i;
  5034   5024   	int negate_value = 1;
  5035   5025   	Tcl_WideInt w;
  5036   5026   	Tcl_ObjType *tPtr;
  5037   5027   
  5038   5028   	valuePtr = *tosPtr;
................................................................................
  5117   5107   	} else {
  5118   5108   	    d = valuePtr->internalRep.doubleValue;
  5119   5109   	    TclSetDoubleObj(valuePtr, -d);
  5120   5110   	    TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
  5121   5111   	}
  5122   5112   	NEXT_INST_F(1, 0, 0);
  5123   5113   #else
  5124         -	valuePtr = *tosPtr;
  5125         -	result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
  5126         -	if ((result == TCL_OK) 
  5127         -#ifdef ACCEPT_NAN
  5128         -		|| valuePtr->typePtr == &tclDoubleType
         5114  +	mp_int big;
         5115  +	ClientData ptr;
         5116  +	int type;
         5117  +	Tcl_Obj *valuePtr = *tosPtr;
         5118  +
         5119  +	result = TclGetNumberFromObj(NULL, valuePtr, &ptr, &type);
         5120  +	if ((result != TCL_OK)
         5121  +		|| (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {
         5122  +	    /* ... ~$NonInteger => raise an error */
         5123  +	    result = TCL_ERROR;
         5124  +	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
         5125  +		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
         5126  +	    IllegalExprOperandType(interp, pc, valuePtr);
         5127  +	    goto checkForCatch;
         5128  +	}
         5129  +	if (type == TCL_NUMBER_LONG) {
         5130  +	    long l = *((CONST long *)ptr);
         5131  +	    if (Tcl_IsShared(valuePtr)) {
         5132  +		TclNewLongObj(objResultPtr, ~l);
         5133  +		NEXT_INST_F(1, 1, 1);
         5134  +	    }
         5135  +	    TclSetLongObj(valuePtr, ~l);
         5136  +	    NEXT_INST_F(1, 0, 0);
         5137  +	}
         5138  +	if (type == TCL_NUMBER_WIDE) {
         5139  +	    TclBNInitBignumFromWideInt(&big, *((CONST Tcl_WideInt*)ptr));
         5140  +	} else {
         5141  +	    if (Tcl_IsShared(valuePtr)) {
         5142  +		Tcl_GetBignumFromObj(NULL, valuePtr, &big);
         5143  +	    } else {
         5144  +		Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);
         5145  +	    }
         5146  +	}
         5147  +	/* ~a = - a - 1 */
         5148  +	mp_neg(&big, &big);
         5149  +	mp_sub_d(&big, 1, &big);
         5150  +	if (Tcl_IsShared(valuePtr)) {
         5151  +	    objResultPtr = Tcl_NewBignumObj(&big);
         5152  +	    NEXT_INST_F(1, 1, 1);
         5153  +	}
         5154  +	Tcl_SetBignumObj(valuePtr, &big);
         5155  +	NEXT_INST_F(1, 0, 0);
         5156  +    }
         5157  +
         5158  +    case INST_UMINUS: {
         5159  +	mp_int big;
         5160  +	ClientData ptr;
         5161  +	int type;
         5162  +	Tcl_Obj *valuePtr = *tosPtr;
         5163  +
         5164  +	result = TclGetNumberFromObj(NULL, valuePtr, &ptr, &type);
         5165  +	if ((result != TCL_OK)
         5166  +#ifndef ACCEPT_NAN
         5167  +		|| (type == TCL_NUMBER_NAN)
  5129   5168   #endif
  5130   5169   		) {
  5131         -	    /* Value is now numeric (including NaN) */
  5132         -#ifdef ACCEPT_NAN
  5133         -	    if (result != TCL_OK) {
  5134         -	        /* Value is NaN */
  5135         -		if (*pc == INST_BITNOT) {
  5136         -		    /* ~NaN => error; arg must be an integer */
  5137         -		    goto error;
  5138         -		}
  5139         -		/* -NaN => NaN */
  5140         -		result = TCL_OK;
  5141         -		NEXT_INST_F(1, 0, 0);
         5170  +	    result = TCL_ERROR;
         5171  +	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
         5172  +		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
         5173  +	    IllegalExprOperandType(interp, pc, valuePtr);
         5174  +	    goto checkForCatch;
         5175  +	}
         5176  +	switch (type) {
         5177  +	case TCL_NUMBER_DOUBLE: {
         5178  +	    double d;
         5179  +	    if (Tcl_IsShared(valuePtr)) {
         5180  +		TclNewDoubleObj(objResultPtr, -(*((CONST double *)ptr)));
         5181  +		NEXT_INST_F(1, 1, 1);
  5142   5182   	    }
  5143         -#endif
  5144         -	    if (valuePtr->typePtr == &tclDoubleType) {
  5145         -		if (*pc == INST_BITNOT) {
  5146         -		    /* ~ arg must be an integer */
  5147         -		    result = TCL_ERROR;
  5148         -		    goto error;
  5149         -		}
         5183  +	    d = *((CONST double *)ptr);
         5184  +	    TclSetDoubleObj(valuePtr, -d);
         5185  +	    NEXT_INST_F(1, 0, 0);
         5186  +	}
         5187  +	case TCL_NUMBER_LONG: {
         5188  +	    long l = *((CONST long *)ptr);
         5189  +	    if (l != LONG_MIN) {
  5150   5190   		if (Tcl_IsShared(valuePtr)) {
  5151         -		    TclNewDoubleObj(objResultPtr, -d);
         5191  +		    TclNewLongObj(objResultPtr, -l);
  5152   5192   		    NEXT_INST_F(1, 1, 1);
  5153   5193   		}
  5154         -		TclSetDoubleObj(valuePtr, -d);
  5155         -		NEXT_INST_F(1, 0, 0);
  5156         -	    } else {
  5157         -		/* TODO: optimize use of narrower native integers */
  5158         -		mp_int big;
  5159         -		Tcl_GetBignumFromObj(NULL, valuePtr, &big);
  5160         -		mp_neg(&big, &big);
  5161         -		if (*pc == INST_BITNOT) {
  5162         -		    /* ~a = - a - 1 */
  5163         -		    mp_sub_d(&big, 1, &big);
  5164         -		}
  5165         -		if (Tcl_IsShared(valuePtr)) {
  5166         -		    objResultPtr = Tcl_NewBignumObj(&big);
  5167         -		    NEXT_INST_F(1, 1, 1);
  5168         -		}
  5169         -		Tcl_SetBignumObj(valuePtr, &big);
         5194  +		TclSetLongObj(valuePtr, -l);
  5170   5195   		NEXT_INST_F(1, 0, 0);
  5171   5196   	    }
         5197  +	    /* FALLTHROUGH */
  5172   5198   	}
  5173         -	/* ... -$NonNumeric => raise an error */
  5174         -    error:
  5175         -	TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
  5176         -		(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
  5177         -	IllegalExprOperandType(interp, pc, valuePtr);
  5178         -	goto checkForCatch;
         5199  +	case TCL_NUMBER_WIDE:
         5200  +	case TCL_NUMBER_BIG: {
         5201  +	    switch (type) {
         5202  +	    case TCL_NUMBER_LONG:
         5203  +		TclBNInitBignumFromLong(&big, *((CONST long *)ptr));
         5204  +		break;
         5205  +	    case TCL_NUMBER_WIDE:
         5206  +		TclBNInitBignumFromWideInt(&big, *((CONST Tcl_WideInt*)ptr));
         5207  +		break;
         5208  +	    case TCL_NUMBER_BIG:
         5209  +		if (Tcl_IsShared(valuePtr)) {
         5210  +		    Tcl_GetBignumFromObj(NULL, valuePtr, &big);
         5211  +		} else {
         5212  +		    Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);
         5213  +		}
         5214  +	    }
         5215  +	    mp_neg(&big, &big);
         5216  +	    if (Tcl_IsShared(valuePtr)) {
         5217  +		objResultPtr = Tcl_NewBignumObj(&big);
         5218  +		NEXT_INST_F(1, 1, 1);
         5219  +	    }
         5220  +	    Tcl_SetBignumObj(valuePtr, &big);
         5221  +	    NEXT_INST_F(1, 0, 0);
         5222  +	}
         5223  +	case TCL_NUMBER_NAN:
         5224  +	    /* -NaN => NaN */
         5225  +	    NEXT_INST_F(1, 0, 0);
         5226  +	}
  5179   5227   #endif
  5180   5228       }
  5181   5229   
  5182   5230   #if 0
  5183   5231       case INST_BITNOT: {
  5184   5232   	/*
  5185   5233   	 * The operand must be an integer. If the operand object is unshared
................................................................................
  6573   6621       Tcl_Interp *interp;		/* Interpreter to which error information
  6574   6622   				 * pertains. */
  6575   6623       unsigned char *pc;		/* Points to the instruction being executed
  6576   6624   				 * when the illegal type was found. */
  6577   6625       Tcl_Obj *opndPtr;		/* Points to the operand holding the value
  6578   6626   				 * with the illegal type. */
  6579   6627   {
  6580         -    Tcl_Obj *msg = Tcl_NewStringObj("can't use ", -1);
  6581         -    double d;
  6582         -    int isNumeric;
  6583         -    unsigned char opCode = *pc;
  6584         -    CONST char *operator = operatorStrings[opCode - INST_LOR];
  6585         -    if (opCode == INST_EXPON) {
         6628  +    ClientData ptr;
         6629  +    int type;
         6630  +    unsigned char opcode = *pc;
         6631  +    CONST char *description, *operator = operatorStrings[opcode - INST_LOR];
         6632  +    Tcl_Obj *msg = Tcl_NewObj();
         6633  +
         6634  +    if (opcode == INST_EXPON) {
  6586   6635   	operator = "**";
  6587   6636       }
  6588   6637   
  6589         -    /* TODO: Consider alternative that need not write to d */
  6590         -    isNumeric = (Tcl_GetDoubleFromObj(NULL, opndPtr, &d) == TCL_OK);
  6591         -
  6592         -    if (opndPtr->typePtr == &tclDoubleType) {
  6593         -	if (!isNumeric) {
  6594         -	    Tcl_AppendToObj(msg, "non-numeric ", -1);
  6595         -	}
  6596         -	Tcl_AppendToObj(msg, "floating-point value", -1);
  6597         -    } else if (isNumeric) {
  6598         -	/* TODO: check callers, might be able to eliminate this */
  6599         -	Tcl_AppendToObj(msg, "(big) integer", -1);
  6600         -    } else {
  6601         -        /* TODO: When to post "integer value too large to represent" ? */
         6638  +    if (TclGetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
  6602   6639   	int numBytes;
  6603   6640   	CONST char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
  6604   6641   	if (numBytes == 0) {
  6605         -	    Tcl_AppendToObj(msg, "empty string", -1);
         6642  +	    description = "empty string";
  6606   6643   	} else if (TclCheckBadOctal(NULL, bytes)) {
  6607         -	    Tcl_AppendToObj(msg, "invalid octal number", -1);
         6644  +	    description = "invalid octal number";
  6608   6645   	} else {
  6609         -	    Tcl_AppendToObj(msg, "non-numeric string", -1);
         6646  +	    description = "non-numeric string";
  6610   6647   	}
         6648  +    } else if (type == TCL_NUMBER_NAN) {
         6649  +	description = "non-numeric floating-point value";
         6650  +    } else if (type == TCL_NUMBER_DOUBLE) {
         6651  +	description = "floating-point value";
         6652  +    } else {
         6653  +	/* TODO: No caller needs this.  Eliminate? */
         6654  +	description = "(big) integer";
  6611   6655       }
  6612         -    Tcl_AppendToObj(msg, " as operand of \"", -1);
  6613         -    Tcl_AppendToObj(msg, operator, -1);
  6614         -    Tcl_AppendToObj(msg, "\"", -1);
         6656  +
         6657  +    TclObjPrintf(NULL, msg, "can't use %s as operand of \"%s\"",
         6658  +	    description, operator);
  6615   6659       Tcl_SetObjResult(interp, msg);
  6616   6660   }
  6617   6661   
  6618   6662   /*
  6619   6663    *----------------------------------------------------------------------
  6620   6664    *
  6621   6665    * GetSrcInfoForPc --