diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2003-04-28 12:34:21 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2003-04-28 12:34:21 (GMT) |
commit | 9fe48f681df7e7a45aee145405151f0bef5d5808 (patch) | |
tree | a7dfc6ac4db8ceaa9a7d3fceccf59bbe274caa74 | |
parent | 270dd26ada27456d73cfdcaf7623fee880227569 (diff) | |
download | tcl-9fe48f681df7e7a45aee145405151f0bef5d5808.zip tcl-9fe48f681df7e7a45aee145405151f0bef5d5808.tar.gz tcl-9fe48f681df7e7a45aee145405151f0bef5d5808.tar.bz2 |
Made [incr] able to accept and work with wide increments [Bug 728838]
-rw-r--r-- | ChangeLog | 10 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 379 | ||||
-rw-r--r-- | generic/tclDictObj.c | 73 | ||||
-rw-r--r-- | generic/tclExecute.c | 83 | ||||
-rw-r--r-- | generic/tclInt.decls | 134 | ||||
-rw-r--r-- | generic/tclInt.h | 5 | ||||
-rw-r--r-- | generic/tclIntDecls.h | 20 | ||||
-rw-r--r-- | generic/tclStubInit.c | 3 | ||||
-rw-r--r-- | generic/tclVar.c | 159 | ||||
-rw-r--r-- | tests/incr.test | 24 |
10 files changed, 578 insertions, 312 deletions
@@ -1,5 +1,15 @@ 2003-04-28 Donal K. Fellows <fellowsd@cs.man.ac.uk> + * generic/tclDictObj.c (DictIncrCmd): Updated to reflect the + behaviour with wide increments of the normal [incr] command. + * generic/tclInt.decls: Added TclIncrWideVar2 to internal stub + table and cleaned up. + * tests/incr.test (incr-3.*): + * generic/tclVar.c (TclIncrWideVar2, TclPtrIncrWideVar): + * generic/tclExecute.c (TclExecuteByteCode): + * generic/tclCmdIL.c (Tcl_IncrObjCmd): Make [incr] work when + trying to increment by wide values. [Bug 728838] + * generic/tclCompCmds.c (TclCompileSwitchCmd): Default mode of operation of [switch] is exact matching. [Bug 727563] diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 1e4dd4c..aba9dd3 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.48 2003/04/16 23:33:43 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.49 2003/04/28 12:34:23 dkf Exp $ */ #include "tclInt.h" @@ -309,10 +309,12 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { long incrAmount; + Tcl_WideInt wideIncrAmount; Tcl_Obj *newValuePtr; + int isWide; if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); + Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); return TCL_ERROR; } @@ -322,11 +324,8 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) if (objc == 2) { incrAmount = 1; + isWide = 0; } else { - if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (reading increment)"); - return TCL_ERROR; - } /* * Need to be a bit cautious to ensure that [expr]-like rules * are enforced for interpretation of wide integers, despite @@ -334,20 +333,24 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) */ if (objv[2]->typePtr == &tclIntType) { incrAmount = objv[2]->internalRep.longValue; + isWide = 0; } else if (objv[2]->typePtr == &tclWideIntType) { - TclGetLongFromWide(incrAmount,objv[2]); + wideIncrAmount = objv[2]->internalRep.wideValue; + isWide = 1; } else { - Tcl_WideInt wide; - - if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], + &wideIncrAmount) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } - incrAmount = Tcl_WideAsLong(wide); - if ((wide <= Tcl_LongAsWide(LONG_MAX)) - && (wide >= Tcl_LongAsWide(LONG_MIN))) { + if ((wideIncrAmount <= Tcl_LongAsWide(LONG_MAX)) + && (wideIncrAmount >= Tcl_LongAsWide(LONG_MIN))) { + incrAmount = Tcl_WideAsLong(wideIncrAmount); objv[2]->typePtr = &tclIntType; objv[2]->internalRep.longValue = incrAmount; + isWide = 0; + } else { + isWide = 1; } } } @@ -356,8 +359,13 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) * Increment the variable's value. */ - newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, - TCL_LEAVE_ERR_MSG); + if (isWide) { + newValuePtr = TclIncrWideVar2(interp, objv[1], (Tcl_Obj *) NULL, + wideIncrAmount, TCL_LEAVE_ERR_MSG); + } else { + newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, + incrAmount, TCL_LEAVE_ERR_MSG); + } if (newValuePtr == NULL) { return TCL_ERROR; } @@ -397,12 +405,12 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { - "args", "body", "cmdcount", "commands", - "complete", "default", "exists", "functions", "globals", - "hostname", "level", "library", "loaded", - "locals", "nameofexecutable", "patchlevel", "procs", - "script", "sharedlibextension", "tclversion", "vars", - (char *) NULL}; + "args", "body", "cmdcount", "commands", + "complete", "default", "exists", "functions", "globals", + "hostname", "level", "library", "loaded", + "locals", "nameofexecutable", "patchlevel", "procs", + "script", "sharedlibextension", "tclversion", "vars", + (char *) NULL}; enum ISubCmdIdx { IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, @@ -413,8 +421,8 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) int index, result; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; } result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, @@ -424,19 +432,19 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) } switch (index) { - case IArgsIdx: + case IArgsIdx: result = InfoArgsCmd(clientData, interp, objc, objv); - break; + break; case IBodyIdx: result = InfoBodyCmd(clientData, interp, objc, objv); break; case ICmdCountIdx: result = InfoCmdCountCmd(clientData, interp, objc, objv); break; - case ICommandsIdx: + case ICommandsIdx: result = InfoCommandsCmd(clientData, interp, objc, objv); break; - case ICompleteIdx: + case ICompleteIdx: result = InfoCompleteCmd(clientData, interp, objc, objv); break; case IDefaultIdx: @@ -448,10 +456,10 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) case IFunctionsIdx: result = InfoFunctionsCmd(clientData, interp, objc, objv); break; - case IGlobalsIdx: + case IGlobalsIdx: result = InfoGlobalsCmd(clientData, interp, objc, objv); break; - case IHostnameIdx: + case IHostnameIdx: result = InfoHostnameCmd(clientData, interp, objc, objv); break; case ILevelIdx: @@ -460,10 +468,10 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) case ILibraryIdx: result = InfoLibraryCmd(clientData, interp, objc, objv); break; - case ILoadedIdx: + case ILoadedIdx: result = InfoLoadedCmd(clientData, interp, objc, objv); break; - case ILocalsIdx: + case ILocalsIdx: result = InfoLocalsCmd(clientData, interp, objc, objv); break; case INameOfExecutableIdx: @@ -472,10 +480,10 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) case IPatchLevelIdx: result = InfoPatchLevelCmd(clientData, interp, objc, objv); break; - case IProcsIdx: + case IProcsIdx: result = InfoProcsCmd(clientData, interp, objc, objv); break; - case IScriptIdx: + case IScriptIdx: result = InfoScriptCmd(clientData, interp, objc, objv); break; case ISharedLibExtensionIdx: @@ -525,16 +533,16 @@ InfoArgsCmd(dummy, interp, objc, objv) Tcl_Obj *listObjPtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procname"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "procname"); + return TCL_ERROR; } name = Tcl_GetString(objv[2]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "\"", name, "\" isn't a procedure", (char *) NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", name, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; } /* @@ -543,11 +551,11 @@ InfoArgsCmd(dummy, interp, objc, objv) listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_ListObjAppendElement(interp, listObjPtr, + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_ListObjAppendElement(interp, listObjPtr, Tcl_NewStringObj(localPtr->name, -1)); - } + } } Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; @@ -586,16 +594,16 @@ InfoBodyCmd(dummy, interp, objc, objv) Tcl_Obj *bodyPtr, *resultPtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procname"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "procname"); + return TCL_ERROR; } name = Tcl_GetString(objv[2]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", name, "\" isn't a procedure", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } /* @@ -652,8 +660,8 @@ InfoCmdCountCmd(dummy, interp, objc, objv) Interp *iPtr = (Interp *) interp; if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount); @@ -708,7 +716,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) */ if (objc == 2) { - simplePattern = NULL; + simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 3) { @@ -721,18 +729,17 @@ InfoCommandsCmd(dummy, interp, objc, objv) */ Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetString(objv[2]); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, - /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); if (nsPtr != NULL) { /* we successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } /* @@ -819,8 +826,8 @@ InfoCompleteCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "command"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "command"); + return TCL_ERROR; } if (TclObjCommandComplete(objv[2])) { @@ -867,8 +874,8 @@ InfoDefaultCmd(dummy, interp, objc, objv) Tcl_Obj *valueObjPtr; if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); + return TCL_ERROR; } procName = Tcl_GetString(objv[2]); @@ -878,37 +885,37 @@ InfoDefaultCmd(dummy, interp, objc, objv) if (procPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", procName, "\" isn't a procedure", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { - if (TclIsVarArgument(localPtr) + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr) && (strcmp(argName, localPtr->name) == 0)) { - if (localPtr->defValuePtr != NULL) { + if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, localPtr->defValuePtr, 0); - if (valueObjPtr == NULL) { - defStoreError: + if (valueObjPtr == NULL) { + defStoreError: varName = Tcl_GetString(objv[4]); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't store default value in variable \"", varName, "\"", (char *) NULL); - return TCL_ERROR; - } + return TCL_ERROR; + } Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - } else { - Tcl_Obj *nullObjPtr = Tcl_NewObj(); - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + } else { + Tcl_Obj *nullObjPtr = Tcl_NewObj(); + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, nullObjPtr, 0); - if (valueObjPtr == NULL) { - Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ - goto defStoreError; - } + if (valueObjPtr == NULL) { + Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ + goto defStoreError; + } Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } - return TCL_OK; - } + } + return TCL_OK; + } } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -948,16 +955,16 @@ InfoExistsCmd(dummy, interp, objc, objv) Var *varPtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "varName"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "varName"); + return TCL_ERROR; } varName = Tcl_GetString(objv[2]); varPtr = TclVarTraceExists(interp, varName); if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } @@ -994,12 +1001,12 @@ InfoFunctionsCmd(dummy, interp, objc, objv) Tcl_Obj *listPtr; if (objc == 2) { - pattern = NULL; + pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetString(objv[2]); + pattern = Tcl_GetString(objv[2]); } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } listPtr = Tcl_ListMathFuncs(interp, pattern); @@ -1046,12 +1053,12 @@ InfoGlobalsCmd(dummy, interp, objc, objv) Tcl_Obj *listPtr; if (objc == 2) { - pattern = NULL; + pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetString(objv[2]); + pattern = Tcl_GetString(objv[2]); } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } /* @@ -1061,17 +1068,17 @@ InfoGlobalsCmd(dummy, interp, objc, objv) listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (TclIsVarUndefined(varPtr)) { - continue; - } - varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (TclIsVarUndefined(varPtr)) { + continue; + } + varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(varName, -1)); - } + } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; @@ -1106,8 +1113,8 @@ InfoHostnameCmd(dummy, interp, objc, objv) { CONST char *name; if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } name = Tcl_GetHostName(); @@ -1154,40 +1161,40 @@ InfoLevelCmd(dummy, interp, objc, objv) Tcl_Obj *listPtr; if (objc == 2) { /* just "info level" */ - if (iPtr->varFramePtr == NULL) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level); - } - return TCL_OK; + if (iPtr->varFramePtr == NULL) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level); + } + return TCL_OK; } else if (objc == 3) { - if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level <= 0) { - if (iPtr->varFramePtr == NULL) { - levelError: + if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + if (iPtr->varFramePtr == NULL) { + levelError: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", Tcl_GetString(objv[2]), "\"", (char *) NULL); - return TCL_ERROR; - } - level += iPtr->varFramePtr->level; - } - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - - listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; + return TCL_ERROR; + } + level += iPtr->varFramePtr->level; + } + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + + listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } Tcl_WrongNumArgs(interp, 2, objv, "?number?"); @@ -1225,17 +1232,17 @@ InfoLibraryCmd(dummy, interp, objc, objv) CONST char *libDirName; if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); if (libDirName != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1); - return TCL_OK; + Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1); + return TCL_OK; } Tcl_SetStringObj(Tcl_GetObjResult(interp), - "no library has been specified for Tcl", -1); + "no library has been specified for Tcl", -1); return TCL_ERROR; } @@ -1271,8 +1278,8 @@ InfoLoadedCmd(dummy, interp, objc, objv) int result; if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); + return TCL_ERROR; } if (objc == 2) { /* get loaded pkgs in all interpreters */ @@ -1317,16 +1324,16 @@ InfoLocalsCmd(dummy, interp, objc, objv) Tcl_Obj *listPtr; if (objc == 2) { - pattern = NULL; + pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetString(objv[2]); + pattern = Tcl_GetString(objv[2]); } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) { - return TCL_OK; + return TCL_OK; } /* @@ -1391,7 +1398,7 @@ AppendLocals(interp, listPtr, pattern, includeLinks) Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(varName, -1)); } - } + } varPtr++; localPtr = localPtr->nextPtr; } @@ -1399,7 +1406,7 @@ AppendLocals(interp, listPtr, pattern, includeLinks) if (localVarTablePtr != NULL) { for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { + entryPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { @@ -1445,8 +1452,8 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv) CONST char *nameOfExecutable; if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } nameOfExecutable = Tcl_GetNameOfExecutable(); @@ -1488,15 +1495,15 @@ InfoPatchLevelCmd(dummy, interp, objc, objv) CONST char *patchlevel; if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", - (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1); - return TCL_OK; + Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1); + return TCL_OK; } return TCL_ERROR; } @@ -1574,8 +1581,8 @@ InfoProcsCmd(dummy, interp, objc, objv) specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } /* @@ -1690,8 +1697,8 @@ InfoScriptCmd(dummy, interp, objc, objv) { Interp *iPtr = (Interp *) interp; if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); + return TCL_ERROR; } if (objc == 3) { @@ -1702,7 +1709,7 @@ InfoScriptCmd(dummy, interp, objc, objv) Tcl_IncrRefCount(iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { - Tcl_SetObjResult(interp, iPtr->scriptFile); + Tcl_SetObjResult(interp, iPtr->scriptFile); } return TCL_OK; } @@ -1736,8 +1743,8 @@ InfoSharedlibCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } #ifdef TCL_SHLIB_EXT @@ -1776,15 +1783,15 @@ InfoTclVersionCmd(dummy, interp, objc, objv) CONST char *version; if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } version = Tcl_GetVar(interp, "tcl_version", - (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (version != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1); - return TCL_OK; + Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1); + return TCL_OK; } return TCL_ERROR; } @@ -1839,7 +1846,7 @@ InfoVarsCmd(dummy, interp, objc, objv) */ if (objc == 2) { - simplePattern = NULL; + simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; } else if (objc == 3) { @@ -1853,7 +1860,7 @@ InfoVarsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetString(objv[2]); + pattern = Tcl_GetString(objv[2]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -1862,8 +1869,8 @@ InfoVarsCmd(dummy, interp, objc, objv) specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; } /* @@ -2613,11 +2620,11 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv) */ if (listPtr->typePtr != &tclListType) { - result = Tcl_ListObjGetElements(interp, listPtr, &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; - } + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } } /* @@ -3262,8 +3269,8 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) SortElement *elementArray; SortElement *elementPtr; SortInfo sortInfo; /* Information about this sort that - * needs to be passed to the - * comparison function */ + * needs to be passed to the + * comparison function */ static CONST char *switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", "-index", "-integer", "-real", "-unique", (char *) NULL @@ -3346,7 +3353,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) * later. */ - Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); + Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); Tcl_Obj *newObjPtr = Tcl_NewObj(); Tcl_IncrRefCount(newCommandPtr); @@ -3428,7 +3435,7 @@ static SortElement * MergeSort(headPtr, infoPtr) SortElement *headPtr; /* First element on the list */ SortInfo *infoPtr; /* Information needed by the - * comparison operator */ + * comparison operator */ { /* * The subList array below holds pointers to temporary lists built @@ -3442,7 +3449,7 @@ MergeSort(headPtr, infoPtr) int i; for(i = 0; i < NUM_LISTS; i++){ - subList[i] = NULL; + subList[i] = NULL; } while (headPtr != NULL) { elementPtr = headPtr; @@ -3459,7 +3466,7 @@ MergeSort(headPtr, infoPtr) } elementPtr = NULL; for (i = 0; i < NUM_LISTS; i++){ - elementPtr = MergeLists(subList[i], elementPtr, infoPtr); + elementPtr = MergeLists(subList[i], elementPtr, infoPtr); } return elementPtr; } @@ -3489,17 +3496,17 @@ MergeLists(leftPtr, rightPtr, infoPtr) SortElement *rightPtr; /* Second list to be merged; may be * NULL. */ SortInfo *infoPtr; /* Information needed by the - * comparison operator. */ + * comparison operator. */ { SortElement *headPtr; SortElement *tailPtr; int cmp; if (leftPtr == NULL) { - return rightPtr; + return rightPtr; } if (rightPtr == NULL) { - return leftPtr; + return leftPtr; } cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); if (cmp > 0) { @@ -3529,9 +3536,9 @@ MergeLists(leftPtr, rightPtr, infoPtr) } } if (leftPtr != NULL) { - tailPtr->nextPtr = leftPtr; + tailPtr->nextPtr = leftPtr; } else { - tailPtr->nextPtr = rightPtr; + tailPtr->nextPtr = rightPtr; } return headPtr; } @@ -3561,7 +3568,7 @@ static int SortCompare(objPtr1, objPtr2, infoPtr) Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */ SortInfo *infoPtr; /* Information passed from the - * top-level "lsort" command */ + * top-level "lsort" command */ { int order, listLen, index; Tcl_Obj *objPtr; @@ -3823,8 +3830,8 @@ DictionaryCompare(left, right) break; } - diff = uniLeftLower - uniRightLower; - if (diff) { + diff = uniLeftLower - uniRightLower; + if (diff) { return diff; } else if (secondaryDiff == 0) { if (Tcl_UniCharIsUpper(uniLeft) && @@ -3834,7 +3841,7 @@ DictionaryCompare(left, right) && Tcl_UniCharIsLower(uniLeft)) { secondaryDiff = 1; } - } + } } if (diff == 0) { diff = secondaryDiff; diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 53e7d66..dfafccf 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.7 2003/04/16 23:33:43 dgp Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.8 2003/04/28 12:34:24 dkf Exp $ */ #include "tclInt.h" @@ -1678,8 +1678,9 @@ DictIncrCmd(interp, objc, objv) Tcl_Obj *CONST *objv; { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int result; + int result, isWide; long incrValue; + Tcl_WideInt wideIncrValue; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?"); @@ -1687,18 +1688,40 @@ DictIncrCmd(interp, objc, objv) } if (objc == 5) { - result = Tcl_GetLongFromObj(interp, objv[4], &incrValue); - if (result != TCL_OK) { - return result; + if (objv[4]->typePtr == &tclIntType) { + incrValue = objv[4]->internalRep.longValue; + isWide = 0; + } else if (objv[4]->typePtr == &tclWideIntType) { + wideIncrValue = objv[4]->internalRep.wideValue; + isWide = 1; + } else { + result = Tcl_GetWideIntFromObj(interp, objv[4], &wideIncrValue); + if (result != TCL_OK) { + return result; + } + if (wideIncrValue <= Tcl_LongAsWide(LONG_MAX) + && wideIncrValue >= Tcl_LongAsWide(LONG_MIN)) { + isWide = 0; + incrValue = Tcl_WideAsLong(wideIncrValue); + objv[4]->typePtr = &tclIntType; + } else { + isWide = 1; + } } } else { incrValue = 1; + isWide = 0; } dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); if (dictPtr == NULL) { dictPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewLongObj(incrValue)); + if (isWide) { + valuePtr = Tcl_NewWideIntObj(wideIncrValue); + } else { + valuePtr = Tcl_NewLongObj(incrValue); + } + Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr); } else { long lValue; Tcl_WideInt wValue; @@ -1711,13 +1734,25 @@ DictIncrCmd(interp, objc, objv) return TCL_ERROR; } if (valuePtr == NULL) { - valuePtr = Tcl_NewLongObj(incrValue); + if (isWide) { + valuePtr = Tcl_NewWideIntObj(wideIncrValue); + } else { + valuePtr = Tcl_NewLongObj(incrValue); + } } else if (valuePtr->typePtr == &tclWideIntType) { Tcl_GetWideIntFromObj(NULL, valuePtr, &wValue); if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_NewWideIntObj(wValue + incrValue); + if (isWide) { + valuePtr = Tcl_NewWideIntObj(wValue + wideIncrValue); + } else { + valuePtr = Tcl_NewWideIntObj(wValue + incrValue); + } } else { - Tcl_SetWideIntObj(valuePtr, wValue + incrValue); + if (isWide) { + Tcl_SetWideIntObj(valuePtr, wValue + wideIncrValue); + } else { + Tcl_SetWideIntObj(valuePtr, wValue + incrValue); + } if (dictPtr->bytes != NULL) { Tcl_InvalidateStringRep(dictPtr); } @@ -1726,9 +1761,17 @@ DictIncrCmd(interp, objc, objv) } else if (valuePtr->typePtr == &tclIntType) { Tcl_GetLongFromObj(NULL, valuePtr, &lValue); if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_NewLongObj(lValue + incrValue); + if (isWide) { + valuePtr = Tcl_NewWideIntObj(lValue + wideIncrValue); + } else { + valuePtr = Tcl_NewLongObj(lValue + incrValue); + } } else { - Tcl_SetLongObj(valuePtr, lValue + incrValue); + if (isWide) { + Tcl_SetWideIntObj(valuePtr, lValue + wideIncrValue); + } else { + Tcl_SetLongObj(valuePtr, lValue + incrValue); + } if (dictPtr->bytes != NULL) { Tcl_InvalidateStringRep(dictPtr); } @@ -1749,7 +1792,9 @@ DictIncrCmd(interp, objc, objv) * Determine if we should have got a standard long instead. */ if (Tcl_IsShared(valuePtr)) { - if (wValue >= LONG_MIN && wValue <= LONG_MAX) { + if (isWide) { + valuePtr = Tcl_NewWideIntObj(wValue + wideIncrValue); + } else if (wValue >= LONG_MIN && wValue <= LONG_MAX) { /* * Convert the type... */ @@ -1759,7 +1804,9 @@ DictIncrCmd(interp, objc, objv) valuePtr = Tcl_NewWideIntObj(wValue + incrValue); } } else { - if (wValue >= LONG_MIN && wValue <= LONG_MAX) { + if (isWide) { + Tcl_SetWideIntObj(valuePtr, wValue + wideIncrValue); + } else if (wValue >= LONG_MIN && wValue <= LONG_MAX) { Tcl_SetLongObj(valuePtr, Tcl_WideAsLong(wValue) + incrValue); } else { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bcdb242..3d324a5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * 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.99 2003/04/18 20:03:50 hobbs Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.100 2003/04/28 12:34:25 dkf Exp $ */ #include "tclInt.h" @@ -1060,6 +1060,7 @@ TclExecuteByteCode(interp, codePtr) int length; long i = 0; /* Init. avoids compiler warning. */ Tcl_WideInt w; + int isWide; register int cleanup; Tcl_Obj *objResultPtr; char *part1, *part2; @@ -1872,8 +1873,10 @@ TclExecuteByteCode(interp, codePtr) valuePtr = stackPtr[stackTop]; if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; + isWide = 0; } else if (valuePtr->typePtr == &tclWideIntType) { - TclGetLongFromWide(i,valuePtr); + w = valuePtr->internalRep.wideValue; + isWide = 1; } else { REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); if (result != TCL_OK) { @@ -1882,7 +1885,7 @@ TclExecuteByteCode(interp, codePtr) Tcl_AddErrorInfo(interp, "\n (reading increment)"); goto checkForCatch; } - FORCE_LONG(valuePtr, i, w); + isWide = (valuePtr->typePtr == &tclWideIntType); } stackTop--; TclDecrRefCount(valuePtr); @@ -1902,6 +1905,7 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: i = TclGetInt1AtPtr(pc+1); + isWide = 0; pcAdjustment = 2; doIncrStk: @@ -1933,6 +1937,7 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); i = TclGetInt1AtPtr(pc+2); + isWide = 0; pcAdjustment = 3; doIncrArray: @@ -1957,6 +1962,7 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); i = TclGetInt1AtPtr(pc+2); + isWide = 0; pcAdjustment = 3; doIncrScalar: @@ -1977,35 +1983,58 @@ TclExecuteByteCode(interp, codePtr) && !TclIsVarUndefined(varPtr) && (varPtr->tracePtr == NULL) && ((arrayPtr == NULL) - || (arrayPtr->tracePtr == NULL)) - && (objPtr->typePtr == &tclIntType)) { - /* - * No errors, no traces, the variable already has an - * integer value: inline processing. - */ + || (arrayPtr->tracePtr == NULL))) { + if (objPtr->typePtr == &tclIntType && !isWide) { + /* + * No errors, no traces, the variable already has an + * integer value: inline processing. + */ - i += objPtr->internalRep.longValue; - if (Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewLongObj(i); - TclDecrRefCount(objPtr); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - Tcl_SetLongObj(objPtr, i); - objResultPtr = objPtr; + i += objPtr->internalRep.longValue; + if (Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewLongObj(i); + TclDecrRefCount(objPtr); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + Tcl_SetLongObj(objPtr, i); + objResultPtr = objPtr; + } + goto doneIncr; + } else if (objPtr->typePtr == &tclWideIntType && isWide) { + /* + * No errors, no traces, the variable already has a + * wide integer value: inline processing. + */ + + w += objPtr->internalRep.wideValue; + if (Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewWideIntObj(w); + TclDecrRefCount(objPtr); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + Tcl_SetWideIntObj(objPtr, w); + objResultPtr = objPtr; + } + goto doneIncr; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + } + DECACHE_STACK_INFO(); + if (isWide) { + objResultPtr = TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, + part2, w, TCL_LEAVE_ERR_MSG); } else { - DECACHE_STACK_INFO(); objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, - part2, i, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } + part2, i, TCL_LEAVE_ERR_MSG); + } + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } + doneIncr: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); #ifndef TCL_COMPILE_DEBUG if (*(pc+pcAdjustment) == INST_POP) { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 8a68f70..d68aa29 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.59 2003/02/18 02:25:45 hobbs Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.60 2003/04/28 12:34:27 dkf Exp $ library tcl @@ -111,7 +111,7 @@ declare 22 generic { int *sizePtr, int *bracePtr) } declare 23 generic { - Proc * TclFindProc(Interp *iPtr, CONST char *procName) + Proc *TclFindProc(Interp *iPtr, CONST char *procName) } declare 24 generic { int TclFormatInt(char *buffer, long n) @@ -120,8 +120,8 @@ declare 25 generic { void TclFreePackageInfo(Interp *iPtr) } # Removed in 8.1: -# declare 26 generic { -# char * TclGetCwd(Tcl_Interp *interp) +# declare 26 generic { +# char *TclGetCwd(Tcl_Interp *interp) # } declare 27 generic { int TclGetDate(char *p, unsigned long now, long zone, @@ -132,15 +132,15 @@ declare 28 generic { } # Removed in 8.4b2: #declare 29 generic { -# Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, +# Tcl_Obj *TclGetElementOfIndexedArray(Tcl_Interp *interp, # int localIndex, Tcl_Obj *elemPtr, int flags) #} -# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: +# Replaced by char *TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: # declare 30 generic { -# char * TclGetEnv(CONST char *name) +# char *TclGetEnv(CONST char *name) # } declare 31 generic { - char * TclGetExtension(char *name) + char *TclGetExtension(char *name) } declare 32 generic { int TclGetFrame(Tcl_Interp *interp, CONST char *str, @@ -155,7 +155,7 @@ declare 34 generic { } # Removed in 8.4b2: #declare 35 generic { -# Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, +# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} declare 36 generic { @@ -180,10 +180,11 @@ declare 41 generic { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 generic { - char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr) + char *TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr) } declare 43 generic { - int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags) + int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, + int flags) } declare 44 generic { int TclGuessPackageName(CONST char *fileName, Tcl_DString *bufPtr) @@ -196,16 +197,16 @@ declare 46 generic { } # Removed in 8.4b2: #declare 47 generic { -# Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp, +# Tcl_Obj *TclIncrElementOfIndexedArray(Tcl_Interp *interp, # int localIndex, Tcl_Obj *elemPtr, long incrAmount) #} # Removed in 8.4b2: #declare 48 generic { -# Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, +# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, # long incrAmount) #} declare 49 generic { - Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) } declare 50 generic { @@ -227,7 +228,7 @@ declare 54 generic { int objc, Tcl_Obj *CONST objv[]) } declare 55 generic { - Proc * TclIsProc(Command *cmdPtr) + Proc *TclIsProc(Command *cmdPtr) } # Replaced with TclpLoadFile in 8.1: # declare 56 generic { @@ -240,7 +241,7 @@ declare 55 generic { # int TclLooksLikeInt(char *p) # } declare 58 generic { - Var * TclLookupVar(Tcl_Interp *interp, CONST char *part1, CONST char *part2, + Var *TclLookupVar(Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, CONST char *msg, int createPart1, int createPart2, Var **arrayPtrPtr) } @@ -253,7 +254,7 @@ declare 60 generic { int TclNeedSpace(CONST char *start, CONST char *end) } declare 61 generic { - Tcl_Obj * TclNewProcBodyObj(Proc *procPtr) + Tcl_Obj *TclNewProcBodyObj(Proc *procPtr) } declare 62 generic { int TclObjCommandComplete(Tcl_Obj *cmdPtr) @@ -281,7 +282,7 @@ declare 67 generic { # int TclpAccess(CONST char *path, int mode) #} declare 69 generic { - char * TclpAlloc(unsigned int size) + char *TclpAlloc(unsigned int size) } #declare 70 generic { # int TclpCopyFile(CONST char *source, CONST char *dest) @@ -324,7 +325,7 @@ declare 78 generic { # char *modeString, int permissions) #} declare 81 generic { - char * TclpRealloc(char *ptr, unsigned int size) + char *TclpRealloc(char *ptr, unsigned int size) } #declare 82 generic { # int TclpRemoveDirectory(CONST char *path, int recursive, @@ -350,7 +351,7 @@ declare 81 generic { # void TclPlatformInit(Tcl_Interp *interp) # } declare 88 generic { - char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, + char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags) } declare 89 generic { @@ -391,16 +392,16 @@ declare 98 generic { } # Removed in 8.4b2: #declare 99 generic { -# Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex, +# Tcl_Obj *TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex, # Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags) #} # Removed in 8.4b2: #declare 100 generic { -# Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, +# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, # Tcl_Obj *objPtr, int flags) #} declare 101 generic { - char * TclSetPreInitScript(char *string) + char *TclSetPreInitScript(char *string) } declare 102 generic { void TclSetupEnv(Tcl_Interp *interp) @@ -430,7 +431,7 @@ declare 109 generic { } # Removed in 8.1: # declare 110 generic { -# char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) +# char *TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) # } # Procedures used in conjunction with Tcl namespaces. They are @@ -446,7 +447,7 @@ declare 112 generic { Tcl_Obj *objPtr) } declare 113 generic { - Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name, + Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 generic { @@ -461,7 +462,7 @@ declare 116 generic { Tcl_Namespace *contextNsPtr, int flags) } declare 117 generic { - Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, CONST char *name, + Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 generic { @@ -488,10 +489,10 @@ declare 123 generic { Tcl_Obj *objPtr) } declare 124 generic { - Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp) + Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) } declare 125 generic { - Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp) + Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) } declare 126 generic { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, @@ -502,10 +503,10 @@ declare 127 generic { CONST char *pattern, int allowOverwrite) } declare 128 generic { - void Tcl_PopCallFrame(Tcl_Interp* interp) + void Tcl_PopCallFrame(Tcl_Interp *interp) } declare 129 generic { - int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr, + int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame) } declare 130 generic { @@ -520,7 +521,7 @@ declare 132 generic { int TclpHasSockets(Tcl_Interp *interp) } declare 133 generic { - struct tm * TclpGetDate(TclpTime_t time, int useGMT) + struct tm *TclpGetDate(TclpTime_t time, int useGMT) } declare 134 generic { size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, @@ -536,7 +537,7 @@ declare 135 generic { # int TclpChdir(CONST char *dirName) #} declare 138 generic { - CONST84_RETURN char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) + CONST84_RETURN char *TclGetEnv(CONST char *name, Tcl_DString *valuePtr) } #declare 139 generic { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, @@ -610,11 +611,11 @@ declare 153 generic { #} declare 156 generic { - void TclRegError (Tcl_Interp *interp, CONST char *msg, + void TclRegError(Tcl_Interp *interp, CONST char *msg, int status) } declare 157 generic { - Var * TclVarTraceExists (Tcl_Interp *interp, CONST char *varName) + Var *TclVarTraceExists(Tcl_Interp *interp, CONST char *varName) } declare 158 generic { void TclSetStartupScriptFileName(CONST char *filename) @@ -642,7 +643,7 @@ declare 162 generic { # correct type when calling this procedure. declare 163 generic { - void * TclGetInstructionTable (void) + void *TclGetInstructionTable(void) } # ALERT: The argument of 'TclExpandCodeArray' is actually a @@ -650,7 +651,7 @@ declare 163 generic { # "tclInt.h". It is described in "tclCompile.h". declare 164 generic { - void TclExpandCodeArray (void *envPtr) + void TclExpandCodeArray(void *envPtr) } # These functions are vfs aware, but are generally only useful internally. @@ -676,14 +677,14 @@ declare 169 generic { int TclpUtfNcmp2(CONST char *s1, CONST char *s2, unsigned long n) } declare 170 generic { - int TclCheckInterpTraces (Tcl_Interp *interp, CONST char *command, int numChars, \ - Command *cmdPtr, int result, int traceFlags, int objc, \ - Tcl_Obj *CONST objv[]) + int TclCheckInterpTraces(Tcl_Interp *interp, CONST char *command, + int numChars, Command *cmdPtr, int result, int traceFlags, + int objc, Tcl_Obj *CONST objv[]) } declare 171 generic { - int TclCheckExecutionTraces (Tcl_Interp *interp, CONST char *command, int numChars, \ - Command *cmdPtr, int result, int traceFlags, int objc, \ - Tcl_Obj *CONST objv[]) + int TclCheckExecutionTraces(Tcl_Interp *interp, CONST char *command, + int numChars, Command *cmdPtr, int result, int traceFlags, + int objc, Tcl_Obj *CONST objv[]) } declare 172 generic { @@ -693,10 +694,17 @@ declare 172 generic { # added for 8.4.2 declare 173 generic { - int TclUniCharMatch (CONST Tcl_UniChar *string, int strLen, \ + int TclUniCharMatch(CONST Tcl_UniChar *string, int strLen, CONST Tcl_UniChar *pattern, int ptnLen, int nocase) } +# added for 8.4.3 + +declare 174 generic { + Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed) +} + ############################################################################## # Define the platform specific internal Tcl interface. These functions are @@ -708,13 +716,13 @@ interface tclIntPlat # Mac specific internals declare 0 mac { - VOID * TclpSysAlloc(long size, int isBin) + VOID *TclpSysAlloc(long size, int isBin) } declare 1 mac { void TclpSysFree(VOID *ptr) } declare 2 mac { - VOID * TclpSysRealloc(VOID *cp, unsigned int size) + VOID *TclpSysRealloc(VOID *cp, unsigned int size) } declare 3 mac { void TclpExit(int status) @@ -782,7 +790,7 @@ declare 17 mac { void TclMacRemoveTimer(void *timerToken) } declare 18 mac { - void * TclMacStartTimer(long ms) + void *TclMacStartTimer(long ms) } declare 19 mac { int TclMacTimerExpired(void *timerToken) @@ -790,22 +798,22 @@ declare 19 mac { declare 20 mac { int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, int insert) -} +} declare 21 mac { short TclMacUnRegisterResourceFork(char *tokenPtr, Tcl_Obj *resultPtr) -} +} declare 22 mac { int TclMacCreateEnv(void) } declare 23 mac { - FILE * TclMacFOpenHack(CONST char *path, CONST char *mode) + FILE *TclMacFOpenHack(CONST char *path, CONST char *mode) } # Replaced in 8.1 by TclpReadLink: # declare 24 mac { # int TclMacReadlink(char *path, char *buf, int size) # } declare 24 mac { - char * TclpGetTZName(int isdst) + char *TclpGetTZName(int isdst) } declare 25 mac { int TclMacChmod(CONST char *path, int mode) @@ -825,12 +833,12 @@ declare 1 win { void TclWinConvertWSAError(DWORD errCode) } declare 2 win { - struct servent * TclWinGetServByName(CONST char *nm, + struct servent *TclWinGetServByName(CONST char *nm, CONST char *proto) } declare 3 win { int TclWinGetSockOpt(SOCKET s, int level, int optname, - char FAR * optval, int FAR *optlen) + char FAR *optval, int FAR *optlen) } declare 4 win { HINSTANCE TclWinGetTclInstance(void) @@ -844,7 +852,7 @@ declare 6 win { } declare 7 win { int TclWinSetSockOpt(SOCKET s, int level, int optname, - CONST char FAR * optval, int optlen) + CONST char FAR *optval, int optlen) } declare 8 win { unsigned long TclpGetPid(Tcl_Pid pid) @@ -882,7 +890,7 @@ declare 15 win { # TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) # } # declare 17 win { -# char * TclpGetTZName(void) +# char *TclpGetTZName(void) # } declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) @@ -904,10 +912,10 @@ declare 22 win { TclFile TclpCreateTempFile(CONST char *contents) } declare 23 win { - char * TclpGetTZName(int isdst) + char *TclpGetTZName(int isdst) } declare 24 win { - char * TclWinNoBackslash(char *path) + char *TclWinNoBackslash(char *path) } declare 25 win { TclPlatformType *TclWinGetPlatform(void) @@ -919,7 +927,7 @@ declare 26 win { # Added in Tcl 8.3.3 / 8.4 declare 27 win { - void TclWinFlushDirtyChannels (void) + void TclWinFlushDirtyChannels(void) } # Added in 8.4.2 @@ -974,18 +982,14 @@ declare 9 unix { # Added in 8.4: declare 10 unix { - Tcl_DirEntry * TclpReaddir(DIR * dir) + Tcl_DirEntry *TclpReaddir(DIR *dir) } - declare 11 unix { - struct tm * TclpLocaltime(time_t * clock) + struct tm *TclpLocaltime(time_t *clock) } - declare 12 unix { - struct tm * TclpGmtime(time_t * clock) + struct tm *TclpGmtime(time_t *clock) } - declare 13 unix { - char * TclpInetNtoa(struct in_addr addr) + char *TclpInetNtoa(struct in_addr addr) } - diff --git a/generic/tclInt.h b/generic/tclInt.h index 5df729d..70b8106 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * 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.125 2003/04/22 23:20:43 andreas_kupries Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.126 2003/04/28 12:34:27 dkf Exp $ */ #ifndef _TCLINT @@ -2040,6 +2040,9 @@ EXTERN Tcl_Obj *TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, CONST long i, CONST int flags)); +EXTERN Tcl_Obj *TclPtrIncrWideVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, CONST char *part1, CONST char *part2, + CONST Tcl_WideInt i, CONST int flags)); /* *---------------------------------------------------------------- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index e41dca6..a35c504 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.49 2003/02/18 02:25:45 hobbs Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.50 2003/04/28 12:34:28 dkf Exp $ */ #ifndef _TCLINTDECLS @@ -378,9 +378,9 @@ EXTERN int Tcl_Import _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 128 */ -EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp* interp)); +EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp * interp)); /* 129 */ -EXTERN int Tcl_PushCallFrame _ANSI_ARGS_((Tcl_Interp* interp, +EXTERN int Tcl_PushCallFrame _ANSI_ARGS_((Tcl_Interp * interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 130 */ @@ -503,6 +503,11 @@ EXTERN int TclUniCharMatch _ANSI_ARGS_(( CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); +/* 174 */ +EXTERN Tcl_Obj * TclIncrWideVar2 _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, + Tcl_WideInt wideIncrAmount, + int part1NotParsed)); typedef struct TclIntStubs { int magic; @@ -660,8 +665,8 @@ typedef struct TclIntStubs { Tcl_Namespace * (*tcl_GetGlobalNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 125 */ void (*tcl_GetVariableFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr)); /* 126 */ int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 127 */ - void (*tcl_PopCallFrame) _ANSI_ARGS_((Tcl_Interp* interp)); /* 128 */ - int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */ + void (*tcl_PopCallFrame) _ANSI_ARGS_((Tcl_Interp * interp)); /* 128 */ + int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */ int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 130 */ void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */ int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */ @@ -706,6 +711,7 @@ typedef struct TclIntStubs { int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */ int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */ int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */ + Tcl_Obj * (*tclIncrWideVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)); /* 174 */ } TclIntStubs; #ifdef __cplusplus @@ -1316,6 +1322,10 @@ extern TclIntStubs *tclIntStubsPtr; #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ #endif +#ifndef TclIncrWideVar2 +#define TclIncrWideVar2 \ + (tclIntStubsPtr->tclIncrWideVar2) /* 174 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c424c07..df105fa 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.81 2003/04/05 01:26:11 dkf Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.82 2003/04/28 12:34:29 dkf Exp $ */ #include "tclInt.h" @@ -268,6 +268,7 @@ TclIntStubs tclIntStubs = { TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ + TclIncrWideVar2, /* 174 */ }; TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclVar.c b/generic/tclVar.c index 2d36e3a..aab35cc 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.71 2003/04/16 23:33:44 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.72 2003/04/28 12:34:31 dkf Exp $ */ #include "tclInt.h" @@ -1876,6 +1876,163 @@ TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) /* *---------------------------------------------------------------------- * + * TclIncrWideVar2 -- + * + * Given a two-part variable name, which may refer either to a scalar + * variable or an element of an array, increment the Tcl object value + * of the variable by a specified amount. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the specified variable doesn't exist, or there is a + * clash in array usage, or an error occurs while executing variable + * traces, then NULL is returned and a message will be left in + * the interpreter's result. + * + * Side effects: + * The value of the given variable is incremented by the specified + * amount. If either the array or the entry didn't exist then a new + * variable is created. The ref count for the returned object is _not_ + * incremented to reflect the returned reference; if you want to keep a + * reference to the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclIncrWideVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_WideInt incrAmount; /* Amount to be added to variable. */ + int flags; /* Various flags that tell how to incr value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ +{ + Var *varPtr, *arrayPtr; + char *part1, *part2; + + part1 = TclGetString(part1Ptr); + part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr)); + + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", + 0, 1, &arrayPtr); + if (varPtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + return TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, + incrAmount, flags); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrIncrWideVar -- + * + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a specified + * amount. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the specified variable doesn't exist, or there is a + * clash in array usage, or an error occurs while executing variable + * traces, then NULL is returned and a message will be left in + * the interpreter's result. + * + * Side effects: + * The value of the given variable is incremented by the specified + * amount. If either the array or the entry didn't exist then a new + * variable is created. The ref count for the returned object is _not_ + * incremented to reflect the returned reference; if you want to keep a + * reference to the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + Var *varPtr; + Var *arrayPtr; + CONST char *part1; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + CONST char *part2; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + CONST Tcl_WideInt incrAmount; + /* Amount to be added to variable. */ + CONST int flags; /* Various flags that tell how to incr value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ +{ + register Tcl_Obj *varValuePtr; + int createdNewObj; /* Set 1 if var's value object is shared + * so we must increment a copy (i.e. copy + * on write). */ + Tcl_WideInt wide; + + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); + + if (varValuePtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + + /* + * Increment the variable's value. If the object is unshared we can + * modify it directly, otherwise we must create a new copy to modify: + * this is "copy on write". Then free the variable's old string + * representation, if any, since it will no longer be valid. + */ + + createdNewObj = 0; + if (Tcl_IsShared(varValuePtr)) { + varValuePtr = Tcl_DuplicateObj(varValuePtr); + createdNewObj = 1; + } + if (varValuePtr->typePtr == &tclWideIntType) { + TclGetWide(wide, varValuePtr); + Tcl_SetWideIntObj(varValuePtr, wide + incrAmount); + } else if (varValuePtr->typePtr == &tclIntType) { + long i = varValuePtr->internalRep.longValue; + Tcl_SetWideIntObj(varValuePtr, Tcl_LongAsWide(i) + incrAmount); + } else { + /* + * Not an integer or wide internal-rep... + */ + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + Tcl_SetWideIntObj(varValuePtr, wide + incrAmount); + } + + /* + * Store the variable's new value and run any write traces. + */ + + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + varValuePtr, flags); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_UnsetVar -- * * Delete a variable, so that it may not be accessed anymore. diff --git a/tests/incr.test b/tests/incr.test index 5f3a633..309b757 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: incr.test,v 1.8 2003/02/07 01:07:05 mdejong Exp $ +# RCS: @(#) $Id: incr.test,v 1.9 2003/04/28 12:34:33 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -516,18 +516,16 @@ test incr-2.31 {incr command (compiled): bad increment} { invoked from within "incr x 1a"}} +test incr-3.1 {increment by wide amount: bytecode route} { + set x 0 + incr x 123123123123 +} 123123123123 +test incr-3.2 {increment by wide amount: command route} { + set z incr + set x 0 + $z x 123123123123 +} 123123123123 + # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - - |