diff options
author | dgp <dgp@users.sourceforge.net> | 2005-08-19 05:17:47 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2005-08-19 05:17:47 (GMT) |
commit | 71a957f75b308d060c0fef727230abca9d9f9fd4 (patch) | |
tree | a3518cd114a116db4a8e673d45cf9ed174e76f2f | |
parent | 2d85aae311a521f058f675ea276215ec029e5b4a (diff) | |
download | tcl-71a957f75b308d060c0fef727230abca9d9f9fd4.zip tcl-71a957f75b308d060c0fef727230abca9d9f9fd4.tar.gz tcl-71a957f75b308d060c0fef727230abca9d9f9fd4.tar.bz2 |
[kennykb_numerics_branch]
* generic/tclVar.c: Replaced TclPtrIncrVar and TclPtrIncrWideVar
* generic/tclInt.h: with TclPtrIncrObjVar and replaced TclIncrVar2
* generic/tclInt.decls: and TclIncrWideVar2 with TclIncrObjVar2. New
routines call on TclIncrObj to do the work.
* generic/tclIntDecls.h: make genstubs
* generic/tclStubInit.c:
* generic/tclCmdIL.c: Rework Tcl_IncrObjCmd and the INST_*INCR*
* generic/tclExecute.c: opcodes to use the new routines.
-rw-r--r-- | ChangeLog | 15 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 19 | ||||
-rw-r--r-- | generic/tclExecute.c | 47 | ||||
-rw-r--r-- | generic/tclInt.decls | 18 | ||||
-rw-r--r-- | generic/tclInt.h | 11 | ||||
-rw-r--r-- | generic/tclIntDecls.h | 35 | ||||
-rw-r--r-- | generic/tclStubInit.c | 8 | ||||
-rw-r--r-- | generic/tclVar.c | 131 |
8 files changed, 234 insertions, 50 deletions
@@ -1,3 +1,18 @@ +2005-08-19 Don Porter <dgp@users.sourceforge.net> + + [kennykb_numerics_branch] + + * generic/tclVar.c: Replaced TclPtrIncrVar and TclPtrIncrWideVar + * generic/tclInt.h: with TclPtrIncrObjVar and replaced TclIncrVar2 + * generic/tclInt.decls: and TclIncrWideVar2 with TclIncrObjVar2. New + routines call on TclIncrObj to do the work. + + * generic/tclIntDecls.h: make genstubs + * generic/tclStubInit.c: + + * generic/tclCmdIL.c: Rework Tcl_IncrObjCmd and the INST_*INCR* + * generic/tclExecute.c: opcodes to use the new routines. + 2005-08-18 Don Porter <dgp@users.sourceforge.net> [kennykb_numerics_branch] diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 554706d..67add7c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,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.70.2.6 2005/08/02 18:15:13 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.70.2.7 2005/08/19 05:17:47 dgp Exp $ */ #include "tclInt.h" @@ -326,16 +326,19 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { +#if 0 long incrAmount = 1; Tcl_WideInt wideIncrAmount; - Tcl_Obj *newValuePtr; int isWide = 0; +#endif + Tcl_Obj *newValuePtr, *incrPtr; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); return TCL_ERROR; } +#if 0 /* * Calculate the amount to increment by. */ @@ -382,6 +385,18 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, TCL_LEAVE_ERR_MSG); } +#else + if (objc == 3) { + incrPtr = objv[2]; + } else { + incrPtr = Tcl_NewIntObj(1); + } + Tcl_IncrRefCount(incrPtr); + newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, + incrPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(incrPtr); + +#endif if (newValuePtr == NULL) { return TCL_ERROR; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index acbc0e1..9f2a8a3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -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: tclExecute.c,v 1.167.2.27 2005/08/18 21:19:17 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.167.2.28 2005/08/19 05:17:47 dgp Exp $ */ #include "tclInt.h" @@ -289,6 +289,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ +#if 0 /* * Macro to read a string containing either a wide or an int and decide which * it is while decoding it at the same time. This enforces the policy that @@ -299,7 +300,6 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never * generates an error message. * - * TODO: Eliminate */ #define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ @@ -309,7 +309,6 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; (objPtr)->internalRep.longValue = (longVar) \ = Tcl_WideAsLong(wideVar); \ } -#if 0 #define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \ &(wideVar)); \ @@ -2274,10 +2273,13 @@ TclExecuteByteCode(interp, codePtr) */ { - Tcl_Obj *objPtr; - int opnd, pcAdjustment, isWide; - long i; + Tcl_Obj *objPtr, *incrPtr; + int opnd, pcAdjustment; +#if 0 + int isWide; Tcl_WideInt w; +#endif + long i; char *part1, *part2; Var *varPtr, *arrayPtr; @@ -2287,6 +2289,7 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR_STK: case INST_INCR_STK: opnd = TclGetUInt1AtPtr(pc+1); +#if 0 objPtr = *tosPtr; if (objPtr->typePtr == &tclIntType) { i = objPtr->internalRep.longValue; @@ -2308,6 +2311,10 @@ TclExecuteByteCode(interp, codePtr) } tosPtr--; TclDecrRefCount(objPtr); +#else + incrPtr = *tosPtr; + tosPtr--; +#endif switch (*pc) { case INST_INCR_SCALAR1: pcAdjustment = 2; @@ -2324,7 +2331,12 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: i = TclGetInt1AtPtr(pc+1); +#if 0 isWide = 0; +#else + incrPtr = Tcl_NewIntObj(i); + Tcl_IncrRefCount(incrPtr); +#endif pcAdjustment = 2; doIncrStk: @@ -2348,6 +2360,7 @@ TclExecuteByteCode(interp, codePtr) "\n (reading value of variable to increment)", -1); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; + Tcl_DecrRefCount(incrPtr); goto checkForCatch; } cleanup = ((part2 == NULL)? 1 : 2); @@ -2356,7 +2369,12 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); i = TclGetInt1AtPtr(pc+2); +#if 0 isWide = 0; +#else + incrPtr = Tcl_NewIntObj(i); + Tcl_IncrRefCount(incrPtr); +#endif pcAdjustment = 3; doIncrArray: @@ -2372,6 +2390,7 @@ TclExecuteByteCode(interp, codePtr) if (varPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; + Tcl_DecrRefCount(incrPtr); goto checkForCatch; } cleanup = 1; @@ -2380,7 +2399,12 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); i = TclGetInt1AtPtr(pc+2); +#if 0 isWide = 0; +#else + incrPtr = Tcl_NewIntObj(i); + Tcl_IncrRefCount(incrPtr); +#endif pcAdjustment = 3; doIncrScalar: @@ -2395,6 +2419,7 @@ TclExecuteByteCode(interp, codePtr) TRACE(("%u %ld => ", opnd, i)); doIncrVar: +#if 0 objPtr = varPtr->value.objPtr; if (TclIsVarDirectReadable(varPtr) && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { @@ -2443,12 +2468,22 @@ TclExecuteByteCode(interp, codePtr) part2, i, TCL_LEAVE_ERR_MSG); } CACHE_STACK_INFO(); +#else + /* TODO: Restore no trace optimization */ + DECACHE_STACK_INFO(); + objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, + incrPtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + Tcl_DecrRefCount(incrPtr); +#endif if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; goto checkForCatch; } +#if 0 doneIncr: +#endif 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 124fee2..c83dca0 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.84.2.9 2005/08/15 20:46:02 dgp Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.84.2.10 2005/08/19 05:17:48 dgp Exp $ library tcl @@ -210,10 +210,10 @@ declare 46 generic { # Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, # long incrAmount) #} -declare 49 generic { - Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) -} +#declare 49 generic { +# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, +# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) +#} declare 50 generic { void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr) @@ -709,10 +709,10 @@ declare 173 generic { # 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) -} +#declare 174 generic { +# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, +# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed) +#} # Factoring out of trace code diff --git a/generic/tclInt.h b/generic/tclInt.h index 1316104..b340efa 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.202.2.22 2005/08/18 18:18:46 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.202.2.23 2005/08/19 05:17:48 dgp Exp $ */ #ifndef _TCLINT @@ -1996,6 +1996,9 @@ MODULE_SCOPE int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, int globFlags, Tcl_GlobTypeData* types)); MODULE_SCOPE int TclIncrObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr)); +MODULE_SCOPE Tcl_Obj * TclIncrObjVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + Tcl_Obj *incrPtr, int flags)); MODULE_SCOPE void TclInitAlloc _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitDbCkalloc _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitDoubleConversion _ANSI_ARGS_((void)); @@ -2532,6 +2535,11 @@ MODULE_SCOPE Tcl_Obj * TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, Tcl_Obj *newValuePtr, CONST int flags)); +MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar _ANSI_ARGS_((Tcl_Interp *interp, + Var *varPtr, Var *arrayPtr, CONST char *part1, + CONST char *part2, Tcl_Obj *incrPtr, + CONST int flags)); +#if 0 MODULE_SCOPE Tcl_Obj * TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, CONST long i, CONST int flags)); @@ -2539,6 +2547,7 @@ MODULE_SCOPE 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)); +#endif MODULE_SCOPE void TclInvalidateNsPath _ANSI_ARGS_((Namespace *nsPtr)); /* diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 66cbd48..3a424fe 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -12,9 +12,9 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * <<<<<<< tclIntDecls.h - * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.9 2005/08/15 20:46:02 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.10 2005/08/19 05:17:48 dgp Exp $ ======= - * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.9 2005/08/15 20:46:02 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.10 2005/08/19 05:17:48 dgp Exp $ >>>>>>> 1.83 */ @@ -275,13 +275,7 @@ EXTERN int TclInExit _ANSI_ARGS_((void)); #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ -#ifndef TclIncrVar2_TCL_DECLARED -#define TclIncrVar2_TCL_DECLARED -/* 49 */ -EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, - long incrAmount, int part1NotParsed)); -#endif +/* Slot 49 is reserved */ #ifndef TclInitCompiledLocals_TCL_DECLARED #define TclInitCompiledLocals_TCL_DECLARED /* 50 */ @@ -871,14 +865,7 @@ EXTERN int TclUniCharMatch _ANSI_ARGS_(( CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); #endif -#ifndef TclIncrWideVar2_TCL_DECLARED -#define TclIncrWideVar2_TCL_DECLARED -/* 174 */ -EXTERN Tcl_Obj * TclIncrWideVar2 _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, - Tcl_WideInt wideIncrAmount, - int part1NotParsed)); -#endif +/* Slot 174 is reserved */ #ifndef TclCallVarTraces_TCL_DECLARED #define TclCallVarTraces_TCL_DECLARED /* 175 */ @@ -1166,7 +1153,7 @@ typedef struct TclIntStubs { int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */ void *reserved47; void *reserved48; - Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */ + void *reserved49; void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */ int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */ void *reserved52; @@ -1296,7 +1283,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 */ + void *reserved174; int (*tclCallVarTraces) _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg)); /* 175 */ void (*tclCleanupVar) _ANSI_ARGS_((Var * varPtr, Var * arrayPtr)); /* 176 */ void (*tclVarErrMsg) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * operation, CONST char * reason)); /* 177 */ @@ -1519,10 +1506,7 @@ extern TclIntStubs *tclIntStubsPtr; #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ -#ifndef TclIncrVar2 -#define TclIncrVar2 \ - (tclIntStubsPtr->tclIncrVar2) /* 49 */ -#endif +/* Slot 49 is reserved */ #ifndef TclInitCompiledLocals #define TclInitCompiledLocals \ (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ @@ -1925,10 +1909,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ #endif -#ifndef TclIncrWideVar2 -#define TclIncrWideVar2 \ - (tclIntStubsPtr->tclIncrWideVar2) /* 174 */ -#endif +/* Slot 174 is reserved */ #ifndef TclCallVarTraces #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c97c856..729173a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -9,9 +9,9 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * <<<<<<< tclStubInit.c - * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.12 2005/08/15 20:46:02 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.13 2005/08/19 05:17:48 dgp Exp $ ======= - * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.12 2005/08/15 20:46:02 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.13 2005/08/19 05:17:48 dgp Exp $ >>>>>>> 1.121 */ @@ -132,7 +132,7 @@ TclIntStubs tclIntStubs = { TclInExit, /* 46 */ NULL, /* 47 */ NULL, /* 48 */ - TclIncrVar2, /* 49 */ + NULL, /* 49 */ TclInitCompiledLocals, /* 50 */ TclInterpInit, /* 51 */ NULL, /* 52 */ @@ -262,7 +262,7 @@ TclIntStubs tclIntStubs = { TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ - TclIncrWideVar2, /* 174 */ + NULL, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ diff --git a/generic/tclVar.c b/generic/tclVar.c index 27823e8..d3913d7 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.99.2.7 2005/08/02 18:16:12 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.99.2.8 2005/08/19 05:17:48 dgp Exp $ */ #include "tclInt.h" @@ -1718,6 +1718,7 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) } return resultPtr; } +#if 0 /* *---------------------------------------------------------------------- @@ -1881,6 +1882,133 @@ TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, varValuePtr, flags); } +#endif + +/* + *---------------------------------------------------------------------- + * + * TclIncrObjVar2 -- + * + * 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 Tcl_Obj increment value. + * + * 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 * +TclIncrObjVar2(interp, part1Ptr, part2Ptr, incrPtr, 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_Obj *incrPtr; /* 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 TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, + incrPtr, flags); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrIncrObjVar -- + * + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a Tcl_Obj increment. + * + * 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 * +TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, incrPtr, 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. */ + Tcl_Obj *incrPtr; /* Increment value */ +/* TODO: Which of these flag values really make sense? */ + 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, *newValuePtr = NULL; + int code; + + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); + if (varValuePtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + if (Tcl_IsShared(varValuePtr)) { + varValuePtr = Tcl_DuplicateObj(varValuePtr); + } + code = TclIncrObj(interp, varValuePtr, incrPtr); + Tcl_IncrRefCount(varValuePtr); + if (code == TCL_OK) { + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + varValuePtr, flags); + } + Tcl_DecrRefCount(varValuePtr); + return newValuePtr; +} +#if 0 /* *---------------------------------------------------------------------- @@ -2038,6 +2166,7 @@ TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, varValuePtr, flags); } +#endif /* *---------------------------------------------------------------------- |