diff options
author | Miguel Sofer <miguel.sofer@gmail.com> | 2002-07-17 10:36:21 (GMT) |
---|---|---|
committer | Miguel Sofer <miguel.sofer@gmail.com> | 2002-07-17 10:36:21 (GMT) |
commit | 239854b80c97ffda9f1300635a18bfb1350c1e53 (patch) | |
tree | 4d1cb86aa902e81bdefccdaf0a4fd9875459360e /generic | |
parent | c5f54ca90775a8e1f51e53d2a87a5898b613a90f (diff) | |
download | tcl-239854b80c97ffda9f1300635a18bfb1350c1e53.zip tcl-239854b80c97ffda9f1300635a18bfb1350c1e53.tar.gz tcl-239854b80c97ffda9f1300635a18bfb1350c1e53.tar.bz2 |
variable access optimisations
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclExecute.c | 650 | ||||
-rw-r--r-- | generic/tclInt.h | 26 | ||||
-rw-r--r-- | generic/tclVar.c | 2016 |
3 files changed, 1439 insertions, 1253 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 024509e..c7538b5 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.77 2002/07/16 01:12:50 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.78 2002/07/17 10:36:22 msofer Exp $ */ #include "tclInt.h" @@ -174,14 +174,14 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #define NEXT_INST_V(pcAdjustment, nCleanup, result) \ pc += (pcAdjustment);\ + cleanup = (nCleanup);\ if (result) {\ if ((result) > 0) {\ Tcl_IncrRefCount(objResultPtr);\ }\ - cleanup = (nCleanup);\ goto cleanupV_pushObjResultPtr;\ } else {\ - panic("ERROR: bad usage of macro NEXT_INST_V");\ + goto cleanupV;\ } @@ -1054,15 +1054,19 @@ TclExecuteByteCode(interp, codePtr) int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif - Tcl_Obj *valuePtr, *value2Ptr, *objPtr, *elemPtr; + Tcl_Obj *valuePtr, *value2Ptr, *objPtr; char *bytes; int length; long i = 0; /* Init. avoids compiler warning. */ #ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; #endif - int cleanup; + register int cleanup; Tcl_Obj *objResultPtr; +// + char *part1, *part2; + Var *varPtr, *arrayPtr; + CallFrame *varFramePtr = iPtr->varFramePtr; /* * This procedure uses a stack to hold information about catch commands. @@ -1127,6 +1131,9 @@ TclExecuteByteCode(interp, codePtr) cleanupV_pushObjResultPtr: switch (cleanup) { + case 0: + PUSH_OBJECT(objResultPtr); + goto cleanup0; default: cleanup -= 2; while (cleanup--) { @@ -1145,13 +1152,24 @@ TclExecuteByteCode(interp, codePtr) stackPtr[stackTop] = objResultPtr; goto cleanup0; - cleanup2: - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - - cleanup1: - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); + cleanupV: + switch (cleanup) { + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 0: + } cleanup0: @@ -1420,66 +1438,93 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); NEXT_INST_F(1, 1, -1); /* already has right refct */ + /* + * --------------------------------------------------------- + * Start of INST_LOAD instructions. + * + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. + */ + case INST_LOAD_SCALAR1: opnd = TclGetUInt1AtPtr(pc+1); - DECACHE_STACK_INFO(); - objResultPtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%u => ERROR: ", opnd), - Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; } - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_F(2, 0, 1); + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL)) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_F(2, 0, 1); + } + pcAdjustment = 2; + cleanup = 0; + arrayPtr = NULL; + part2 = NULL; + goto doCallPtrGetVar; case INST_LOAD_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); - DECACHE_STACK_INFO(); - objResultPtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%u => ERROR: ", opnd), Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; } - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_F(5, 0, 1); + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL)) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_F(5, 0, 1); + } + pcAdjustment = 5; + cleanup = 0; + arrayPtr = NULL; + part2 = NULL; + goto doCallPtrGetVar; case INST_LOAD_ARRAY_STK: - elemPtr = stackPtr[stackTop]; /* element name */ + cleanup = 2; + part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */ objPtr = stackPtr[stackTop-1]; /* array name */ goto doLoadStk; case INST_LOAD_STK: case INST_LOAD_SCALAR_STK: - elemPtr = NULL; + cleanup = 1; + part2 = NULL; objPtr = stackPtr[stackTop]; /* variable name */ doLoadStk: - DECACHE_STACK_INFO(); - objResultPtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - if (elemPtr != NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", - O2S(objPtr), O2S(elemPtr)), Tcl_GetObjResult(interp)); - } else { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - } + part1 = TclGetString(objPtr); + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "read", + /*createPart1*/ 0, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { result = TCL_ERROR; goto checkForCatch; } - if (elemPtr != NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ", - O2S(objPtr), O2S(elemPtr)), objResultPtr); - NEXT_INST_F(1, 2, 1); - } else { - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), objResultPtr); - NEXT_INST_F(1, 1, 1); + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + NEXT_INST_V(1, cleanup, 1); } + pcAdjustment = 1; + goto doCallPtrGetVar; case INST_LOAD_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -1489,147 +1534,115 @@ TclExecuteByteCode(interp, codePtr) case INST_LOAD_ARRAY1: opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; - + doLoadArray: - elemPtr = stackPtr[stackTop]; - - DECACHE_STACK_INFO(); - objResultPtr = TclGetElementOfIndexedArray(interp, opnd, - elemPtr, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", - opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); + part2 = TclGetString(stackPtr[stackTop]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + if (varPtr == NULL) { result = TCL_ERROR; goto checkForCatch; } - TRACE_WITH_OBJ(("%u \"%.30s\" => ", - opnd, O2S(elemPtr)), objResultPtr); - NEXT_INST_F(pcAdjustment, 1, 1); - - case INST_LAPPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); - goto doStoreScalar; - - case INST_LAPPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); - goto doStoreScalar; - - case INST_APPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreScalar; - - case INST_APPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreScalar; - - case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = TCL_LEAVE_ERR_MSG; - goto doStoreScalar; + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + NEXT_INST_F(pcAdjustment, 1, 1); + } + cleanup = 1; + goto doCallPtrGetVar; - case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = TCL_LEAVE_ERR_MSG; + doCallPtrGetVar: + /* + * There are either errors or the variable is traced: + * call TclPtrGetVar to process fully. + */ - doStoreScalar: - valuePtr = stackPtr[stackTop]; DECACHE_STACK_INFO(); - objResultPtr = TclSetIndexedScalar(interp, opnd, valuePtr, storeFlags); + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, + part2, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", - opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); result = TCL_ERROR; goto checkForCatch; } - TRACE_WITH_OBJ(("%u <- \"%.30s\" => ", - opnd, O2S(valuePtr)), objResultPtr); + NEXT_INST_V(pcAdjustment, cleanup, 1); - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_F((pcAdjustment+1), 1, 0); - } - NEXT_INST_F(pcAdjustment, 1, 1); + /* + * End of INST_LOAD instructions. + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- + * Start of INST_STORE and related instructions. + * + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. + */ case INST_LAPPEND_STK: valuePtr = stackPtr[stackTop]; /* value to append */ - elemPtr = NULL; + part2 = NULL; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT | TCL_TRACE_READS); goto doStoreStk; case INST_LAPPEND_ARRAY_STK: valuePtr = stackPtr[stackTop]; /* value to append */ - elemPtr = stackPtr[stackTop - 1]; + part2 = TclGetString(stackPtr[stackTop - 1]); storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT | TCL_TRACE_READS); goto doStoreStk; case INST_APPEND_STK: valuePtr = stackPtr[stackTop]; /* value to append */ - elemPtr = NULL; + part2 = NULL; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreStk; case INST_APPEND_ARRAY_STK: valuePtr = stackPtr[stackTop]; /* value to append */ - elemPtr = stackPtr[stackTop - 1]; + part2 = TclGetString(stackPtr[stackTop - 1]); storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreStk; case INST_STORE_ARRAY_STK: valuePtr = stackPtr[stackTop]; - elemPtr = stackPtr[stackTop - 1]; + part2 = TclGetString(stackPtr[stackTop - 1]); storeFlags = TCL_LEAVE_ERR_MSG; goto doStoreStk; case INST_STORE_STK: case INST_STORE_SCALAR_STK: valuePtr = stackPtr[stackTop]; - elemPtr = NULL; + part2 = NULL; storeFlags = TCL_LEAVE_ERR_MSG; doStoreStk: - objPtr = stackPtr[stackTop - 1 - (elemPtr != NULL)]; /* variable name */ - DECACHE_STACK_INFO(); - objResultPtr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, storeFlags); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - if (elemPtr != NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", - O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - } else { - TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", - O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - } + objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */ + part1 = TclGetString(objPtr); + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "set", + /*createPart1*/ 1, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { result = TCL_ERROR; goto checkForCatch; } - if (elemPtr != NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ", - O2S(objPtr), O2S(elemPtr), O2S(objResultPtr)), objResultPtr); - NEXT_INST_V(1, 3, 1); - } else { - TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", - O2S(objPtr), O2S(valuePtr)), objResultPtr); - if (*(pc+1) == INST_POP) { - NEXT_INST_F(2, 2, 0); - } - NEXT_INST_F(1, 2, 1); - } + cleanup = ((part2 == NULL)? 2 : 3); + pcAdjustment = 1; + goto doCallPtrSetVar; case INST_LAPPEND_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -1670,35 +1683,128 @@ TclExecuteByteCode(interp, codePtr) doStoreArray: valuePtr = stackPtr[stackTop]; - elemPtr = stackPtr[stackTop - 1]; - DECACHE_STACK_INFO(); - objResultPtr = TclSetElementOfIndexedArray(interp, opnd, - elemPtr, valuePtr, storeFlags); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", - opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); + part2 = TclGetString(stackPtr[stackTop - 1]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr); + if (varPtr == NULL) { result = TCL_ERROR; goto checkForCatch; } - TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ", - opnd, O2S(elemPtr), O2S(valuePtr)), objResultPtr); + cleanup = 2; + goto doCallPtrSetVar; + + case INST_LAPPEND_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreScalar; + case INST_LAPPEND_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreScalar; + + case INST_APPEND_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreScalar; + + case INST_APPEND_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreScalar; + + case INST_STORE_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreScalar; + + case INST_STORE_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = TCL_LEAVE_ERR_MSG; + + doStoreScalar: + valuePtr = stackPtr[stackTop]; + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + cleanup = 1; + arrayPtr = NULL; + part2 = NULL; + + doCallPtrSetVar: + if ((storeFlags == TCL_LEAVE_ERR_MSG) + && !((varPtr->flags & VAR_IN_HASHTABLE) + && (varPtr->hPtr == NULL)) + && (varPtr->tracePtr == NULL) + && (TclIsVarScalar(varPtr) + || TclIsVarUndefined(varPtr)) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { + /* + * No traces, no errors, plain 'set': we can safely inline. + * The value *will* be set to what's requested, so that + * the stack top remains pointing to the same Tcl_Obj. + */ + valuePtr = varPtr->value.objPtr; + objResultPtr = stackPtr[stackTop]; + if (valuePtr != objResultPtr) { + if (valuePtr != NULL) { + TclDecrRefCount(valuePtr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = objResultPtr; + Tcl_IncrRefCount(objResultPtr); + } + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } + NEXT_INST_V(pcAdjustment, cleanup, 1); + } else { + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, + part1, part2, valuePtr, storeFlags); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + result = TCL_ERROR; + goto checkForCatch; + } + } if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_F((pcAdjustment+1), 2, 0); + NEXT_INST_V((pcAdjustment+1), cleanup, 0); } - NEXT_INST_F(pcAdjustment, 2, 1); + NEXT_INST_V(pcAdjustment, cleanup, 1); - case INST_LIST: - /* - * Pop the opnd (objc) top stack elements into a new list obj - * and then decrement their ref counts. - */ - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)])); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 1); + /* + * End of INST_STORE and related instructions. + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- + * Start of INST_INCR instructions. + * + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. + */ case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: @@ -1736,26 +1842,32 @@ TclExecuteByteCode(interp, codePtr) goto doIncrStk; } - case INST_INCR_SCALAR1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); - pcAdjustment = 3; - - doIncrScalar: - DECACHE_STACK_INFO(); - objResultPtr = TclIncrIndexedScalar(interp, opnd, i); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i), Tcl_GetObjResult(interp)); + case INST_INCR_ARRAY_STK_IMM: + case INST_INCR_SCALAR_STK_IMM: + case INST_INCR_STK_IMM: + i = TclGetInt1AtPtr(pc+1); + pcAdjustment = 2; + + doIncrStk: + if ((*pc == INST_INCR_ARRAY_STK_IMM) + || (*pc == INST_INCR_ARRAY_STK)) { + part2 = TclGetString(stackPtr[stackTop]); + objPtr = stackPtr[stackTop - 1]; + } else { + part2 = NULL; + objPtr = stackPtr[stackTop]; + } + part1 = TclGetString(objPtr); + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr); + if (varPtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); result = TCL_ERROR; goto checkForCatch; } - TRACE_WITH_OBJ(("%u %ld => ", opnd, i), objResultPtr); - - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_F((pcAdjustment+1), 0, 0); - } - NEXT_INST_F(pcAdjustment, 0, 1); + cleanup = ((part2 == NULL)? 1 : 2); + goto doIncrVar; case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); @@ -1763,66 +1875,82 @@ TclExecuteByteCode(interp, codePtr) pcAdjustment = 3; doIncrArray: - elemPtr = stackPtr[stackTop]; - DECACHE_STACK_INFO(); - objResultPtr = TclIncrElementOfIndexedArray(interp, opnd, elemPtr, i); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", - opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); + part2 = TclGetString(stackPtr[stackTop]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + if (varPtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); result = TCL_ERROR; goto checkForCatch; } - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", - opnd, O2S(elemPtr), i), objResultPtr); + cleanup = 1; + goto doIncrVar; - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_F((pcAdjustment+1), 1, 0); - } - NEXT_INST_F(pcAdjustment, 1, 1); - - case INST_INCR_ARRAY_STK_IMM: - case INST_INCR_SCALAR_STK_IMM: - case INST_INCR_STK_IMM: - i = TclGetInt1AtPtr(pc+1); - pcAdjustment = 2; - - doIncrStk: - if ((*pc == INST_INCR_ARRAY_STK_IMM) - || (*pc == INST_INCR_ARRAY_STK)) { - elemPtr = stackPtr[stackTop]; - objPtr = stackPtr[stackTop - 1]; - } else { - elemPtr = NULL; - objPtr = stackPtr[stackTop]; + case INST_INCR_SCALAR1_IMM: + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); + pcAdjustment = 3; + + doIncrScalar: + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; } - DECACHE_STACK_INFO(); - objResultPtr = TclIncrVar2(interp, objPtr, elemPtr, i, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - if (elemPtr != NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(objPtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); + arrayPtr = NULL; + part2 = NULL; + cleanup = 0; + + doIncrVar: + objPtr = varPtr->value.objPtr; + if (TclIsVarScalar(varPtr) + && !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. + */ + + i += objPtr->internalRep.longValue; + if (Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewLongObj(i); + TclDecrRefCount(objPtr); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; } else { - TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ", - O2S(objPtr), i), Tcl_GetObjResult(interp)); + Tcl_SetLongObj(objPtr, i); + objResultPtr = objPtr; } - result = TCL_ERROR; - goto checkForCatch; - } - if (elemPtr != NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(elemPtr), i), objResultPtr); - NEXT_INST_F(pcAdjustment, 2, 1); } else { - TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i), objResultPtr); - NEXT_INST_F(pcAdjustment, 1, 1); + DECACHE_STACK_INFO(); + objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, + part2, i, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + result = TCL_ERROR; + goto checkForCatch; + } } - + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } + NEXT_INST_V(pcAdjustment, cleanup, 1); + /* - * END INCR INSTRUCTIONS + * End of INST_INCR instructions. + * --------------------------------------------------------- */ + case INST_JUMP1: opnd = TclGetInt1AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, @@ -2006,6 +2134,22 @@ TclExecuteByteCode(interp, codePtr) } } + /* + * --------------------------------------------------------- + * Start of INST_LIST and related instructions. + */ + + case INST_LIST: + /* + * Pop the opnd (objc) top stack elements into a new list obj + * and then decrement their ref counts. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)])); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + case INST_LIST_LENGTH: valuePtr = stackPtr[stackTop]; @@ -2166,6 +2310,11 @@ TclExecuteByteCode(interp, codePtr) TRACE(("=> %s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); + /* + * End of INST_LIST and related instructions. + * --------------------------------------------------------- + */ + case INST_STR_EQ: case INST_STR_NEQ: { @@ -3679,19 +3828,40 @@ TclExecuteByteCode(interp, codePtr) } varIndex = varListPtr->varIndexes[j]; - DECACHE_STACK_INFO(); - value2Ptr = TclSetIndexedScalar(interp, - varIndex, valuePtr, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", - opnd, varIndex), - Tcl_GetObjResult(interp)); - if (setEmptyStr) { - TclDecrRefCount(valuePtr); + varPtr = &(varFramePtr->compiledLocals[varIndex]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) + && (varPtr->tracePtr == NULL) + && (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", + opnd, varIndex), + Tcl_GetObjResult(interp)); + if (setEmptyStr) { + TclDecrRefCount(valuePtr); + } + result = TCL_ERROR; + goto checkForCatch; } - result = TCL_ERROR; - goto checkForCatch; } valIndex++; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 7eac73d..3fca93b 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.100 2002/07/16 16:38:41 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.101 2002/07/17 10:36:23 msofer Exp $ */ #ifndef _TCLINT @@ -2058,6 +2058,30 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* + * Functions defined in generic/tclVar.c and currenttly exported only + * for use by the bytecode compiler and engine. Some of these could later + * be placed in the public interface. + */ + +EXTERN Var * TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *arrayName, CONST char *elName, CONST int flags, + CONST char *msg, CONST int createPart1, + CONST int createPart2, Var *arrayPtr)); +EXTERN Var * TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, CONST char *part2, int flags, + CONST char *msg, CONST int createPart1, + CONST int createPart2, Var **arrayPtrPtr)); +EXTERN Tcl_Obj *TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, char *part1, CONST char *part2, + CONST int flags)); +EXTERN Tcl_Obj *TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, char *part1, CONST char *part2, + Tcl_Obj *newValuePtr, CONST int flags)); +EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, char *part1, CONST char *part2, + CONST long i, CONST int flags)); + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. diff --git a/generic/tclVar.c b/generic/tclVar.c index 487edc6..d8c9aad 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.56 2002/07/16 16:29:07 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.57 2002/07/17 10:36:23 msofer Exp $ */ #include "tclInt.h" @@ -68,33 +68,15 @@ static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp, /* - * Functions defined in this file and currently only used here and by the - * bytecode compiler and engine. Some of these could later be placed - * in the public interface. + * Functions defined in this file that may be exported in the future + * for use by the bytecode compiler and engine or to the public interface. */ -Var * TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *arrayName, CONST char *elName, CONST int flags, - CONST char *msg, CONST int createPart1, - CONST int createPart2, Var *arrayPtr)); Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp, CONST char *varName, int flags, CONST int create, CONST char **errMsgPtr, int *indexPtr)); -Var * TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *part1Ptr, CONST char *part2, int flags, - CONST char *msg, CONST int createPart1, - CONST int createPart2, Var **arrayPtrPtr)); int TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *part1Ptr, CONST char *part2, int flags)); -Tcl_Obj * TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, - Var *arrayPtr, char *part1, CONST char *part2, - CONST int flags)); -Tcl_Obj * TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, - Var *arrayPtr, char *part1, CONST char *part2, - Tcl_Obj *newValuePtr, CONST int flags)); -Tcl_Obj * TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, - Var *arrayPtr, char *part1, CONST char *part2, - CONST long i, CONST int flags)); static Tcl_FreeInternalRepProc FreeLocalVarName; static Tcl_DupInternalRepProc DupLocalVarName; @@ -1232,283 +1214,6 @@ TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags) /* *---------------------------------------------------------------------- * - * TclGetIndexedScalar -- - * - * Return the Tcl object value of a local scalar variable in the active - * procedure, given its index in the procedure's array of compiler - * allocated local variables. - * - * Results: - * The return value points to the current object value of the variable - * given by localIndex. 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 if TCL_LEAVE_ERR_MSG is set in flags. - * - * Side effects: - * 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 * -TclGetIndexedScalar(interp, localIndex, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - register int localIndex; /* Index of variable in procedure's array - * of local variables. */ - int flags; /* TCL_LEAVE_ERR_MSG if to leave an error - * message in interpreter's result on an error. - * Otherwise no error message is left. */ -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - register Var *varPtr; /* Points to the variable's in-frame Var - * structure. */ - char *varName; /* Name of the local variable. */ - CONST char *msg; - -#ifdef TCL_COMPILE_DEBUG - int localCt = varFramePtr->procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get "); - fprintf(stderr, "local %i in frame 0x%x, ", localIndex, - (unsigned int) varFramePtr); - fprintf(stderr, "no compiled locals\n"); - panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get "); - fprintf(stderr, "local %i in frame 0x%x " localIndex, - (unsigned int) varFramePtr); - fprintf(stderr, "with %i locals\n", localCt); - panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - varPtr = &(compiledLocals[localIndex]); - varName = varPtr->name; - - /* - * If varPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - /* - * Invoke any traces that have been set for the variable. - */ - - if (varPtr->tracePtr != NULL) { - if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, - NULL, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { - return NULL; - } - } - - /* - * Make sure we're dealing with a scalar variable and not an array, and - * that the variable exists (isn't undefined). - */ - - if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) { - if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarArray(varPtr)) { - msg = isArray; - } else { - msg = noSuchVar; - } - VarErrMsg(interp, varName, NULL, "read", msg); - } - return NULL; - } - return varPtr->value.objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetElementOfIndexedArray -- - * - * Return the Tcl object value for an element in a local array - * variable. The element is named by the object elemPtr while the - * array is specified by its index in the active procedure's array - * of compiler allocated local variables. - * - * Results: - * The return value points to the current object value of the - * element. If the specified array or element 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 if TCL_LEAVE_ERR_MSG is set in flags. - * - * Side effects: - * 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 * -TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to get in the array. */ - int flags; /* TCL_LEAVE_ERR_MSG if to leave an error - * message in interpreter's result on an error. - * Otherwise no error message is left. */ -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - Var *arrayPtr; /* Points to the array's in-frame Var - * structure. */ - char *arrayName; /* Name of the local array. */ - Tcl_HashEntry *hPtr; - Var *varPtr = NULL; /* Points to the element's Var structure - * that we return. Initialized to avoid - * compiler warning. */ - CONST char *elem, *msg; - int new; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element "); - fprintf(stderr, "of local %i in frame 0x%x, " localIndex, - (unsigned int) varFramePtr); - fprintf(stderr, "no compiled locals\n"); - panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get element of " - "local %i in frame 0x%x with %i locals\n", localIndex, - (unsigned int) varFramePtr, localCt); - panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - elem = TclGetString(elemPtr); - arrayPtr = &(compiledLocals[localIndex]); - arrayName = arrayPtr->name; - - /* - * If arrayPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - - /* - * Make sure we're dealing with an array and that the array variable - * exists (isn't undefined). - */ - - if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, arrayName, elem, "read", noSuchVar); - } - goto errorReturn; - } - - /* - * Look up the element. Note that we must create the element (but leave - * it marked undefined) if it does not already exist. This allows a - * trace to create new array elements "on the fly" that did not exist - * before. A trace is always passed a variable for the array element. If - * the trace does not define the variable, it will be deleted below (at - * errorReturn) and an error returned. - */ - - hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); - if (new) { - if (arrayPtr->searchPtr != NULL) { - DeleteSearches(arrayPtr); - } - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varFramePtr->nsPtr; - TclSetVarArrayElement(varPtr); - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } - - /* - * Invoke any traces that have been set for the element variable. - */ - - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { - goto errorReturn; - } - } - - /* - * Return the element if it's an existing scalar variable. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarArray(varPtr)) { - msg = isArray; - } else { - msg = noSuchVar; - } - VarErrMsg(interp, arrayName, elem, "read", msg); - } - - /* - * An error. If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. - */ - - errorReturn: - if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); /* the array is not in a hashtable */ - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetObjCmd -- * * This procedure is invoked to process the "set" Tcl command. @@ -1976,511 +1681,6 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) /* *---------------------------------------------------------------------- * - * TclSetIndexedScalar -- - * - * Change the Tcl object value of a local scalar variable in the active - * procedure, given its compile-time allocated index in the procedure's - * array of local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * variable given by localIndex. 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 if flags has TCL_LEAVE_ERR_MSG. - * Note that the returned object may not be the same one referenced by - * newValuePtr; this is because variable traces may modify the - * variable's value. - * - * Side effects: - * The value of the given variable is set. The reference count is - * decremented for any old value of the variable and incremented for - * its new value. If as a result of a variable trace the new value for - * the variable is not the same one referenced by newValuePtr, then - * newValuePtr's ref count is left unchanged. 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. This procedure does not create - * new variables, but only sets those recognized at compile time. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclSetIndexedScalar(interp, localIndex, newValuePtr, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ - int localIndex; /* Index of variable in procedure's array - * of local variables. */ - Tcl_Obj *newValuePtr; /* New value for variable. */ - int flags; /* Various flags that tell how to set value: - * any of TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - register Var *varPtr; /* Points to the variable's in-frame Var - * structure. */ - char *varName; /* Name of the local variable. */ - Tcl_Obj *oldValuePtr; - Tcl_Obj *resultPtr = NULL; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set "); - fprintf(stderr, "local %i in ", localIndex); - fprintf(stderr, "frame 0x%x, no compiled locals\n", - (unsigned int) varFramePtr); - panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set "); - fprintf(stderr, "local %i in " localIndex); - fprintf(stderr, "frame 0x%x with %i locals\n", - (unsigned int) varFramePtr, localCt); - panic("TclSetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - varPtr = &(compiledLocals[localIndex]); - varName = varPtr->name; - - /* - * If varPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - /* - * Invoke any read traces that have been set for the variable if it - * is requested; this is only done in the core when lappending. - */ - - if ((flags & TCL_TRACE_READS) && (varPtr->tracePtr != NULL)) { - if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, - NULL, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { - return NULL; - } - } - - /* - * If the variable is in a hashtable and its hPtr field is NULL, then we - * may have an upvar to an array element where the array was deleted - * or an upvar to a namespace variable whose namespace was deleted. - * Generate an error (allowing the variable to be reset would screw up - * our storage allocation and is meaningless anyway). - */ - - if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { - if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarArrayElement(varPtr)) { - VarErrMsg(interp, varName, NULL, "set", danglingElement); - } else { - VarErrMsg(interp, varName, NULL, "set", danglingVar); - } - } - return NULL; - } - - /* - * It's an error to try to set an array variable itself. - */ - - if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, varName, NULL, "set", isArray); - } - return NULL; - } - - /* - * Set the variable's new value and discard its old value. - */ - - oldValuePtr = varPtr->value.objPtr; - if (flags & TCL_APPEND_VALUE) { - if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { - Tcl_DecrRefCount(oldValuePtr); /* discard old value */ - varPtr->value.objPtr = NULL; - oldValuePtr = NULL; - } - if (flags & TCL_LIST_ELEMENT) { /* append list element */ - if (oldValuePtr == NULL) { - TclNewObj(oldValuePtr); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ - } else if (Tcl_IsShared(oldValuePtr)) { - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - Tcl_DecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ - } - if (Tcl_ListObjAppendElement(interp, oldValuePtr, - newValuePtr) != TCL_OK) { - return NULL; - } - } else { /* append string */ - /* - * We append newValuePtr's bytes but don't change its ref count. - */ - - if (oldValuePtr == NULL) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - } else { - if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ - } - Tcl_AppendObjToObj(oldValuePtr, newValuePtr); - } - } - } else if (newValuePtr != oldValuePtr) { /* set new value */ - /* - * In this case we are replacing the value, so we don't need to - * do more than swap the objects. - */ - - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } - } - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - - /* - * Invoke any write traces for the variable. - */ - - if (varPtr->tracePtr != NULL) { - if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, - NULL, TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { - goto cleanup; - } - } - - /* - * Return the variable's value unless the variable was changed in some - * gross way by a trace (e.g. it was unset and then recreated as an - * array). If it was changed is a gross way, just return an empty string - * object. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - resultPtr = Tcl_NewObj(); - - /* - * If the variable doesn't exist anymore and no-one's using it, then - * free up the relevant structures and hash table entries. - */ - - cleanup: - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclSetElementOfIndexedArray -- - * - * Change the Tcl object value of an element in a local array - * variable. The element is named by the object elemPtr while the array - * is specified by its index in the active procedure's array of - * compiler allocated local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * element. If the specified array or element 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 if flags has TCL_LEAVE_ERR_MSG. Note that the - * returned object may not be the same one referenced by newValuePtr; - * this is because variable traces may modify the variable's value. - * - * Side effects: - * The value of the given array element is set. The reference count is - * decremented for any old value of the element and incremented for its - * new value. If as a result of a variable trace the new value for the - * element is not the same one referenced by newValuePtr, then - * newValuePtr's ref count is left unchanged. 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. This procedure will not create new - * array variables, but only sets elements of those arrays recognized - * at compile time. However, if the entry doesn't exist then a new - * variable is created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags) - Tcl_Interp *interp; /* Command interpreter in which the array is - * to be found. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to set in the array. */ - Tcl_Obj *newValuePtr; /* New value for variable. */ - int flags; /* Various flags that tell how to set value: - * any of TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - Var *arrayPtr; /* Points to the array's in-frame Var - * structure. */ - char *arrayName; /* Name of the local array. */ - char *elem; - Tcl_HashEntry *hPtr; - Var *varPtr = NULL; /* Points to the element's Var structure - * that we return. */ - Tcl_Obj *resultPtr = NULL; - Tcl_Obj *oldValuePtr; - int new; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element "); - fprintf(stderr, "of local %i in frame 0x%x, ", localIndex, - (unsigned int) varFramePtr); - fprintf(stderr, "no compiled locals\n"); - panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set element of "); - fprintf(stderr, "local %i in frame 0x%x ", localIndex, - (unsigned int) varFramePtr); - fprintf(stderr, "with %i locals\n", localCt); - panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - elem = TclGetString(elemPtr); - arrayPtr = &(compiledLocals[localIndex]); - arrayName = arrayPtr->name; - - /* - * If arrayPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - - /* - * If the variable is in a hashtable and its hPtr field is NULL, then we - * may have an upvar to an array element where the array was deleted - * or an upvar to a namespace variable whose namespace was deleted. - * Generate an error (allowing the variable to be reset would screw up - * our storage allocation and is meaningless anyway). - */ - - if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { - if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarArrayElement(arrayPtr)) { - VarErrMsg(interp, arrayName, elem, "set", danglingElement); - } else { - VarErrMsg(interp, arrayName, elem, "set", danglingVar); - } - } - goto errorReturn; - } - - /* - * Make sure we're dealing with an array. - */ - - if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { - TclSetVarArray(arrayPtr); - arrayPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); - TclClearVarUndefined(arrayPtr); - } else if (!TclIsVarArray(arrayPtr)) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, arrayName, elem, "set", needArray); - } - goto errorReturn; - } - - /* - * Look up the element. - */ - - hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); - if (new) { - if (arrayPtr->searchPtr != NULL) { - DeleteSearches(arrayPtr); - } - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varFramePtr->nsPtr; - TclSetVarArrayElement(varPtr); - } - varPtr = (Var *) Tcl_GetHashValue(hPtr); - - /* - * It's an error to try to set an array variable itself. - */ - - if (TclIsVarArray(varPtr)) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, arrayName, elem, "set", isArray); - } - goto errorReturn; - } - - /* - * Invoke any read traces that have been set for the variable if it - * is requested; this is only done in the core when lappending. - */ - - if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { - if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { - goto errorReturn; - } - } - - /* - * Set the variable's new value and discard the old one. - */ - - oldValuePtr = varPtr->value.objPtr; - if (flags & TCL_APPEND_VALUE) { - if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { - Tcl_DecrRefCount(oldValuePtr); /* discard old value */ - varPtr->value.objPtr = NULL; - oldValuePtr = NULL; - } - if (flags & TCL_LIST_ELEMENT) { /* append list element */ - if (oldValuePtr == NULL) { - TclNewObj(oldValuePtr); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ - } else if (Tcl_IsShared(oldValuePtr)) { - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - Tcl_DecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ - } - if (Tcl_ListObjAppendElement(interp, oldValuePtr, - newValuePtr) != TCL_OK) { - return NULL; - } - } else { /* append string */ - /* - * We append newValuePtr's bytes but don't change its ref count. - */ - - if (oldValuePtr == NULL) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - } else { - if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ - } - Tcl_AppendObjToObj(oldValuePtr, newValuePtr); - } - } - } else if (newValuePtr != oldValuePtr) { /* set new value */ - /* - * In this case we are replacing the value, so we don't need to - * do more than swap the objects. - */ - - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } - } - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - - /* - * Invoke any write traces for the element variable. - */ - - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { - goto errorReturn; - } - } - - /* - * Return the element's value unless it was changed in some gross way by - * a trace (e.g. it was unset and then recreated as an array). If it was - * changed is a gross way, just return an empty string object. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - resultPtr = Tcl_NewObj(); - - /* - * An error. If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. - */ - - errorReturn: - if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); /* note: array isn't in hashtable */ - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclIncrVar2 -- * * Given a two-part variable name, which may refer either to a scalar @@ -2653,215 +1853,6 @@ TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) /* *---------------------------------------------------------------------- * - * TclIncrIndexedScalar -- - * - * Increments the Tcl object value of a local scalar variable in the - * active procedure, given its compile-time allocated index in the - * procedure's array of local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * variable given by localIndex. 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. 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 * -TclIncrIndexedScalar(interp, localIndex, incrAmount) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ - int localIndex; /* Index of variable in procedure's array - * of local variables. */ - long incrAmount; /* Amount to be added to variable. */ -{ - 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). */ - long i; - - varValuePtr = TclGetIndexedScalar(interp, localIndex, TCL_LEAVE_ERR_MSG); - if (varValuePtr == NULL) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - return NULL; - } - - /* - * Reach into the object's representation to extract and 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)) { - createdNewObj = 1; - varValuePtr = Tcl_DuplicateObj(varValuePtr); - } -#ifdef TCL_WIDE_INT_IS_LONG - if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ - } - return NULL; - } - Tcl_SetLongObj(varValuePtr, (i + incrAmount)); -#else - if (varValuePtr->typePtr == &tclWideIntType) { - Tcl_WideInt wide = varValuePtr->internalRep.wideValue; - Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); - } else if (varValuePtr->typePtr == &tclIntType) { - i = varValuePtr->internalRep.longValue; - Tcl_SetIntObj(varValuePtr, i + incrAmount); - } else { - /* - * Not an integer or wide internal-rep... - */ - Tcl_WideInt wide; - if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ - } - return NULL; - } - if (wide <= Tcl_LongAsWide(LONG_MAX) - && wide >= Tcl_LongAsWide(LONG_MIN)) { - Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); - } else { - Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); - } - } -#endif - - /* - * Store the variable's new value and run any write traces. - */ - - return TclSetIndexedScalar(interp, localIndex, varValuePtr, - TCL_LEAVE_ERR_MSG); -} - -/* - *---------------------------------------------------------------------- - * - * TclIncrElementOfIndexedArray -- - * - * Increments the Tcl object value of an element in a local array - * variable. The element is named by the object elemPtr while the array - * is specified by its index in the active procedure's array of - * compiler allocated local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * element. If the specified array or element 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 array element is incremented by the specified - * amount. 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. If the - * entry doesn't exist then a new variable is created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) - Tcl_Interp *interp; /* Command interpreter in which the array is - * to be found. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to increment in the array. */ - long incrAmount; /* Amount to be added to variable. */ -{ - 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). */ - long i; - - varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, - TCL_LEAVE_ERR_MSG); - if (varValuePtr == NULL) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - return NULL; - } - - /* - * Reach into the object's representation to extract and 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)) { - createdNewObj = 1; - varValuePtr = Tcl_DuplicateObj(varValuePtr); - } -#ifdef TCL_WIDE_INT_IS_LONG - if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ - } - return NULL; - } - Tcl_SetLongObj(varValuePtr, (i + incrAmount)); -#else - if (varValuePtr->typePtr == &tclWideIntType) { - Tcl_WideInt wide = varValuePtr->internalRep.wideValue; - Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); - } else if (varValuePtr->typePtr == &tclIntType) { - i = varValuePtr->internalRep.longValue; - Tcl_SetIntObj(varValuePtr, i + incrAmount); - } else { - /* - * Not an integer or wide internal-rep... - */ - Tcl_WideInt wide; - if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ - } - return NULL; - } - if (wide <= Tcl_LongAsWide(LONG_MAX) - && wide >= Tcl_LongAsWide(LONG_MIN)) { - Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); - } else { - Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); - } - } -#endif - - /* - * Store the variable's new value and run any write traces. - */ - - return TclSetElementOfIndexedArray(interp, localIndex, elemPtr, - varValuePtr, TCL_LEAVE_ERR_MSG); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_UnsetVar -- * * Delete a variable, so that it may not be accessed anymore. @@ -6127,3 +5118,1004 @@ UpdateParsedVarName(objPtr) *p++ = ')'; *p = '\0'; } + +/* + * ****************************************************** + * Special functions for indexed variables + * + * These functions are not used any longer; as they were + * present in the internal stubs table, their removal has + * not been deemed safe at this time. + * + */ + +/* + *---------------------------------------------------------------------- + * + * TclGetIndexedScalar -- + * + * Return the Tcl object value of a local scalar variable in the active + * procedure, given its index in the procedure's array of compiler + * allocated local variables. + * + * Results: + * The return value points to the current object value of the variable + * given by localIndex. 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 if TCL_LEAVE_ERR_MSG is set in flags. + * + * Side effects: + * 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 * +TclGetIndexedScalar(interp, localIndex, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + register int localIndex; /* Index of variable in procedure's array + * of local variables. */ + int flags; /* TCL_LEAVE_ERR_MSG if to leave an error + * message in interpreter's result on an error. + * Otherwise no error message is left. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Var *compiledLocals = varFramePtr->compiledLocals; + register Var *varPtr; /* Points to the variable's in-frame Var + * structure. */ + char *varName; /* Name of the local variable. */ + CONST char *msg; + +#ifdef TCL_COMPILE_DEBUG + int localCt = varFramePtr->procPtr->numCompiledLocals; + + if (compiledLocals == NULL) { + fprintf(stderr, "\nTclGetIndexedScalar: can't get "); + fprintf(stderr, "local %i in frame 0x%x, ", localIndex, + (unsigned int) varFramePtr); + fprintf(stderr, "no compiled locals\n"); + panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); + } + if ((localIndex < 0) || (localIndex >= localCt)) { + fprintf(stderr, "\nTclGetIndexedScalar: can't get "); + fprintf(stderr, "local %i in frame 0x%x " localIndex, + (unsigned int) varFramePtr); + fprintf(stderr, "with %i locals\n", localCt); + panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); + } +#endif /* TCL_COMPILE_DEBUG */ + + varPtr = &(compiledLocals[localIndex]); + varName = varPtr->name; + + /* + * If varPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command, or we have a + * reference to a variable in an enclosing namespace. Traverse through + * any links until we find the referenced variable. + */ + + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + + /* + * Invoke any traces that have been set for the variable. + */ + + if (varPtr->tracePtr != NULL) { + if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, + NULL, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { + return NULL; + } + } + + /* + * Make sure we're dealing with a scalar variable and not an array, and + * that the variable exists (isn't undefined). + */ + + if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + if (TclIsVarArray(varPtr)) { + msg = isArray; + } else { + msg = noSuchVar; + } + VarErrMsg(interp, varName, NULL, "read", msg); + } + return NULL; + } + return varPtr->value.objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetElementOfIndexedArray -- + * + * Return the Tcl object value for an element in a local array + * variable. The element is named by the object elemPtr while the + * array is specified by its index in the active procedure's array + * of compiler allocated local variables. + * + * Results: + * The return value points to the current object value of the + * element. If the specified array or element 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 if TCL_LEAVE_ERR_MSG is set in flags. + * + * Side effects: + * 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 * +TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + int localIndex; /* Index of array variable in procedure's + * array of local variables. */ + Tcl_Obj *elemPtr; /* Points to an object holding the name of + * an element to get in the array. */ + int flags; /* TCL_LEAVE_ERR_MSG if to leave an error + * message in interpreter's result on an error. + * Otherwise no error message is left. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Var *compiledLocals = varFramePtr->compiledLocals; + Var *arrayPtr; /* Points to the array's in-frame Var + * structure. */ + char *arrayName; /* Name of the local array. */ + Tcl_HashEntry *hPtr; + Var *varPtr = NULL; /* Points to the element's Var structure + * that we return. Initialized to avoid + * compiler warning. */ + CONST char *elem, *msg; + int new; + +#ifdef TCL_COMPILE_DEBUG + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + + if (compiledLocals == NULL) { + fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element "); + fprintf(stderr, "of local %i in frame 0x%x, " localIndex, + (unsigned int) varFramePtr); + fprintf(stderr, "no compiled locals\n"); + panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); + } + if ((localIndex < 0) || (localIndex >= localCt)) { + fprintf(stderr, "\nTclGetIndexedScalar: can't get element of " + "local %i in frame 0x%x with %i locals\n", localIndex, + (unsigned int) varFramePtr, localCt); + panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); + } +#endif /* TCL_COMPILE_DEBUG */ + + elem = TclGetString(elemPtr); + arrayPtr = &(compiledLocals[localIndex]); + arrayName = arrayPtr->name; + + /* + * If arrayPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command, or we have a + * reference to a variable in an enclosing namespace. Traverse through + * any links until we find the referenced variable. + */ + + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + + /* + * Make sure we're dealing with an array and that the array variable + * exists (isn't undefined). + */ + + if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, arrayName, elem, "read", noSuchVar); + } + goto errorReturn; + } + + /* + * Look up the element. Note that we must create the element (but leave + * it marked undefined) if it does not already exist. This allows a + * trace to create new array elements "on the fly" that did not exist + * before. A trace is always passed a variable for the array element. If + * the trace does not define the variable, it will be deleted below (at + * errorReturn) and an error returned. + */ + + hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); + if (new) { + if (arrayPtr->searchPtr != NULL) { + DeleteSearches(arrayPtr); + } + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = varFramePtr->nsPtr; + TclSetVarArrayElement(varPtr); + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + } + + /* + * Invoke any traces that have been set for the element variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, + TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { + goto errorReturn; + } + } + + /* + * Return the element if it's an existing scalar variable. + */ + + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { + return varPtr->value.objPtr; + } + + if (flags & TCL_LEAVE_ERR_MSG) { + if (TclIsVarArray(varPtr)) { + msg = isArray; + } else { + msg = noSuchVar; + } + VarErrMsg(interp, arrayName, elem, "read", msg); + } + + /* + * An error. If the variable doesn't exist anymore and no-one's using + * it, then free up the relevant structures and hash table entries. + */ + + errorReturn: + if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, NULL); /* the array is not in a hashtable */ + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetIndexedScalar -- + * + * Change the Tcl object value of a local scalar variable in the active + * procedure, given its compile-time allocated index in the procedure's + * array of local variables. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable given by localIndex. 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 if flags has TCL_LEAVE_ERR_MSG. + * Note that the returned object may not be the same one referenced by + * newValuePtr; this is because variable traces may modify the + * variable's value. + * + * Side effects: + * The value of the given variable is set. The reference count is + * decremented for any old value of the variable and incremented for + * its new value. If as a result of a variable trace the new value for + * the variable is not the same one referenced by newValuePtr, then + * newValuePtr's ref count is left unchanged. 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. This procedure does not create + * new variables, but only sets those recognized at compile time. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclSetIndexedScalar(interp, localIndex, newValuePtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + int localIndex; /* Index of variable in procedure's array + * of local variables. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Var *compiledLocals = varFramePtr->compiledLocals; + register Var *varPtr; /* Points to the variable's in-frame Var + * structure. */ + char *varName; /* Name of the local variable. */ + Tcl_Obj *oldValuePtr; + Tcl_Obj *resultPtr = NULL; + +#ifdef TCL_COMPILE_DEBUG + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + + if (compiledLocals == NULL) { + fprintf(stderr, "\nTclSetIndexedScalar: can't set "); + fprintf(stderr, "local %i in ", localIndex); + fprintf(stderr, "frame 0x%x, no compiled locals\n", + (unsigned int) varFramePtr); + panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); + } + if ((localIndex < 0) || (localIndex >= localCt)) { + fprintf(stderr, "\nTclSetIndexedScalar: can't set "); + fprintf(stderr, "local %i in " localIndex); + fprintf(stderr, "frame 0x%x with %i locals\n", + (unsigned int) varFramePtr, localCt); + panic("TclSetIndexedScalar: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); + } +#endif /* TCL_COMPILE_DEBUG */ + + varPtr = &(compiledLocals[localIndex]); + varName = varPtr->name; + + /* + * If varPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command, or we have a + * reference to a variable in an enclosing namespace. Traverse through + * any links until we find the referenced variable. + */ + + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + + /* + * Invoke any read traces that have been set for the variable if it + * is requested; this is only done in the core when lappending. + */ + + if ((flags & TCL_TRACE_READS) && (varPtr->tracePtr != NULL)) { + if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, + NULL, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { + return NULL; + } + } + + /* + * If the variable is in a hashtable and its hPtr field is NULL, then we + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). + */ + + if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if (flags & TCL_LEAVE_ERR_MSG) { + if (TclIsVarArrayElement(varPtr)) { + VarErrMsg(interp, varName, NULL, "set", danglingElement); + } else { + VarErrMsg(interp, varName, NULL, "set", danglingVar); + } + } + return NULL; + } + + /* + * It's an error to try to set an array variable itself. + */ + + if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, varName, NULL, "set", isArray); + } + return NULL; + } + + /* + * Set the variable's new value and discard its old value. + */ + + oldValuePtr = varPtr->value.objPtr; + if (flags & TCL_APPEND_VALUE) { + if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { + Tcl_DecrRefCount(oldValuePtr); /* discard old value */ + varPtr->value.objPtr = NULL; + oldValuePtr = NULL; + } + if (flags & TCL_LIST_ELEMENT) { /* append list element */ + if (oldValuePtr == NULL) { + TclNewObj(oldValuePtr); + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + Tcl_DecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + } + if (Tcl_ListObjAppendElement(interp, oldValuePtr, + newValuePtr) != TCL_OK) { + return NULL; + } + } else { /* append string */ + /* + * We append newValuePtr's bytes but don't change its ref count. + */ + + if (oldValuePtr == NULL) { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } else { + if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ + } + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + } + } + } else if (newValuePtr != oldValuePtr) { /* set new value */ + /* + * In this case we are replacing the value, so we don't need to + * do more than swap the objects. + */ + + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); /* discard old value */ + } + } + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + + /* + * Invoke any write traces for the variable. + */ + + if (varPtr->tracePtr != NULL) { + if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, + NULL, TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { + goto cleanup; + } + } + + /* + * Return the variable's value unless the variable was changed in some + * gross way by a trace (e.g. it was unset and then recreated as an + * array). If it was changed is a gross way, just return an empty string + * object. + */ + + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { + return varPtr->value.objPtr; + } + + resultPtr = Tcl_NewObj(); + + /* + * If the variable doesn't exist anymore and no-one's using it, then + * free up the relevant structures and hash table entries. + */ + + cleanup: + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, NULL); + } + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetElementOfIndexedArray -- + * + * Change the Tcl object value of an element in a local array + * variable. The element is named by the object elemPtr while the array + * is specified by its index in the active procedure's array of + * compiler allocated local variables. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * element. If the specified array or element 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 if flags has TCL_LEAVE_ERR_MSG. Note that the + * returned object may not be the same one referenced by newValuePtr; + * this is because variable traces may modify the variable's value. + * + * Side effects: + * The value of the given array element is set. The reference count is + * decremented for any old value of the element and incremented for its + * new value. If as a result of a variable trace the new value for the + * element is not the same one referenced by newValuePtr, then + * newValuePtr's ref count is left unchanged. 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. This procedure will not create new + * array variables, but only sets elements of those arrays recognized + * at compile time. However, if the entry doesn't exist then a new + * variable is created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags) + Tcl_Interp *interp; /* Command interpreter in which the array is + * to be found. */ + int localIndex; /* Index of array variable in procedure's + * array of local variables. */ + Tcl_Obj *elemPtr; /* Points to an object holding the name of + * an element to set in the array. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Var *compiledLocals = varFramePtr->compiledLocals; + Var *arrayPtr; /* Points to the array's in-frame Var + * structure. */ + char *arrayName; /* Name of the local array. */ + char *elem; + Tcl_HashEntry *hPtr; + Var *varPtr = NULL; /* Points to the element's Var structure + * that we return. */ + Tcl_Obj *resultPtr = NULL; + Tcl_Obj *oldValuePtr; + int new; + +#ifdef TCL_COMPILE_DEBUG + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + + if (compiledLocals == NULL) { + fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element "); + fprintf(stderr, "of local %i in frame 0x%x, ", localIndex, + (unsigned int) varFramePtr); + fprintf(stderr, "no compiled locals\n"); + panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); + } + if ((localIndex < 0) || (localIndex >= localCt)) { + fprintf(stderr, "\nTclSetIndexedScalar: can't set element of "); + fprintf(stderr, "local %i in frame 0x%x ", localIndex, + (unsigned int) varFramePtr); + fprintf(stderr, "with %i locals\n", localCt); + panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); + } +#endif /* TCL_COMPILE_DEBUG */ + + elem = TclGetString(elemPtr); + arrayPtr = &(compiledLocals[localIndex]); + arrayName = arrayPtr->name; + + /* + * If arrayPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command, or we have a + * reference to a variable in an enclosing namespace. Traverse through + * any links until we find the referenced variable. + */ + + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + + /* + * If the variable is in a hashtable and its hPtr field is NULL, then we + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). + */ + + if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { + if (flags & TCL_LEAVE_ERR_MSG) { + if (TclIsVarArrayElement(arrayPtr)) { + VarErrMsg(interp, arrayName, elem, "set", danglingElement); + } else { + VarErrMsg(interp, arrayName, elem, "set", danglingVar); + } + } + goto errorReturn; + } + + /* + * Make sure we're dealing with an array. + */ + + if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { + TclSetVarArray(arrayPtr); + arrayPtr->value.tablePtr = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); + TclClearVarUndefined(arrayPtr); + } else if (!TclIsVarArray(arrayPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, arrayName, elem, "set", needArray); + } + goto errorReturn; + } + + /* + * Look up the element. + */ + + hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); + if (new) { + if (arrayPtr->searchPtr != NULL) { + DeleteSearches(arrayPtr); + } + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = varFramePtr->nsPtr; + TclSetVarArrayElement(varPtr); + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + + /* + * It's an error to try to set an array variable itself. + */ + + if (TclIsVarArray(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, arrayName, elem, "set", isArray); + } + goto errorReturn; + } + + /* + * Invoke any read traces that have been set for the variable if it + * is requested; this is only done in the core when lappending. + */ + + if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, + TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { + goto errorReturn; + } + } + + /* + * Set the variable's new value and discard the old one. + */ + + oldValuePtr = varPtr->value.objPtr; + if (flags & TCL_APPEND_VALUE) { + if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { + Tcl_DecrRefCount(oldValuePtr); /* discard old value */ + varPtr->value.objPtr = NULL; + oldValuePtr = NULL; + } + if (flags & TCL_LIST_ELEMENT) { /* append list element */ + if (oldValuePtr == NULL) { + TclNewObj(oldValuePtr); + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + Tcl_DecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ + } + if (Tcl_ListObjAppendElement(interp, oldValuePtr, + newValuePtr) != TCL_OK) { + return NULL; + } + } else { /* append string */ + /* + * We append newValuePtr's bytes but don't change its ref count. + */ + + if (oldValuePtr == NULL) { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } else { + if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ + } + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + } + } + } else if (newValuePtr != oldValuePtr) { /* set new value */ + /* + * In this case we are replacing the value, so we don't need to + * do more than swap the objects. + */ + + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); /* discard old value */ + } + } + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + + /* + * Invoke any write traces for the element variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, + TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { + goto errorReturn; + } + } + + /* + * Return the element's value unless it was changed in some gross way by + * a trace (e.g. it was unset and then recreated as an array). If it was + * changed is a gross way, just return an empty string object. + */ + + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { + return varPtr->value.objPtr; + } + + resultPtr = Tcl_NewObj(); + + /* + * An error. If the variable doesn't exist anymore and no-one's using + * it, then free up the relevant structures and hash table entries. + */ + + errorReturn: + if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, NULL); /* note: array isn't in hashtable */ + } + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclIncrIndexedScalar -- + * + * Increments the Tcl object value of a local scalar variable in the + * active procedure, given its compile-time allocated index in the + * procedure's array of local variables. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable given by localIndex. 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. 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 * +TclIncrIndexedScalar(interp, localIndex, incrAmount) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + int localIndex; /* Index of variable in procedure's array + * of local variables. */ + long incrAmount; /* Amount to be added to variable. */ +{ + 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). */ + long i; + + varValuePtr = TclGetIndexedScalar(interp, localIndex, TCL_LEAVE_ERR_MSG); + if (varValuePtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + + /* + * Reach into the object's representation to extract and 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)) { + createdNewObj = 1; + varValuePtr = Tcl_DuplicateObj(varValuePtr); + } +#ifdef TCL_WIDE_INT_IS_LONG + if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + Tcl_SetLongObj(varValuePtr, (i + incrAmount)); +#else + if (varValuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wide = varValuePtr->internalRep.wideValue; + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } else if (varValuePtr->typePtr == &tclIntType) { + i = varValuePtr->internalRep.longValue; + Tcl_SetIntObj(varValuePtr, i + incrAmount); + } else { + /* + * Not an integer or wide internal-rep... + */ + Tcl_WideInt wide; + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + if (wide <= Tcl_LongAsWide(LONG_MAX) + && wide >= Tcl_LongAsWide(LONG_MIN)) { + Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); + } else { + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } + } +#endif + + /* + * Store the variable's new value and run any write traces. + */ + + return TclSetIndexedScalar(interp, localIndex, varValuePtr, + TCL_LEAVE_ERR_MSG); +} + +/* + *---------------------------------------------------------------------- + * + * TclIncrElementOfIndexedArray -- + * + * Increments the Tcl object value of an element in a local array + * variable. The element is named by the object elemPtr while the array + * is specified by its index in the active procedure's array of + * compiler allocated local variables. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * element. If the specified array or element 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 array element is incremented by the specified + * amount. 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. If the + * entry doesn't exist then a new variable is created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) + Tcl_Interp *interp; /* Command interpreter in which the array is + * to be found. */ + int localIndex; /* Index of array variable in procedure's + * array of local variables. */ + Tcl_Obj *elemPtr; /* Points to an object holding the name of + * an element to increment in the array. */ + long incrAmount; /* Amount to be added to variable. */ +{ + 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). */ + long i; + + varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, + TCL_LEAVE_ERR_MSG); + if (varValuePtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + + /* + * Reach into the object's representation to extract and 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)) { + createdNewObj = 1; + varValuePtr = Tcl_DuplicateObj(varValuePtr); + } +#ifdef TCL_WIDE_INT_IS_LONG + if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + Tcl_SetLongObj(varValuePtr, (i + incrAmount)); +#else + if (varValuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wide = varValuePtr->internalRep.wideValue; + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } else if (varValuePtr->typePtr == &tclIntType) { + i = varValuePtr->internalRep.longValue; + Tcl_SetIntObj(varValuePtr, i + incrAmount); + } else { + /* + * Not an integer or wide internal-rep... + */ + Tcl_WideInt wide; + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + if (wide <= Tcl_LongAsWide(LONG_MAX) + && wide >= Tcl_LongAsWide(LONG_MIN)) { + Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); + } else { + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } + } +#endif + + /* + * Store the variable's new value and run any write traces. + */ + + return TclSetElementOfIndexedArray(interp, localIndex, elemPtr, + varValuePtr, TCL_LEAVE_ERR_MSG); +} |