summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2002-07-17 18:21:53 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2002-07-17 18:21:53 (GMT)
commit023276a9b9bbb4085068a13aafc1ed53f72ea197 (patch)
treee51d5d4dbb02babd0b3776e7d1e1d0f8d70c9a8c
parent3c26f7d2cb401292666bdb968313497537a8301b (diff)
downloadtcl-023276a9b9bbb4085068a13aafc1ed53f72ea197.zip
tcl-023276a9b9bbb4085068a13aafc1ed53f72ea197.tar.gz
tcl-023276a9b9bbb4085068a13aafc1ed53f72ea197.tar.bz2
removing the now redundant functions Tcl(Get|Set|Incr)IndexedScalar()
and Tcl(Get|Set|Incr)ElementOfIndexedArray()
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclInt.decls56
-rw-r--r--generic/tclIntDecls.h73
-rw-r--r--generic/tclStubInit.c14
-rw-r--r--generic/tclVar.c1003
5 files changed, 67 insertions, 1088 deletions
diff --git a/ChangeLog b/ChangeLog
index facee55..da88795 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclInt.decls:
+ * generic/tclIntDecls.h:
+ * generic/tclStubInit.c:
+ * generic/tclVar.c: removing the now redundant functions to access
+ indexed variables: Tcl(Get|Set|Incr)IndexedScalar() and
+ Tcl(Get|Set|Incr)ElementOfIndexedArray().
+
2002-07-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclExecute.c (TclExecuteByteCode): Minor fixes to make
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 258498a..63d47ad 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.52 2002/07/15 22:18:04 msofer Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.53 2002/07/17 18:21:54 msofer Exp $
library tcl
@@ -130,10 +130,11 @@ declare 27 generic {
declare 28 generic {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
-declare 29 generic {
- Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp,
- int localIndex, Tcl_Obj *elemPtr, int flags)
-}
+# Removed in 8.4b2:
+#declare 29 generic {
+# Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp,
+# int localIndex, Tcl_Obj *elemPtr, int flags)
+#}
# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
# declare 30 generic {
# char * TclGetEnv(CONST char *name)
@@ -152,10 +153,11 @@ declare 34 generic {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
-declare 35 generic {
- Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
- int flags)
-}
+# Removed in 8.4b2:
+#declare 35 generic {
+# Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
+# int flags)
+#}
declare 36 generic {
int TclGetLong(Tcl_Interp *interp, CONST char *str, long *longPtr)
}
@@ -192,14 +194,16 @@ declare 45 generic {
declare 46 generic {
int TclInExit(void)
}
-declare 47 generic {
- Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp,
- int localIndex, Tcl_Obj *elemPtr, long incrAmount)
-}
-declare 48 generic {
- Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
- long incrAmount)
-}
+# Removed in 8.4b2:
+#declare 47 generic {
+# Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp,
+# int localIndex, Tcl_Obj *elemPtr, long incrAmount)
+#}
+# Removed in 8.4b2:
+#declare 48 generic {
+# Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
+# long incrAmount)
+#}
declare 49 generic {
Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
@@ -385,14 +389,16 @@ declare 97 generic {
declare 98 generic {
int TclServiceIdle(void)
}
-declare 99 generic {
- Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
- Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
-}
-declare 100 generic {
- Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
- Tcl_Obj *objPtr, int flags)
-}
+# Removed in 8.4b2:
+#declare 99 generic {
+# Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
+# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
+#}
+# Removed in 8.4b2:
+#declare 100 generic {
+# Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
+# Tcl_Obj *objPtr, int flags)
+#}
declare 101 {unix win} {
char * TclSetPreInitScript(char *string)
}
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 9fbd8ac..5d7f063 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.43 2002/07/15 22:18:06 msofer Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.44 2002/07/17 18:21:54 msofer Exp $
*/
#ifndef _TCLINTDECLS
@@ -119,10 +119,7 @@ EXTERN int TclGetDate _ANSI_ARGS_((char * p, unsigned long now,
long zone, unsigned long * timePtr));
/* 28 */
EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
-/* 29 */
-EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp * interp, int localIndex,
- Tcl_Obj * elemPtr, int flags));
+/* Slot 29 is reserved */
/* Slot 30 is reserved */
/* 31 */
EXTERN char * TclGetExtension _ANSI_ARGS_((char * name));
@@ -135,9 +132,7 @@ EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void));
EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, int endValue,
int * indexPtr));
-/* 35 */
-EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp,
- int localIndex, int flags));
+/* Slot 35 is reserved */
/* 36 */
EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp,
CONST char * str, long * longPtr));
@@ -174,14 +169,8 @@ EXTERN int TclHideUnsafeCommands _ANSI_ARGS_((
Tcl_Interp * interp));
/* 46 */
EXTERN int TclInExit _ANSI_ARGS_((void));
-/* 47 */
-EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp * interp, int localIndex,
- Tcl_Obj * elemPtr, long incrAmount));
-/* 48 */
-EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_((
- Tcl_Interp * interp, int localIndex,
- long incrAmount));
+/* Slot 47 is reserved */
+/* Slot 48 is reserved */
/* 49 */
EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
@@ -293,14 +282,8 @@ EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_((
Tcl_Interp * interp, Command * newCmdPtr));
/* 98 */
EXTERN int TclServiceIdle _ANSI_ARGS_((void));
-/* 99 */
-EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp * interp, int localIndex,
- Tcl_Obj * elemPtr, Tcl_Obj * objPtr,
- int flags));
-/* 100 */
-EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp,
- int localIndex, Tcl_Obj * objPtr, int flags));
+/* Slot 99 is reserved */
+/* Slot 100 is reserved */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 101 */
EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string));
@@ -568,13 +551,13 @@ typedef struct TclIntStubs {
void *reserved26;
int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
- Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int flags)); /* 29 */
+ void *reserved29;
void *reserved30;
char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 32 */
TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
- Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int flags)); /* 35 */
+ void *reserved35;
int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * longPtr)); /* 36 */
int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */
@@ -586,8 +569,8 @@ typedef struct TclIntStubs {
int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */
int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
- Tcl_Obj * (*tclIncrElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, long incrAmount)); /* 47 */
- Tcl_Obj * (*tclIncrIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, long incrAmount)); /* 48 */
+ void *reserved47;
+ void *reserved48;
Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */
void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
@@ -638,8 +621,8 @@ typedef struct TclIntStubs {
int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
- Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int flags)); /* 99 */
- Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int flags)); /* 100 */
+ void *reserved99;
+ void *reserved100;
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
#endif /* UNIX */
@@ -848,10 +831,7 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclpGetDefaultStdChannel \
(tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */
#endif
-#ifndef TclGetElementOfIndexedArray
-#define TclGetElementOfIndexedArray \
- (tclIntStubsPtr->tclGetElementOfIndexedArray) /* 29 */
-#endif
+/* Slot 29 is reserved */
/* Slot 30 is reserved */
#ifndef TclGetExtension
#define TclGetExtension \
@@ -869,10 +849,7 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclGetIntForIndex \
(tclIntStubsPtr->tclGetIntForIndex) /* 34 */
#endif
-#ifndef TclGetIndexedScalar
-#define TclGetIndexedScalar \
- (tclIntStubsPtr->tclGetIndexedScalar) /* 35 */
-#endif
+/* Slot 35 is reserved */
#ifndef TclGetLong
#define TclGetLong \
(tclIntStubsPtr->tclGetLong) /* 36 */
@@ -917,14 +894,8 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclInExit \
(tclIntStubsPtr->tclInExit) /* 46 */
#endif
-#ifndef TclIncrElementOfIndexedArray
-#define TclIncrElementOfIndexedArray \
- (tclIntStubsPtr->tclIncrElementOfIndexedArray) /* 47 */
-#endif
-#ifndef TclIncrIndexedScalar
-#define TclIncrIndexedScalar \
- (tclIntStubsPtr->tclIncrIndexedScalar) /* 48 */
-#endif
+/* Slot 47 is reserved */
+/* Slot 48 is reserved */
#ifndef TclIncrVar2
#define TclIncrVar2 \
(tclIntStubsPtr->tclIncrVar2) /* 49 */
@@ -1071,14 +1042,8 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclServiceIdle \
(tclIntStubsPtr->tclServiceIdle) /* 98 */
#endif
-#ifndef TclSetElementOfIndexedArray
-#define TclSetElementOfIndexedArray \
- (tclIntStubsPtr->tclSetElementOfIndexedArray) /* 99 */
-#endif
-#ifndef TclSetIndexedScalar
-#define TclSetIndexedScalar \
- (tclIntStubsPtr->tclSetIndexedScalar) /* 100 */
-#endif
+/* Slot 99 is reserved */
+/* Slot 100 is reserved */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef TclSetPreInitScript
#define TclSetPreInitScript \
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ef55072..eb9480b 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.72 2002/06/17 22:52:51 hobbs Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.73 2002/07/17 18:21:55 msofer Exp $
*/
#include "tclInt.h"
@@ -92,13 +92,13 @@ TclIntStubs tclIntStubs = {
NULL, /* 26 */
TclGetDate, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
- TclGetElementOfIndexedArray, /* 29 */
+ NULL, /* 29 */
NULL, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
TclGetInterpProc, /* 33 */
TclGetIntForIndex, /* 34 */
- TclGetIndexedScalar, /* 35 */
+ NULL, /* 35 */
TclGetLong, /* 36 */
TclGetLoadedPackages, /* 37 */
TclGetNamespaceForQualName, /* 38 */
@@ -110,8 +110,8 @@ TclIntStubs tclIntStubs = {
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
- TclIncrElementOfIndexedArray, /* 47 */
- TclIncrIndexedScalar, /* 48 */
+ NULL, /* 47 */
+ NULL, /* 48 */
TclIncrVar2, /* 49 */
TclInitCompiledLocals, /* 50 */
TclInterpInit, /* 51 */
@@ -162,8 +162,8 @@ TclIntStubs tclIntStubs = {
TclRenameCommand, /* 96 */
TclResetShadowedCmdRefs, /* 97 */
TclServiceIdle, /* 98 */
- TclSetElementOfIndexedArray, /* 99 */
- TclSetIndexedScalar, /* 100 */
+ NULL, /* 99 */
+ NULL, /* 100 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
TclSetPreInitScript, /* 101 */
#endif /* UNIX */
diff --git a/generic/tclVar.c b/generic/tclVar.c
index d8c9aad..d20f7e3 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.57 2002/07/17 10:36:23 msofer Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.58 2002/07/17 18:21:55 msofer Exp $
*/
#include "tclInt.h"
@@ -5118,1004 +5118,3 @@ 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);
-}