summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2002-07-17 10:36:21 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2002-07-17 10:36:21 (GMT)
commit239854b80c97ffda9f1300635a18bfb1350c1e53 (patch)
tree4d1cb86aa902e81bdefccdaf0a4fd9875459360e /generic
parentc5f54ca90775a8e1f51e53d2a87a5898b613a90f (diff)
downloadtcl-239854b80c97ffda9f1300635a18bfb1350c1e53.zip
tcl-239854b80c97ffda9f1300635a18bfb1350c1e53.tar.gz
tcl-239854b80c97ffda9f1300635a18bfb1350c1e53.tar.bz2
variable access optimisations
Diffstat (limited to 'generic')
-rw-r--r--generic/tclExecute.c650
-rw-r--r--generic/tclInt.h26
-rw-r--r--generic/tclVar.c2016
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);
+}