summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclCmdIL.c379
-rw-r--r--generic/tclDictObj.c73
-rw-r--r--generic/tclExecute.c83
-rw-r--r--generic/tclInt.decls134
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclIntDecls.h20
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclVar.c159
-rw-r--r--tests/incr.test24
10 files changed, 578 insertions, 312 deletions
diff --git a/ChangeLog b/ChangeLog
index 6a2e9ab..f8c62ef 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
-
-
-
-
-
-
-
-
-
-
-
-
generated by cgit v0.12 at 2024-11-18 05:37:12 (GMT)